From 82da33707f2cb433f6bbcc22cd32750d6462fa0f Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 9 Jun 2024 03:18:59 +0800 Subject: [PATCH] Unify critical session running in hls (#4256) * add thread to do shake restart * run session loader in thread --------- Co-authored-by: Michael Peyton Jones --- ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 51 +++++++-------- ghcide/src/Development/IDE/Core/Service.hs | 3 +- ghcide/src/Development/IDE/Core/Shake.hs | 64 ++++++++++++------- .../src/Development/IDE/Core/WorkerThread.hs | 54 ++++++++++++++++ .../src/Development/IDE/LSP/LanguageServer.hs | 34 ++++++---- ghcide/src/Development/IDE/Main.hs | 25 ++++---- ghcide/src/Development/IDE/Types/Shake.hs | 5 +- 8 files changed, 159 insertions(+), 78 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/WorkerThread.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index d9c4c1ae53..7c319fb8f3 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -148,6 +148,7 @@ library Development.IDE.Core.Shake Development.IDE.Core.Tracing Development.IDE.Core.UseStale + Development.IDE.Core.WorkerThread Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core Development.IDE.GHC.Compat.CmdLine diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index dcb65d2924..aaa74bcc8c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -7,21 +7,19 @@ The logic for setting up a ghcide session by tapping into hie-bios. module Development.IDE.Session (SessionLoadingOptions(..) ,CacheDirs(..) - ,loadSession ,loadSessionWithOptions ,setInitialDynFlags ,getHieDbLoc - ,runWithDb ,retryOnSqliteBusy ,retryOnException ,Log(..) + ,runWithDb ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses -- the real GHC library and the types are incompatible. Furthermore, when -- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios! -import Control.Concurrent.Async import Control.Concurrent.Strict import Control.Exception.Safe as Safe import Control.Monad @@ -100,14 +98,19 @@ import Control.Concurrent.STM.TQueue import Control.DeepSeq import Control.Exception (evaluate) import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Cont (ContT (ContT, runContT)) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) +import Development.IDE.Core.WorkerThread (awaitRunInThread, + withWorkerQueue) import Development.IDE.Session.Diagnostics (renderCradleError) -import Development.IDE.Types.Shake (WithHieDb, toNoFileKey) +import Development.IDE.Types.Shake (WithHieDb, + WithHieDbShield (..), + toNoFileKey) import HieDb.Create import HieDb.Types import HieDb.Utils @@ -375,8 +378,10 @@ makeWithHieDbRetryable recorder rng hieDb f = -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial -- by a worker thread using a dedicated database connection. -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () -runWithDb recorder fp k = do +-- +-- Also see Note [Serializing runs in separate thread] +runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue) +runWithDb recorder fp = ContT $ \k -> do -- use non-deterministic seed because maybe multiple HLS start at same time -- and send bursts of requests rng <- Random.newStdGen @@ -394,18 +399,15 @@ runWithDb recorder fp k = do withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb withWriteDbRetryable initConn - chan <- newTQueueIO - withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do - withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan) + -- Clear the index of any files that might have been deleted since the last run + _ <- withWriteDbRetryable deleteMissingRealFiles + _ <- withWriteDbRetryable garbageCollectTypeNames + + runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan -> + withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan)) where - writerThread :: WithHieDb -> IndexQueue -> IO () - writerThread withHieDbRetryable chan = do - -- Clear the index of any files that might have been deleted since the last run - _ <- withHieDbRetryable deleteMissingRealFiles - _ <- withHieDbRetryable garbageCollectTypeNames - forever $ do - l <- atomically $ readTQueue chan + writer withHieDbRetryable l = do -- TODO: probably should let exceptions be caught/logged/handled by top level handler l withHieDbRetryable `Safe.catch` \e@SQLError{} -> do @@ -435,11 +437,9 @@ getHieDbLoc dir = do -- This is the key function which implements multi-component support. All -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. -loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) -loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) +loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file @@ -464,9 +464,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let res' = toAbsolutePath <$> res return $ normalise <$> res' - dummyAs <- async $ return (error "Uninitialised") - runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) - return $ do clientConfig <- getClientConfigAction extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv @@ -739,12 +736,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - opts <- join $ mask_ $ modifyVar runningCradle $ \as -> do - -- If the cradle is not finished, then wait for it to finish. - void $ wait as - asyncRes <- async $ getOptions file - return (asyncRes, wait asyncRes) - pure opts + -- see Note [Serializing runs in separate thread] + awaitRunInThread que $ getOptions file -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 1ad02b4db4..52639aeb22 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -53,6 +53,7 @@ instance Pretty Log where LogOfInterest msg -> pretty msg LogFileExists msg -> pretty msg + ------------------------------------------------------------ -- Exposed API @@ -65,7 +66,7 @@ initialise :: Recorder (WithPriority Log) -> Debouncer LSP.NormalizedUri -> IdeOptions -> WithHieDb - -> IndexQueue + -> ThreadQueue -> Monitoring -> FilePath -- ^ Root directory see Note [Root Directory] -> IO IdeState diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f759fabf63..d426ba34f8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -73,6 +73,7 @@ module Development.IDE.Core.Shake( garbageCollectDirtyKeysOlderThan, Log(..), VFSModified(..), getClientConfigAction, + ThreadQueue(..) ) where import Control.Concurrent.Async @@ -123,6 +124,7 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing +import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, initNameCache, knownKeyNames) @@ -262,6 +264,12 @@ data HieDbWriter -- with (currently) retry functionality type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +data ThreadQueue = ThreadQueue { + tIndexQueue :: IndexQueue + , tRestartQueue :: TQueue (IO ()) + , tLoaderQueue :: TQueue (IO ()) +} + -- Note [Semantic Tokens Cache Location] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- storing semantic tokens cache for each file in shakeExtras might @@ -334,6 +342,10 @@ data ShakeExtras = ShakeExtras -- ^ Default HLS config, only relevant if the client does not provide any Config , dirtyKeys :: TVar KeySet -- ^ Set of dirty rule keys since the last Shake run + , restartQueue :: TQueue (IO ()) + -- ^ Queue of restart actions to be run. + , loaderQueue :: TQueue (IO ()) + -- ^ Queue of loader actions to be run. } type WithProgressFunc = forall a. @@ -648,7 +660,7 @@ shakeOpen :: Recorder (WithPriority Log) -> IdeReportProgress -> IdeTesting -> WithHieDb - -> IndexQueue + -> ThreadQueue -> ShakeOptions -> Monitoring -> Rules () @@ -658,8 +670,12 @@ shakeOpen :: Recorder (WithPriority Log) -> IO IdeState shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) - ideTesting@(IdeTesting testing) - withHieDb indexQueue opts monitoring rules rootDir = mdo + ideTesting + withHieDb threadQueue opts monitoring rules rootDir = mdo + -- see Note [Serializing runs in separate thread] + let indexQueue = tIndexQueue threadQueue + restartQueue = tRestartQueue threadQueue + loaderQueue = tLoaderQueue threadQueue #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames @@ -784,31 +800,33 @@ delayedAction a = do extras <- ask liftIO $ shakeEnqueue extras a + -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = - withMVar' - shakeSession - (\runner -> do - (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - keys <- ioActionBetweenShakeSession - -- it is every important to update the dirty keys after we enter the critical section - -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys - res <- shakeDatabaseProfile shakeDb - backlog <- readTVarIO $ dirtyKeys shakeExtras - queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - - -- this log is required by tests - logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res - ) - -- It is crucial to be masked here, otherwise we can get killed - -- between spawning the new thread and updating shakeSession. - -- See https://github.com/haskell/ghcide/issues/79 - (\() -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) + void $ awaitRunInThread (restartQueue shakeExtras) $ do + withMVar' + shakeSession + (\runner -> do + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + keys <- ioActionBetweenShakeSession + -- it is every important to update the dirty keys after we enter the critical section + -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + res <- shakeDatabaseProfile shakeDb + backlog <- readTVarIO $ dirtyKeys shakeExtras + queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras + + -- this log is required by tests + logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res + ) + -- It is crucial to be masked here, otherwise we can get killed + -- between spawning the new thread and updating shakeSession. + -- See https://github.com/haskell/ghcide/issues/79 + (\() -> do + (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) where logErrorAfter :: Seconds -> IO () -> IO () logErrorAfter seconds action = flip withAsync (const action) $ do diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs new file mode 100644 index 0000000000..a38da77f38 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -0,0 +1,54 @@ +{- +Module : Development.IDE.Core.WorkerThread +Author : @soulomoon +SPDX-License-Identifier: Apache-2.0 + +Description : This module provides an API for managing worker threads in the IDE. +see Note [Serializing runs in separate thread] +-} +module Development.IDE.Core.WorkerThread + (withWorkerQueue, awaitRunInThread) + where + +import Control.Concurrent.Async (withAsync) +import Control.Concurrent.STM +import Control.Concurrent.Strict (newBarrier, signalBarrier, + waitBarrier) +import Control.Monad (forever) +import Control.Monad.Cont (ContT (ContT)) + +{- +Note [Serializing runs in separate thread] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We often want to take long-running actions using some resource that cannot be shared. +In this instance it is useful to have a queue of jobs to run using the resource. +Like the db writes, session loading in session loader, shake session restarts. + +Originally we used various ways to implement this, but it was hard to maintain and error prone. +Moreover, we can not stop these threads uniformly when we are shutting down the server. +-} + +-- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker +-- thread which polls the queue for requests and runs the given worker +-- function on them. +withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t) +withWorkerQueue workerAction = ContT $ \mainAction -> do + q <- newTQueueIO + withAsync (writerThread q) $ \_ -> mainAction q + where + writerThread q = + forever $ do + l <- atomically $ readTQueue q + workerAction l + +-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, +-- and then blocks until the result is computed. +awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result +awaitRunInThread q act = do + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + barrier <- newBarrier + atomically $ writeTQueue q $ do + res <- act + signalBarrier barrier res + waitBarrier barrier diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 3c7984b8e8..cf7845ce08 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -1,15 +1,16 @@ - -- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NumericUnderscores #-} -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer ( runLanguageServer , setupLSP , Log(..) + , ThreadQueue + , runWithWorkerThreads ) where import Control.Concurrent.STM @@ -34,11 +35,14 @@ import UnliftIO.Exception import qualified Colog.Core as Colog import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing +import Development.IDE.Core.WorkerThread (withWorkerQueue) import qualified Development.IDE.Session as Session -import Development.IDE.Types.Shake (WithHieDb) +import Development.IDE.Types.Shake (WithHieDb, + WithHieDbShield (..)) import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, @@ -77,8 +81,6 @@ instance Pretty Log where LogLspServer msg -> pretty msg LogServerShutdownMessage -> "Received shutdown message" --- used to smuggle RankNType WithHieDb through dbMVar -newtype WithHieDbShield = WithHieDbShield WithHieDb runLanguageServer :: forall config a m. (Show config) @@ -130,7 +132,7 @@ setupLSP :: -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), @@ -189,7 +191,7 @@ handleInit :: Recorder (WithPriority Log) -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () -> IO () -> (SomeLspId -> IO ()) @@ -236,8 +238,8 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c exceptionInHandler e k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do - putMVar dbMVar (WithHieDbShield withHieDb',hieChan') + untilMVar lifetime $ runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> do + putMVar dbMVar (WithHieDbShield withHieDb',threadQueue') forever $ do msg <- readChan clientMsgChan -- We dispatch notifications synchronously and requests asynchronously @@ -247,12 +249,22 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped - (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb hieChan + (WithHieDbShield withHieDb, threadQueue) <- takeMVar dbMVar + ide <- getIdeState env root withHieDb threadQueue registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) +-- | runWithWorkerThreads +-- create several threads to run the session, db and session loader +-- see Note [Serializing runs in separate thread] +runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () +runWithWorkerThreads recorder dbLoc f = evalContT $ do + sessionRestartTQueue <- withWorkerQueue id + sessionLoaderTQueue <- withWorkerQueue id + (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc + liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) + -- | Runs the action until it ends or until the given MVar is put. -- Rethrows any exceptions. untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 0c1c740596..d4c80e23a6 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -24,7 +24,6 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as J import Data.Coerce (coerce) import Data.Default (Default (def)) -import Data.Foldable (traverse_) import Data.Hashable (hashed) import qualified Data.HashMap.Strict as HashMap import Data.List.Extra (intercalate, @@ -54,12 +53,13 @@ import Development.IDE.Core.Service (initialise, runAction) import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), - IndexQueue, + ThreadQueue (tLoaderQueue), shakeSessionInit, uses) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, + runWithWorkerThreads, setupLSP) import qualified Development.IDE.LSP.LanguageServer as LanguageServer import Development.IDE.Main.HeapStats (withHeapStats) @@ -74,7 +74,6 @@ import Development.IDE.Session (SessionLoadingOptions getHieDbLoc, loadSessionWithOptions, retryOnSqliteBusy, - runWithDb, setInitialDynFlags) import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, @@ -326,8 +325,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState - getIdeState env rootPath withHieDb hieChan = do + let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState + getIdeState env rootPath withHieDb threadQueue = do t <- ioT logWith recorder Info $ LogLspStartDuration t -- We want to set the global DynFlags right now, so that we can use @@ -337,7 +336,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re -- TODO: should probably catch/log/rethrow at top level instead `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue) config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -361,7 +360,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re debouncer ideOptions withHieDb - hieChan + threadQueue monitoring rootPath putMVar ideStateVar ide @@ -387,7 +386,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Check argFiles -> do let dir = argsProjectRoot dbLoc <- getHieDbLoc dir - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -408,14 +407,14 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir (tLoaderQueue threadQueue) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty dir + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty dir shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -445,15 +444,15 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Custom (IdeCommand c) -> do let root = argsProjectRoot dbLoc <- getHieDbLoc root - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty root + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty root shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 7b3a70d14f..2083625c43 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -12,7 +12,7 @@ module Development.IDE.Types.Shake ShakeValue(..), currentValue, isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb) + toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb,WithHieDbShield(..)) where import Control.DeepSeq @@ -42,6 +42,9 @@ import Unsafe.Coerce (unsafeCoerce) -- functionality type WithHieDb = forall a. (HieDb -> IO a) -> IO a +-- used to smuggle RankNType WithHieDb through dbMVar +newtype WithHieDbShield = WithHieDbShield WithHieDb + data Value v = Succeeded (Maybe FileVersion) v | Stale (Maybe PositionDelta) (Maybe FileVersion) v