From 15f989269b91334d15920c311961d311db4607a0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 21:33:54 +0800 Subject: [PATCH 01/30] add thread to do shake restart --- ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 75 +++++++++---------- ghcide/src/Development/IDE/Core/Service.hs | 4 +- ghcide/src/Development/IDE/Core/Shake.hs | 69 +++++++++++------ ghcide/src/Development/IDE/Core/Thread.hs | 28 +++++++ .../src/Development/IDE/LSP/LanguageServer.hs | 39 ++++++++-- ghcide/src/Development/IDE/Main.hs | 5 +- 7 files changed, 149 insertions(+), 72 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/Thread.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 2b5be914d4..2fcee1b436 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.Thread 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 71688afd1d..6fb8ae18e9 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -11,10 +11,12 @@ module Development.IDE.Session ,loadSessionWithOptions ,setInitialDynFlags ,getHieDbLoc - ,runWithDb +-- ,runWithDb ,retryOnSqliteBusy ,retryOnException ,Log(..) + ,dbThreadRun + ,WithHieDbShield(..) ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses @@ -121,6 +123,9 @@ import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat import GHC.Data.Graph.Directed +import Control.Monad.Cont (ContT (ContT), evalContT) +import Development.IDE.Core.Thread (ThreadRun (..), + runInThread) import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types @@ -370,48 +375,37 @@ makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> Hie makeWithHieDbRetryable recorder rng hieDb f = retryOnSqliteBusy recorder rng (f hieDb) --- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for --- 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 - -- use non-deterministic seed because maybe multiple HLS start at same time - -- and send bursts of requests - rng <- Random.newStdGen - -- Delete the database if it has an incompatible schema version - retryOnSqliteBusy - recorder - rng - (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) - - withHieDb fp $ \writedb -> do - -- the type signature is necessary to avoid concretizing the tyvar - -- e.g. `withWriteDbRetryable initConn` without type signature will - -- instantiate tyvar `a` to `()` - let withWriteDbRetryable :: WithHieDb - withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb - withWriteDbRetryable initConn - - chan <- newTQueueIO - - withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do - withHieDb fp (\readDb -> k (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 - -- TODO: probably should let exceptions be caught/logged/handled by top level handler - l withHieDbRetryable +dbThreadRun :: + ThreadRun + (Recorder (WithPriority Log), FilePath) + WithHieDbShield + WithHieDbShield + (((HieDb -> IO a) -> IO a) -> IO ()) +dbThreadRun = ThreadRun { + tRunner = \(recorder, _fp) (WithHieDbShield withWriter) l -> l withWriter `Safe.catch` \e@SQLError{} -> do logWith recorder Error $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \f -> do logWith recorder Error $ LogHieDbWriterThreadException f - + , + tCreateResource = \(recorder, fp) f -> do + rng <- Random.newStdGen + retryOnSqliteBusy + recorder + rng + (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) + evalContT $ do + writedb <- ContT $ withHieDb fp + readDb <- ContT $ withHieDb fp + let withWriteDbRetryable :: WithHieDb + withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb + liftIO $ withWriteDbRetryable initConn + liftIO $ f (WithHieDbShield withWriteDbRetryable) (WithHieDbShield (makeWithHieDbRetryable recorder rng readDb)) +} +-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for +-- 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 getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do @@ -437,6 +431,9 @@ getHieDbLoc dir = do loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def +-- used to smuggle RankNType WithHieDb through dbMVar +newtype WithHieDbShield = WithHieDbShield WithHieDb + loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do cradle_files <- newIORef [] diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index cdb5ba72cb..bbd07a0245 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -31,6 +31,7 @@ import Ide.Plugin.Config import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP +import Control.Concurrent.STM (TQueue) import Control.Monad import qualified Development.IDE.Core.FileExists as FileExists import qualified Development.IDE.Core.OfInterest as OfInterest @@ -53,6 +54,7 @@ instance Pretty Log where LogOfInterest msg -> pretty msg LogFileExists msg -> pretty msg + ------------------------------------------------------------ -- Exposed API @@ -65,7 +67,7 @@ initialise :: Recorder (WithPriority Log) -> Debouncer LSP.NormalizedUri -> IdeOptions -> WithHieDb - -> IndexQueue + -> ThreadQueue -> Monitoring -> IO IdeState initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 2b95df4ed0..e4f99db54a 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 @@ -182,6 +183,9 @@ import Development.IDE.GHC.Compat (NameCacheUpdater (NCU), #endif #if MIN_VERSION_ghc(9,3,0) +import Control.Concurrent.STM (atomically, + writeTQueue) +import Development.IDE.Core.Thread import Development.IDE.GHC.Compat (NameCacheUpdater) #endif @@ -262,6 +266,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 +344,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. @@ -619,7 +633,7 @@ shakeOpen :: Recorder (WithPriority Log) -> IdeReportProgress -> IdeTesting -> WithHieDb - -> IndexQueue + -> ThreadQueue -> ShakeOptions -> Monitoring -> Rules () @@ -627,7 +641,10 @@ shakeOpen :: Recorder (WithPriority Log) shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) - withHieDb indexQueue opts monitoring rules = mdo + withHieDb threadQueue opts monitoring rules = mdo + let indexQueue = tIndexQueue threadQueue + restartQueue = tRestartQueue threadQueue + loaderQueue = tLoaderQueue threadQueue #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames @@ -752,31 +769,37 @@ 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) +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = do + b <- newBarrier + atomically $ writeTQueue (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) + -- fill barrier to signal that the restart is done + signalBarrier b () + waitBarrier b where logErrorAfter :: Seconds -> IO () -> IO () logErrorAfter seconds action = flip withAsync (const action) $ do diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs new file mode 100644 index 0000000000..30ff5fe607 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/Thread.hs @@ -0,0 +1,28 @@ +module Development.IDE.Core.Thread where +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad (forever) + + +data ThreadRun input threadResource resource arg = ThreadRun { + tCreateResource :: + input -- ^ input of running + -> (threadResource -> resource -> IO ()) -- ^ the long running action + -> IO (), + tRunner -- ^ run a single action with writer resource + :: input -- ^ input of running + -> threadResource -- ^ writer resource + -> arg -- ^ argument to run + -> IO () +} + +runInThread :: ThreadRun input threadResource resource arg -> input -> ((resource, TQueue arg) -> IO ()) -> IO () +runInThread ThreadRun{..} ip f = do + tCreateResource ip $ \w r -> do + q <- newTQueueIO + withAsync (writerThread w q) $ \_ -> f (r, q) + where + writerThread r q = + forever $ do + l <- atomically $ readTQueue q + tRunner ip r l diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2a4994f5b9..5b1beda259 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -10,6 +10,10 @@ module Development.IDE.LSP.LanguageServer ( runLanguageServer , setupLSP , Log(..) + , ThreadQueue + , sessionRestartThread + , sessionLoaderThread + , runWithDb ) where import Control.Concurrent.STM @@ -21,7 +25,8 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE.LSP.Server -import Development.IDE.Session (runWithDb) +import Development.IDE.Session (WithHieDbShield (..), + dbThreadRun) import Ide.Types (traceWithSpan) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -33,9 +38,13 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog +import Control.Monad.Cont (ContT (ContT), + evalContT) import Control.Monad.IO.Unlift (MonadUnliftIO) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Thread (ThreadRun (..), + runInThread) import Development.IDE.Core.Tracing import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb) @@ -77,8 +86,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) @@ -129,7 +136,7 @@ setupLSP :: Recorder (WithPriority Log) -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), @@ -187,7 +194,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do handleInit :: Recorder (WithPriority Log) -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () -> IO () -> (SomeLspId -> IO ()) @@ -240,12 +247,32 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped - (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar + (WithHieDbShield withHieDb, hieChan) <- takeMVar dbMVar ide <- getIdeState env root withHieDb hieChan registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) +runWithDb :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () +runWithDb recorder dbLoc f = evalContT $ do + (_, sessionRestartTQueue) <- ContT $ runInThread sessionRestartThread () + (_, sessionLoaderTQueue) <- ContT $ runInThread sessionLoaderThread () + (WithHieDbShield hiedb, hieChan) <- ContT $ runInThread dbThreadRun (recorder, dbLoc) + liftIO $ f hiedb (ThreadQueue hieChan sessionRestartTQueue sessionLoaderTQueue) + + +sessionRestartThread :: ThreadRun () () () (IO ()) +sessionRestartThread = ThreadRun { + tRunner = \_ _ run -> run, + tCreateResource = \_ f -> do f () () +} + +sessionLoaderThread :: ThreadRun () () () (IO ()) +sessionLoaderThread = ThreadRun { + tRunner = \_ _ run -> run, + tCreateResource = \_ f -> do f () () +} + -- | 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 2c365475d0..0ae7e1d6d7 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -60,7 +60,7 @@ import Development.IDE.Core.Shake (IdeState (shakeExtras import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, - setupLSP) + runWithDb, setupLSP) import qualified Development.IDE.LSP.LanguageServer as LanguageServer import Development.IDE.Main.HeapStats (withHeapStats) import qualified Development.IDE.Main.HeapStats as HeapStats @@ -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,7 +325,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState + let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState getIdeState env rootPath withHieDb hieChan = do traverse_ IO.setCurrentDirectory rootPath t <- ioT From 3ba47f6007f040daf638643bfbed2eb0528c7bb7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 22:46:34 +0800 Subject: [PATCH 02/30] fix --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 5 ++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6fb8ae18e9..98e8a9d694 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -101,6 +101,7 @@ import Control.Concurrent.STM.Stats (atomically, modifyTVar', import Control.Concurrent.STM.TQueue import Control.DeepSeq import Control.Exception (evaluate) +import Control.Monad.Cont (ContT (ContT), runContT) import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) @@ -123,7 +124,6 @@ import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat import GHC.Data.Graph.Directed -import Control.Monad.Cont (ContT (ContT), evalContT) import Development.IDE.Core.Thread (ThreadRun (..), runInThread) import GHC.Data.Bag @@ -394,7 +394,7 @@ dbThreadRun = ThreadRun { recorder rng (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) - evalContT $ do + flip runContT return $ do writedb <- ContT $ withHieDb fp readDb <- ContT $ withHieDb fp let withWriteDbRetryable :: WithHieDb diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 5b1beda259..60521883df 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -38,8 +38,7 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog -import Control.Monad.Cont (ContT (ContT), - evalContT) +import Control.Monad.Cont (ContT (ContT, runContT)) import Control.Monad.IO.Unlift (MonadUnliftIO) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log) @@ -254,7 +253,7 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa runWithDb :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () -runWithDb recorder dbLoc f = evalContT $ do +runWithDb recorder dbLoc f = flip runContT return $ do (_, sessionRestartTQueue) <- ContT $ runInThread sessionRestartThread () (_, sessionLoaderTQueue) <- ContT $ runInThread sessionLoaderThread () (WithHieDbShield hiedb, hieChan) <- ContT $ runInThread dbThreadRun (recorder, dbLoc) From 5d6604146e9bdd8df2c6c323a86c93e6a356414b Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 22:55:37 +0800 Subject: [PATCH 03/30] run session loader in thread --- .../session-loader/Development/IDE/Session.hs | 24 ++++++++----------- ghcide/src/Development/IDE/Main.hs | 8 +++---- 2 files changed, 14 insertions(+), 18 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 98e8a9d694..8a729714c2 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -7,7 +7,7 @@ The logic for setting up a ghcide session by tapping into hie-bios. module Development.IDE.Session (SessionLoadingOptions(..) ,CacheDirs(..) - ,loadSession +-- ,loadSession ,loadSessionWithOptions ,setInitialDynFlags ,getHieDbLoc @@ -428,14 +428,14 @@ 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 +-- loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) +-- loadSession recorder = loadSessionWithOptions recorder def -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) +loadSessionWithOptions recorder SessionLoadingOptions{..} dir que = do cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) @@ -459,9 +459,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do res' <- traverse makeAbsolute 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,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = 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 + resultBarrier <- liftIO newBarrier + atomically $ writeTQueue que $ do + res <- getOptions file + liftIO $ signalBarrier resultBarrier res + waitBarrier resultBarrier -- | 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/Main.hs b/ghcide/src/Development/IDE/Main.hs index 0ae7e1d6d7..ffac41d7db 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -54,7 +54,7 @@ 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 @@ -340,7 +340,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 dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir (tLoaderQueue hieChan) config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -410,7 +410,7 @@ 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 hieChan) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options { optCheckParents = pure NeverCheck @@ -448,7 +448,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue hieChan) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options { optCheckParents = pure NeverCheck From d7946a07333de8be21cb8ff57e40a87e338dde87 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 23:59:44 +0800 Subject: [PATCH 04/30] fix 9.2 --- ghcide/session-loader/Development/IDE/Session.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8a729714c2..15b240fd5a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -108,6 +108,7 @@ import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Database.SQLite.Simple +import Development.IDE.Core.Thread (ThreadRun (..)) import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, toNoFileKey) @@ -124,8 +125,6 @@ import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat import GHC.Data.Graph.Directed -import Development.IDE.Core.Thread (ThreadRun (..), - runInThread) import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types From da56bfbf34c79b2aa19801b26c10f43134758440 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 14:21:04 +0800 Subject: [PATCH 05/30] rename --- .../session-loader/Development/IDE/Session.hs | 22 +++++++++---------- ghcide/src/Development/IDE/Core/Thread.hs | 17 +++++++++----- .../src/Development/IDE/LSP/LanguageServer.hs | 18 +++++---------- 3 files changed, 28 insertions(+), 29 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 15b240fd5a..5238ae401e 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -15,7 +15,7 @@ module Development.IDE.Session ,retryOnSqliteBusy ,retryOnException ,Log(..) - ,dbThreadRun + ,dbThread ,WithHieDbShield(..) ) where @@ -374,37 +374,37 @@ makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> Hie makeWithHieDbRetryable recorder rng hieDb f = retryOnSqliteBusy recorder rng (f hieDb) -dbThreadRun :: +-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for +-- 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 +dbThread :: ThreadRun (Recorder (WithPriority Log), FilePath) WithHieDbShield WithHieDbShield (((HieDb -> IO a) -> IO a) -> IO ()) -dbThreadRun = ThreadRun { - tRunner = \(recorder, _fp) (WithHieDbShield withWriter) l -> l withWriter +dbThread = ThreadRun { + tWorker = \(recorder, _fp) (WithHieDbShield withWriter) l -> l withWriter `Safe.catch` \e@SQLError{} -> do logWith recorder Error $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \f -> do logWith recorder Error $ LogHieDbWriterThreadException f , - tCreateResource = \(recorder, fp) f -> do + tRunWithResource = \(recorder, fp) f -> do rng <- Random.newStdGen retryOnSqliteBusy recorder rng (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) flip runContT return $ do - writedb <- ContT $ withHieDb fp + writeDb <- ContT $ withHieDb fp readDb <- ContT $ withHieDb fp let withWriteDbRetryable :: WithHieDb - withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb + withWriteDbRetryable = makeWithHieDbRetryable recorder rng writeDb liftIO $ withWriteDbRetryable initConn liftIO $ f (WithHieDbShield withWriteDbRetryable) (WithHieDbShield (makeWithHieDbRetryable recorder rng readDb)) } --- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for --- 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 getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs index 30ff5fe607..4e6ce17bee 100644 --- a/ghcide/src/Development/IDE/Core/Thread.hs +++ b/ghcide/src/Development/IDE/Core/Thread.hs @@ -2,27 +2,32 @@ module Development.IDE.Core.Thread where import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad (forever) +import Control.Monad.Cont (ContT (ContT)) data ThreadRun input threadResource resource arg = ThreadRun { - tCreateResource :: + tRunWithResource :: input -- ^ input of running -> (threadResource -> resource -> IO ()) -- ^ the long running action -> IO (), - tRunner -- ^ run a single action with writer resource + tWorker -- ^ A single action we want to run in separate thread serially :: input -- ^ input of running -> threadResource -- ^ writer resource -> arg -- ^ argument to run -> IO () } -runInThread :: ThreadRun input threadResource resource arg -> input -> ((resource, TQueue arg) -> IO ()) -> IO () -runInThread ThreadRun{..} ip f = do - tCreateResource ip $ \w r -> do +-- | runInThread +-- Run a long running action with a additional running thread +-- The additional thread will serialize runs of the actions from the TQueue. +-- Return ContT to run the action +runInThread :: ThreadRun input threadResource resource arg -> input -> ContT () IO (resource, TQueue arg) +runInThread ThreadRun{..} ip = ContT $ \f -> do + tRunWithResource ip $ \w r -> do q <- newTQueueIO withAsync (writerThread w q) $ \_ -> f (r, q) where writerThread r q = forever $ do l <- atomically $ readTQueue q - tRunner ip r l + tWorker ip r l diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 60521883df..ddb2e6db84 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -26,7 +26,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE.LSP.Server import Development.IDE.Session (WithHieDbShield (..), - dbThreadRun) + dbThread) import Ide.Types (traceWithSpan) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -254,23 +254,17 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa runWithDb :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () runWithDb recorder dbLoc f = flip runContT return $ do - (_, sessionRestartTQueue) <- ContT $ runInThread sessionRestartThread () - (_, sessionLoaderTQueue) <- ContT $ runInThread sessionLoaderThread () - (WithHieDbShield hiedb, hieChan) <- ContT $ runInThread dbThreadRun (recorder, dbLoc) + (_, sessionRestartTQueue) <- runInThread sessionRestartThread () + (_, sessionLoaderTQueue) <- runInThread sessionLoaderThread () + (WithHieDbShield hiedb, hieChan) <- runInThread dbThread (recorder, dbLoc) liftIO $ f hiedb (ThreadQueue hieChan sessionRestartTQueue sessionLoaderTQueue) sessionRestartThread :: ThreadRun () () () (IO ()) -sessionRestartThread = ThreadRun { - tRunner = \_ _ run -> run, - tCreateResource = \_ f -> do f () () -} +sessionRestartThread = ThreadRun { tWorker = \_ _ run -> run, tRunWithResource = \_ f -> do f () () } sessionLoaderThread :: ThreadRun () () () (IO ()) -sessionLoaderThread = ThreadRun { - tRunner = \_ _ run -> run, - tCreateResource = \_ f -> do f () () -} +sessionLoaderThread = ThreadRun { tWorker = \_ _ run -> run, tRunWithResource = \_ f -> do f () () } -- | Runs the action until it ends or until the given MVar is put. -- Rethrows any exceptions. From fb0a3702cee0aabcc4949b102f407887f6f22ea1 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 14:23:33 +0800 Subject: [PATCH 06/30] use evalContT --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 5238ae401e..de25ff5e9e 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -101,8 +101,8 @@ import Control.Concurrent.STM.Stats (atomically, modifyTVar', import Control.Concurrent.STM.TQueue import Control.DeepSeq import Control.Exception (evaluate) -import Control.Monad.Cont (ContT (ContT), runContT) import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Cont (ContT (ContT), evalContT) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) @@ -397,7 +397,7 @@ dbThread = ThreadRun { recorder rng (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) - flip runContT return $ do + evalContT $ do writeDb <- ContT $ withHieDb fp readDb <- ContT $ withHieDb fp let withWriteDbRetryable :: WithHieDb diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index ddb2e6db84..1a671144a0 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -38,8 +38,8 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog -import Control.Monad.Cont (ContT (ContT, runContT)) import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Cont (ContT (evalContT)) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Thread (ThreadRun (..), @@ -253,7 +253,7 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa runWithDb :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () -runWithDb recorder dbLoc f = flip runContT return $ do +runWithDb recorder dbLoc f = evalContT $ do (_, sessionRestartTQueue) <- runInThread sessionRestartThread () (_, sessionLoaderTQueue) <- runInThread sessionLoaderThread () (WithHieDbShield hiedb, hieChan) <- runInThread dbThread (recorder, dbLoc) From d1775e636989a09025f2aee2b4a60b0711af3376 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 14:44:38 +0800 Subject: [PATCH 07/30] add doc --- ghcide/src/Development/IDE/Core/Thread.hs | 25 +++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs index 4e6ce17bee..64792c908f 100644 --- a/ghcide/src/Development/IDE/Core/Thread.hs +++ b/ghcide/src/Development/IDE/Core/Thread.hs @@ -4,15 +4,32 @@ import Control.Concurrent.STM import Control.Monad (forever) import Control.Monad.Cont (ContT (ContT)) +-- Note [Serializing runs] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- In a lof cases we want to have a separate thread that will serialize the runs of the actions. +-- 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. +-- +-- `Development.IDE.Core.Thread` module provides a declarative api to implement this easily. +-- In `ThreadRun` data type: +-- * `tRunWithResource`: is used to create the resources needed to perform the long running action. +-- * `tWorker`: is the action we want to run in separate thread serially. +-- +-- runInThread will create a worker thread to run along with the main thread. +-- runInThread provides `resource` created by `tRunWithResource` and a `TQueue` to send the actions to run. +-- The worker thread will serialize the runs of the actions from the TQueue. -data ThreadRun input threadResource resource arg = ThreadRun { + +data ThreadRun input workerResource resource arg = ThreadRun { tRunWithResource :: input -- ^ input of running - -> (threadResource -> resource -> IO ()) -- ^ the long running action + -> (workerResource -> resource -> IO ()) -- ^ the long running action need to run with resource -> IO (), tWorker -- ^ A single action we want to run in separate thread serially :: input -- ^ input of running - -> threadResource -- ^ writer resource + -> workerResource -- ^ writer resource -> arg -- ^ argument to run -> IO () } @@ -21,7 +38,7 @@ data ThreadRun input threadResource resource arg = ThreadRun { -- Run a long running action with a additional running thread -- The additional thread will serialize runs of the actions from the TQueue. -- Return ContT to run the action -runInThread :: ThreadRun input threadResource resource arg -> input -> ContT () IO (resource, TQueue arg) +runInThread :: ThreadRun input workerResource resource arg -> input -> ContT () IO (resource, TQueue arg) runInThread ThreadRun{..} ip = ContT $ \f -> do tRunWithResource ip $ \w r -> do q <- newTQueueIO From 39bdf6a70b60a02167aa3faba0384136dbf4972c Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 14:44:57 +0800 Subject: [PATCH 08/30] fix doc --- ghcide/src/Development/IDE/Core/Thread.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs index 64792c908f..a59895bdc2 100644 --- a/ghcide/src/Development/IDE/Core/Thread.hs +++ b/ghcide/src/Development/IDE/Core/Thread.hs @@ -4,7 +4,7 @@ import Control.Concurrent.STM import Control.Monad (forever) import Control.Monad.Cont (ContT (ContT)) --- Note [Serializing runs] +-- Note [Serializing runs in separate thread] -- ~~~~~~~~~~~~~~~~~~~~~~ -- In a lof cases we want to have a separate thread that will serialize the runs of the actions. -- Like the db writes, session loading in session loader, shake session restarts. From b06186b5568b284afe0cdc3e57d04536e387f3a7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 15:02:00 +0800 Subject: [PATCH 09/30] fix import --- ghcide/session-loader/Development/IDE/Session.hs | 5 ++--- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index de25ff5e9e..848545a991 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -23,7 +23,6 @@ module Development.IDE.Session -- 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 @@ -381,8 +380,8 @@ makeWithHieDbRetryable recorder rng hieDb f = dbThread :: ThreadRun (Recorder (WithPriority Log), FilePath) - WithHieDbShield - WithHieDbShield + WithHieDbShield -- ^ writer resource + WithHieDbShield -- ^ reader resource (((HieDb -> IO a) -> IO a) -> IO ()) dbThread = ThreadRun { tWorker = \(recorder, _fp) (WithHieDbShield withWriter) l -> l withWriter diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 1a671144a0..254032db36 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -39,7 +39,7 @@ import UnliftIO.Exception import qualified Colog.Core as Colog import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Trans.Cont (ContT (evalContT)) +import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Thread (ThreadRun (..), From 1a9374b8d5160f2722d6fb3be208e09cc6bbc594 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 15:02:53 +0800 Subject: [PATCH 10/30] export explicit --- ghcide/src/Development/IDE/Core/Thread.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs index a59895bdc2..2adac7275c 100644 --- a/ghcide/src/Development/IDE/Core/Thread.hs +++ b/ghcide/src/Development/IDE/Core/Thread.hs @@ -1,4 +1,7 @@ -module Development.IDE.Core.Thread where +module Development.IDE.Core.Thread + ( ThreadRun(..), runInThread) + where + import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad (forever) From c9bdc87c1750a7bcd1e9a0722adabca95efdd322 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 16:41:38 +0800 Subject: [PATCH 11/30] add comment --- .../session-loader/Development/IDE/Session.hs | 5 ++++- ghcide/src/Development/IDE/Core/Shake.hs | 1 + .../src/Development/IDE/LSP/LanguageServer.hs | 21 +++++++++++-------- ghcide/src/Development/IDE/Main.hs | 21 ++++++++++--------- 4 files changed, 28 insertions(+), 20 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 848545a991..fb7742acf3 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -11,7 +11,7 @@ module Development.IDE.Session ,loadSessionWithOptions ,setInitialDynFlags ,getHieDbLoc --- ,runWithDb +-- ,runWithWorkerThreads ,retryOnSqliteBusy ,retryOnException ,Log(..) @@ -377,6 +377,8 @@ 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 +-- +-- see Note [Serializing runs in separate thread] dbThread :: ThreadRun (Recorder (WithPriority Log), FilePath) @@ -734,6 +736,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir que = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do + -- see Note [Serializing runs in separate thread] resultBarrier <- liftIO newBarrier atomically $ writeTQueue que $ do res <- getOptions file diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index e4f99db54a..82e3e0f51b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -642,6 +642,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb threadQueue opts monitoring rules = mdo + -- see Note [Serializing runs in separate thread] let indexQueue = tIndexQueue threadQueue restartQueue = tRestartQueue threadQueue loaderQueue = tLoaderQueue threadQueue diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 254032db36..f0b0f7a37f 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -13,7 +13,7 @@ module Development.IDE.LSP.LanguageServer , ThreadQueue , sessionRestartThread , sessionLoaderThread - , runWithDb + , runWithWorkerThreads ) where import Control.Concurrent.STM @@ -235,8 +235,8 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa exceptionInHandler e k $ ResponseError (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 @@ -246,18 +246,21 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa 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) -runWithDb :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () -runWithDb recorder dbLoc f = evalContT $ do +-- | 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) <- runInThread sessionRestartThread () (_, sessionLoaderTQueue) <- runInThread sessionLoaderThread () - (WithHieDbShield hiedb, hieChan) <- runInThread dbThread (recorder, dbLoc) - liftIO $ f hiedb (ThreadQueue hieChan sessionRestartTQueue sessionLoaderTQueue) + (WithHieDbShield hiedb, threadQueue) <- runInThread dbThread (recorder, dbLoc) + liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) sessionRestartThread :: ThreadRun () () () (IO ()) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index ffac41d7db..c46f294b43 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -60,7 +60,8 @@ import Development.IDE.Core.Shake (IdeState (shakeExtras import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, - runWithDb, setupLSP) + runWithWorkerThreads, + setupLSP) import qualified Development.IDE.LSP.LanguageServer as LanguageServer import Development.IDE.Main.HeapStats (withHeapStats) import qualified Development.IDE.Main.HeapStats as HeapStats @@ -326,7 +327,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re ideStateVar <- newEmptyMVar let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState - getIdeState env rootPath withHieDb hieChan = do + getIdeState env rootPath withHieDb threadQueue = do traverse_ IO.setCurrentDirectory rootPath t <- ioT logWith recorder Info $ LogLspStartDuration t @@ -340,7 +341,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 dir (tLoaderQueue hieChan) + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir (tLoaderQueue threadQueue) config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -364,7 +365,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re debouncer ideOptions withHieDb - hieChan + threadQueue monitoring putMVar ideStateVar ide pure ide @@ -389,7 +390,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Check argFiles -> do dir <- maybe IO.getCurrentDirectory return 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 @@ -410,14 +411,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 (tLoaderQueue hieChan) + 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 + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -447,15 +448,15 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Custom (IdeCommand c) -> do root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue hieChan) + 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 + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide From cb131e366998949fc7076b93c6e4fa45cc1ca49d Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 16:46:36 +0800 Subject: [PATCH 12/30] cleanup --- ghcide/session-loader/Development/IDE/Session.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index fb7742acf3..1291c7f2ee 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -7,11 +7,9 @@ The logic for setting up a ghcide session by tapping into hie-bios. module Development.IDE.Session (SessionLoadingOptions(..) ,CacheDirs(..) --- ,loadSession ,loadSessionWithOptions ,setInitialDynFlags ,getHieDbLoc --- ,runWithWorkerThreads ,retryOnSqliteBusy ,retryOnException ,Log(..) From 96d6d07b3040d72ec01a4c7c47e481b7f2771072 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 16:53:34 +0800 Subject: [PATCH 13/30] cleanup --- ghcide/session-loader/Development/IDE/Session.hs | 10 +++------- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 6 +++--- ghcide/src/Development/IDE/Types/Shake.hs | 5 ++++- 3 files changed, 10 insertions(+), 11 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1291c7f2ee..75cae48af1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -14,7 +14,6 @@ module Development.IDE.Session ,retryOnException ,Log(..) ,dbThread - ,WithHieDbShield(..) ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses @@ -108,7 +107,9 @@ import Database.SQLite.Simple import Development.IDE.Core.Thread (ThreadRun (..)) import Development.IDE.Core.Tracing (withTrace) 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 @@ -426,11 +427,6 @@ 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 - --- used to smuggle RankNType WithHieDb through dbMVar -newtype WithHieDbShield = WithHieDbShield WithHieDb loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} dir que = do diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index f0b0f7a37f..4cbf5dae2e 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -25,8 +25,7 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE.LSP.Server -import Development.IDE.Session (WithHieDbShield (..), - dbThread) +import Development.IDE.Session (dbThread) import Ide.Types (traceWithSpan) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -46,7 +45,8 @@ import Development.IDE.Core.Thread (ThreadRun (..), runInThread) import Development.IDE.Core.Tracing 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, 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 From b552c804063c59efc4fbf24cd78f77280be6cdf6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 17:09:10 +0800 Subject: [PATCH 14/30] fix note --- ghcide/src/Development/IDE/Core/Thread.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs index 2adac7275c..3588ee1380 100644 --- a/ghcide/src/Development/IDE/Core/Thread.hs +++ b/ghcide/src/Development/IDE/Core/Thread.hs @@ -8,7 +8,7 @@ import Control.Monad (forever) import Control.Monad.Cont (ContT (ContT)) -- Note [Serializing runs in separate thread] --- ~~~~~~~~~~~~~~~~~~~~~~ +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In a lof cases we want to have a separate thread that will serialize the runs of the actions. -- Like the db writes, session loading in session loader, shake session restarts. -- From aef173a2d525e8b35964aac42c6ae71b4c603cda Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 21:48:54 +0800 Subject: [PATCH 15/30] add `blockRunInThread` --- .../session-loader/Development/IDE/Session.hs | 9 ++---- ghcide/src/Development/IDE/Core/Shake.hs | 8 ++--- ghcide/src/Development/IDE/Core/Thread.hs | 30 ++++++++++++++----- .../src/Development/IDE/LSP/LanguageServer.hs | 8 ++--- 4 files changed, 31 insertions(+), 24 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 75cae48af1..b4e5ea00a1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -104,7 +104,8 @@ import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Database.SQLite.Simple -import Development.IDE.Core.Thread (ThreadRun (..)) +import Development.IDE.Core.Thread (ThreadRun (..), + blockRunInThread) import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, @@ -731,11 +732,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir que = do returnWithVersion $ \file -> do -- see Note [Serializing runs in separate thread] - resultBarrier <- liftIO newBarrier - atomically $ writeTQueue que $ do - res <- getOptions file - liftIO $ signalBarrier resultBarrier res - waitBarrier resultBarrier + blockRunInThread 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/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 82e3e0f51b..c446090128 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -775,9 +775,8 @@ delayedAction a = do -- 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 = do - b <- newBarrier - atomically $ writeTQueue (restartQueue shakeExtras) $ do +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = + void $ blockRunInThread (restartQueue shakeExtras) $ do withMVar' shakeSession (\runner -> do @@ -798,9 +797,6 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = -- See https://github.com/haskell/ghcide/issues/79 (\() -> do (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) - -- fill barrier to signal that the restart is done - signalBarrier b () - waitBarrier b where logErrorAfter :: Seconds -> IO () -> IO () logErrorAfter seconds action = flip withAsync (const action) $ do diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs index 3588ee1380..8efd799204 100644 --- a/ghcide/src/Development/IDE/Core/Thread.hs +++ b/ghcide/src/Development/IDE/Core/Thread.hs @@ -1,11 +1,13 @@ module Development.IDE.Core.Thread - ( ThreadRun(..), runInThread) + ( ThreadRun(..), runWithThread, blockRunInThread) where import Control.Concurrent.Async import Control.Concurrent.STM -import Control.Monad (forever) -import Control.Monad.Cont (ContT (ContT)) +import Control.Concurrent.Strict (newBarrier, signalBarrier, + waitBarrier) +import Control.Monad (forever) +import Control.Monad.Cont (ContT (ContT)) -- Note [Serializing runs in separate thread] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -20,8 +22,8 @@ import Control.Monad.Cont (ContT (ContT)) -- * `tRunWithResource`: is used to create the resources needed to perform the long running action. -- * `tWorker`: is the action we want to run in separate thread serially. -- --- runInThread will create a worker thread to run along with the main thread. --- runInThread provides `resource` created by `tRunWithResource` and a `TQueue` to send the actions to run. +-- runWithThread will create a worker thread to run along with the main thread. +-- runWithThread provides `resource` created by `tRunWithResource` and a `TQueue` to send the actions to run. -- The worker thread will serialize the runs of the actions from the TQueue. @@ -37,12 +39,12 @@ data ThreadRun input workerResource resource arg = ThreadRun { -> IO () } --- | runInThread +-- | runWithThread -- Run a long running action with a additional running thread -- The additional thread will serialize runs of the actions from the TQueue. -- Return ContT to run the action -runInThread :: ThreadRun input workerResource resource arg -> input -> ContT () IO (resource, TQueue arg) -runInThread ThreadRun{..} ip = ContT $ \f -> do +runWithThread :: ThreadRun input workerResource resource arg -> input -> ContT () IO (resource, TQueue arg) +runWithThread ThreadRun{..} ip = ContT $ \f -> do tRunWithResource ip $ \w r -> do q <- newTQueueIO withAsync (writerThread w q) $ \_ -> f (r, q) @@ -51,3 +53,15 @@ runInThread ThreadRun{..} ip = ContT $ \f -> do forever $ do l <- atomically $ readTQueue q tWorker ip r l + + +-- | blockRunInThread run and wait for the result +-- Take an action from TQueue, run it and +-- use barrier to wait for the result +blockRunInThread :: TQueue (IO ()) -> IO result -> IO result +blockRunInThread q act = do + 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 4cbf5dae2e..1ea893c511 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -42,7 +42,7 @@ import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Thread (ThreadRun (..), - runInThread) + runWithThread) import Development.IDE.Core.Tracing import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb, @@ -257,9 +257,9 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa -- see Note [Serializing runs in separate thread] runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () runWithWorkerThreads recorder dbLoc f = evalContT $ do - (_, sessionRestartTQueue) <- runInThread sessionRestartThread () - (_, sessionLoaderTQueue) <- runInThread sessionLoaderThread () - (WithHieDbShield hiedb, threadQueue) <- runInThread dbThread (recorder, dbLoc) + (_, sessionRestartTQueue) <- runWithThread sessionRestartThread () + (_, sessionLoaderTQueue) <- runWithThread sessionLoaderThread () + (WithHieDbShield hiedb, threadQueue) <- runWithThread dbThread (recorder, dbLoc) liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) From d08f175eb6aff383a4df5637baaa1e59010830c0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 22:40:56 +0800 Subject: [PATCH 16/30] fix --- ghcide/src/Development/IDE/Core/Shake.hs | 2 -- ghcide/src/Development/IDE/Main.hs | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 022b96397c..b4390d1958 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -183,8 +183,6 @@ import Development.IDE.GHC.Compat (NameCacheUpdater (NCU), #endif #if MIN_VERSION_ghc(9,3,0) -import Control.Concurrent.STM (atomically, - writeTQueue) import Development.IDE.Core.Thread import Development.IDE.GHC.Compat (NameCacheUpdater) #endif diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 15cb4dc7d7..11056a25d1 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -327,7 +327,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re ideStateVar <- newEmptyMVar let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState - getIdeState env rootPath withHieDb hieChan = do + 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 From 60839b023b7eea705a8827c0887c87114b12b940 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 28 May 2024 00:04:52 +0800 Subject: [PATCH 17/30] fix 9.2 import --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b4390d1958..c4846b058d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -123,6 +123,7 @@ import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Thread import Development.IDE.Core.Tracing import Development.IDE.GHC.Compat (NameCache, initNameCache, @@ -183,7 +184,6 @@ import Development.IDE.GHC.Compat (NameCacheUpdater (NCU), #endif #if MIN_VERSION_ghc(9,3,0) -import Development.IDE.Core.Thread import Development.IDE.GHC.Compat (NameCacheUpdater) #endif From b2be89f196765c51ba1756662693002a3d1ff4aa Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 8 Jun 2024 20:06:07 +0800 Subject: [PATCH 18/30] Update ghcide/src/Development/IDE/Core/Thread.hs Co-authored-by: Michael Peyton Jones --- ghcide/src/Development/IDE/Core/Thread.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs index 8efd799204..6be25ce405 100644 --- a/ghcide/src/Development/IDE/Core/Thread.hs +++ b/ghcide/src/Development/IDE/Core/Thread.hs @@ -11,7 +11,7 @@ import Control.Monad.Cont (ContT (ContT)) -- Note [Serializing runs in separate thread] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In a lof cases we want to have a separate thread that will serialize the runs of the actions. +-- In a lot of cases we want to have a separate thread that will serialize the runs of the actions. -- 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. From 8aea82ef8bcfe05eb7fb1b6a8a864164a1630c12 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 8 Jun 2024 20:24:48 +0800 Subject: [PATCH 19/30] refactor to withWorkerQueue --- ghcide/ghcide.cabal | 2 +- .../session-loader/Development/IDE/Session.hs | 64 ++++++++++-------- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- ghcide/src/Development/IDE/Core/Thread.hs | 67 ------------------- .../src/Development/IDE/Core/WorkerThread.hs | 44 ++++++++++++ .../src/Development/IDE/LSP/LanguageServer.hs | 21 ++---- 6 files changed, 88 insertions(+), 112 deletions(-) delete mode 100644 ghcide/src/Development/IDE/Core/Thread.hs create mode 100644 ghcide/src/Development/IDE/Core/WorkerThread.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 628121380a..7c319fb8f3 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -148,7 +148,7 @@ library Development.IDE.Core.Shake Development.IDE.Core.Tracing Development.IDE.Core.UseStale - Development.IDE.Core.Thread + 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 ac4b5164f1..2d13b87809 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -13,7 +13,7 @@ module Development.IDE.Session ,retryOnSqliteBusy ,retryOnException ,Log(..) - ,dbThread + ,runWithDb ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses @@ -98,15 +98,15 @@ 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), evalContT) +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.Thread (ThreadRun (..), - blockRunInThread) import Development.IDE.Core.Tracing (withTrace) +import Development.IDE.Core.WorkerThread (blockRunInThread, + withWorkerQueue) import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..), @@ -379,34 +379,42 @@ makeWithHieDbRetryable recorder rng hieDb f = -- 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 -- --- see Note [Serializing runs in separate thread] -dbThread :: - ThreadRun - (Recorder (WithPriority Log), FilePath) - WithHieDbShield -- ^ writer resource - WithHieDbShield -- ^ reader resource - (((HieDb -> IO a) -> IO a) -> IO ()) -dbThread = ThreadRun { - tWorker = \(recorder, _fp) (WithHieDbShield withWriter) l -> l withWriter +-- 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 + -- Delete the database if it has an incompatible schema version + retryOnSqliteBusy + recorder + rng + (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) + + withHieDb fp $ \writedb -> do + -- the type signature is necessary to avoid concretizing the tyvar + -- e.g. `withWriteDbRetryable initConn` without type signature will + -- instantiate tyvar `a` to `()` + let withWriteDbRetryable :: WithHieDb + withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb + withWriteDbRetryable initConn + + + -- 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 + writer withHieDbRetryable l = do + -- TODO: probably should let exceptions be caught/logged/handled by top level handler + l withHieDbRetryable `Safe.catch` \e@SQLError{} -> do logWith recorder Error $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \f -> do logWith recorder Error $ LogHieDbWriterThreadException f - , - tRunWithResource = \(recorder, fp) f -> do - rng <- Random.newStdGen - retryOnSqliteBusy - recorder - rng - (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) - evalContT $ do - writeDb <- ContT $ withHieDb fp - readDb <- ContT $ withHieDb fp - let withWriteDbRetryable :: WithHieDb - withWriteDbRetryable = makeWithHieDbRetryable recorder rng writeDb - liftIO $ withWriteDbRetryable initConn - liftIO $ f (WithHieDbShield withWriteDbRetryable) (WithHieDbShield (makeWithHieDbRetryable recorder rng readDb)) -} + getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c4846b058d..d734454787 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -123,8 +123,8 @@ import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Thread import Development.IDE.Core.Tracing +import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, initNameCache, knownKeyNames) diff --git a/ghcide/src/Development/IDE/Core/Thread.hs b/ghcide/src/Development/IDE/Core/Thread.hs deleted file mode 100644 index 6be25ce405..0000000000 --- a/ghcide/src/Development/IDE/Core/Thread.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Development.IDE.Core.Thread - ( ThreadRun(..), runWithThread, blockRunInThread) - where - -import Control.Concurrent.Async -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] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In a lot of cases we want to have a separate thread that will serialize the runs of the actions. --- 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. --- --- `Development.IDE.Core.Thread` module provides a declarative api to implement this easily. --- In `ThreadRun` data type: --- * `tRunWithResource`: is used to create the resources needed to perform the long running action. --- * `tWorker`: is the action we want to run in separate thread serially. --- --- runWithThread will create a worker thread to run along with the main thread. --- runWithThread provides `resource` created by `tRunWithResource` and a `TQueue` to send the actions to run. --- The worker thread will serialize the runs of the actions from the TQueue. - - -data ThreadRun input workerResource resource arg = ThreadRun { - tRunWithResource :: - input -- ^ input of running - -> (workerResource -> resource -> IO ()) -- ^ the long running action need to run with resource - -> IO (), - tWorker -- ^ A single action we want to run in separate thread serially - :: input -- ^ input of running - -> workerResource -- ^ writer resource - -> arg -- ^ argument to run - -> IO () -} - --- | runWithThread --- Run a long running action with a additional running thread --- The additional thread will serialize runs of the actions from the TQueue. --- Return ContT to run the action -runWithThread :: ThreadRun input workerResource resource arg -> input -> ContT () IO (resource, TQueue arg) -runWithThread ThreadRun{..} ip = ContT $ \f -> do - tRunWithResource ip $ \w r -> do - q <- newTQueueIO - withAsync (writerThread w q) $ \_ -> f (r, q) - where - writerThread r q = - forever $ do - l <- atomically $ readTQueue q - tWorker ip r l - - --- | blockRunInThread run and wait for the result --- Take an action from TQueue, run it and --- use barrier to wait for the result -blockRunInThread :: TQueue (IO ()) -> IO result -> IO result -blockRunInThread q act = do - barrier <- newBarrier - atomically $ writeTQueue q $ do - res <- act - signalBarrier barrier res - waitBarrier barrier diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs new file mode 100644 index 0000000000..fb0266dc0b --- /dev/null +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -0,0 +1,44 @@ +module Development.IDE.Core.WorkerThread + (withWorkerQueue, blockRunInThread) + where + +import Control.Concurrent.Async +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] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In a lof cases we want to have a separate thread that will serialize the runs of the actions. +-- 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. +-- +-- `Development.IDE.Core.WorkerThread` module provides a simple api to implement this easily. +-- * `withWorkerQueue`: accepts an action to run in separate thread and returns a `TQueue` to send the actions to run. +-- * `blockRunInThread` : accepts a `TQueue` and an action to run in separate thread and waits for the result. + + +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 + +-- | blockRunInThread run and wait for the result +blockRunInThread :: TQueue (IO ()) -> IO result -> IO result +blockRunInThread 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 8203a44596..265d48ae32 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -11,8 +11,6 @@ module Development.IDE.LSP.LanguageServer , setupLSP , Log(..) , ThreadQueue - , sessionRestartThread - , sessionLoaderThread , runWithWorkerThreads ) where @@ -25,7 +23,7 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE.LSP.Server -import Development.IDE.Session (dbThread) +import Development.IDE.Session (runWithDb) import Ide.Types (traceWithSpan) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -41,9 +39,8 @@ 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.Thread (ThreadRun (..), - runWithThread) import Development.IDE.Core.Tracing +import Development.IDE.Core.WorkerThread (withWorkerQueue) import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..)) @@ -259,23 +256,17 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c 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) <- runWithThread sessionRestartThread () - (_, sessionLoaderTQueue) <- runWithThread sessionLoaderThread () - (WithHieDbShield hiedb, threadQueue) <- runWithThread dbThread (recorder, dbLoc) + sessionRestartTQueue <- withWorkerQueue id + sessionLoaderTQueue <- withWorkerQueue id + (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) - -sessionRestartThread :: ThreadRun () () () (IO ()) -sessionRestartThread = ThreadRun { tWorker = \_ _ run -> run, tRunWithResource = \_ f -> do f () () } - -sessionLoaderThread :: ThreadRun () () () (IO ()) -sessionLoaderThread = ThreadRun { tWorker = \_ _ run -> run, tRunWithResource = \_ f -> do f () () } - -- | Runs the action until it ends or until the given MVar is put. -- Rethrows any exceptions. untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () From 8c3773f648cf31ad4dfa4b54e2321576253739d5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 8 Jun 2024 20:29:33 +0800 Subject: [PATCH 20/30] typo --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 2d13b87809..d50cfc2df1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -379,7 +379,7 @@ makeWithHieDbRetryable recorder rng hieDb f = -- 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 -- --- ALso see Note [Serializing runs in separate thread] +-- 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 From 5f27faddf83d7c99bdeac85b3e9d1346fe3e5fe2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 8 Jun 2024 20:30:23 +0800 Subject: [PATCH 21/30] ident --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 265d48ae32..0d25dc81f7 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -256,7 +256,6 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c pure $ Right (env,ide) - -- | runWithWorkerThreads -- create several threads to run the session, db and session loader -- see Note [Serializing runs in separate thread] From e800cac6a2697032abe0b8041c882c88012f7c96 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 8 Jun 2024 20:32:26 +0800 Subject: [PATCH 22/30] Improve Note --- ghcide/src/Development/IDE/Core/WorkerThread.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index fb0266dc0b..20766cafd3 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -11,7 +11,8 @@ import Control.Monad.Cont (ContT (ContT)) -- Note [Serializing runs in separate thread] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In a lof cases we want to have a separate thread that will serialize the runs of the actions. +-- 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. From 86d7fb995425354d1be9db2a60c9902bee641011 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 8 Jun 2024 20:32:56 +0800 Subject: [PATCH 23/30] add comment --- ghcide/src/Development/IDE/Core/WorkerThread.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index 20766cafd3..cb5bb60516 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -23,6 +23,7 @@ import Control.Monad.Cont (ContT (ContT)) -- * `blockRunInThread` : accepts a `TQueue` and an action to run in separate thread and waits for the result. +-- | withWorkerQueue creates a new TQueue and runs the workerAction in a separate thread. withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t) withWorkerQueue workerAction = ContT $ \mainAction -> do q <- newTQueueIO From 027e5befc5b9cda96deeee8102f497c6b262148a Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 8 Jun 2024 20:39:02 +0800 Subject: [PATCH 24/30] format --- ghcide/src/Development/IDE/Core/Service.hs | 1 - ghcide/src/Development/IDE/LSP/LanguageServer.hs | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index a73f32161b..52639aeb22 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -31,7 +31,6 @@ import Ide.Plugin.Config import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Control.Concurrent.STM (TQueue) import Control.Monad import qualified Development.IDE.Core.FileExists as FileExists import qualified Development.IDE.Core.OfInterest as OfInterest diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 0d25dc81f7..cf7845ce08 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -1,9 +1,8 @@ - -- 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 From 99322fa6432ccf53855705fdfa74ee1d5092abce Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 8 Jun 2024 23:12:53 +0800 Subject: [PATCH 25/30] Update WorkerThread.hs Co-authored-by: Michael Peyton Jones --- ghcide/src/Development/IDE/Core/WorkerThread.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index cb5bb60516..2bf386ce8b 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -23,7 +23,9 @@ import Control.Monad.Cont (ContT (ContT)) -- * `blockRunInThread` : accepts a `TQueue` and an action to run in separate thread and waits for the result. --- | withWorkerQueue creates a new TQueue and runs the workerAction in a separate thread. +-- | '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 From c1b3e7dac67a38a2236ac231141476dde01d09b0 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 8 Jun 2024 23:15:43 +0800 Subject: [PATCH 26/30] Update WorkerThread.hs Co-authored-by: Michael Peyton Jones --- ghcide/src/Development/IDE/Core/WorkerThread.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index 2bf386ce8b..d024f1fd9d 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -36,7 +36,8 @@ withWorkerQueue workerAction = ContT $ \mainAction -> do l <- atomically $ readTQueue q workerAction l --- | blockRunInThread run and wait for the result +-- | 'blockRunInThread' queues up an 'IO' action to be run by a worker thread, +-- and then blocks until the result is computed. blockRunInThread :: TQueue (IO ()) -> IO result -> IO result blockRunInThread q act = do -- Take an action from TQueue, run it and From a16d04a7aefa2403958a51ed2b4160e40cc4b706 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 9 Jun 2024 00:02:45 +0800 Subject: [PATCH 27/30] rename to await --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- ghcide/src/Development/IDE/Core/WorkerThread.hs | 10 +++++----- ghcide/src/Development/IDE/Main.hs | 1 - 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index d50cfc2df1..aaa74bcc8c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -105,7 +105,7 @@ 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 (blockRunInThread, +import Development.IDE.Core.WorkerThread (awaitRunInThread, withWorkerQueue) import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, @@ -737,7 +737,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do returnWithVersion $ \file -> do -- see Note [Serializing runs in separate thread] - blockRunInThread que $ getOptions file + 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/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d734454787..d426ba34f8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -806,7 +806,7 @@ delayedAction a = do -- 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 = - void $ blockRunInThread (restartQueue shakeExtras) $ do + void $ awaitRunInThread (restartQueue shakeExtras) $ do withMVar' shakeSession (\runner -> do diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index cb5bb60516..7ccf2b4908 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -1,5 +1,5 @@ module Development.IDE.Core.WorkerThread - (withWorkerQueue, blockRunInThread) + (withWorkerQueue, awaitRunInThread) where import Control.Concurrent.Async @@ -20,7 +20,7 @@ import Control.Monad.Cont (ContT (ContT)) -- -- `Development.IDE.Core.WorkerThread` module provides a simple api to implement this easily. -- * `withWorkerQueue`: accepts an action to run in separate thread and returns a `TQueue` to send the actions to run. --- * `blockRunInThread` : accepts a `TQueue` and an action to run in separate thread and waits for the result. +-- * `awaitRunInThread` : accepts a `TQueue` and an action to run in separate thread and waits for the result. -- | withWorkerQueue creates a new TQueue and runs the workerAction in a separate thread. @@ -34,9 +34,9 @@ withWorkerQueue workerAction = ContT $ \mainAction -> do l <- atomically $ readTQueue q workerAction l --- | blockRunInThread run and wait for the result -blockRunInThread :: TQueue (IO ()) -> IO result -> IO result -blockRunInThread q act = do +-- | awaitRunInThread run and wait for the result +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 diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 11056a25d1..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, From c832da3b55978cdba104dcaa879998fdc13f866a Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 9 Jun 2024 00:04:09 +0800 Subject: [PATCH 28/30] use block comment --- .../src/Development/IDE/Core/WorkerThread.hs | 25 ++++++++++--------- 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index 7ccf2b4908..4deafcf911 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -9,19 +9,20 @@ import Control.Concurrent.Strict (newBarrier, signalBarrier, 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. --- --- `Development.IDE.Core.WorkerThread` module provides a simple api to implement this easily. --- * `withWorkerQueue`: accepts an action to run in separate thread and returns a `TQueue` to send the actions to run. --- * `awaitRunInThread` : accepts a `TQueue` and an action to run in separate thread and waits for the result. +{- +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. + +`Development.IDE.Core.WorkerThread` module provides a simple api to implement this easily. +* `withWorkerQueue`: accepts an action to run in separate thread and returns a `TQueue` to send the actions to run. +* `awaitRunInThread` : accepts a `TQueue` and an action to run in separate thread and waits for the result. +-} -- | withWorkerQueue creates a new TQueue and runs the workerAction in a separate thread. withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t) From 442e776c7070216b1a722a36cd42c6214885b33f Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 9 Jun 2024 00:17:02 +0800 Subject: [PATCH 29/30] Remove duplicated comment --- ghcide/src/Development/IDE/Core/WorkerThread.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index 3c5efc1c63..7cd28df1ec 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -20,8 +20,6 @@ Originally we used various ways to implement this, but it was hard to maintain a Moreover, we can not stop these threads uniformly when we are shutting down the server. `Development.IDE.Core.WorkerThread` module provides a simple api to implement this easily. -* `withWorkerQueue`: accepts an action to run in separate thread and returns a `TQueue` to send the actions to run. -* `awaitRunInThread` : accepts a `TQueue` and an action to run in separate thread and waits for the result. -} -- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker From 5d657b63a649553805df80c05a17b9a639f6b073 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 9 Jun 2024 01:29:49 +0800 Subject: [PATCH 30/30] add file header comment --- ghcide/src/Development/IDE/Core/WorkerThread.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index 7cd28df1ec..a38da77f38 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -1,8 +1,16 @@ +{- +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 +import Control.Concurrent.Async (withAsync) import Control.Concurrent.STM import Control.Concurrent.Strict (newBarrier, signalBarrier, waitBarrier) @@ -18,8 +26,6 @@ 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. - -`Development.IDE.Core.WorkerThread` module provides a simple api to implement this easily. -} -- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker