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