diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index cdb5ba72cb..b66116627e 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -9,6 +9,8 @@ module Development.IDE.Core.Service( getIdeOptions, getIdeOptionsIO, IdeState, initialise, shutdown, + runWithShake, + ShakeOpQueue, runAction, getDiagnostics, ideLogger, @@ -31,13 +33,24 @@ import Ide.Plugin.Config import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP +import Control.Concurrent.Async (async, withAsync) +import Control.Concurrent.STM (TQueue, atomically, + flushTQueue, newTQueueIO, + readTQueue, writeTBQueue, + writeTQueue) import Control.Monad +import qualified Data.List.NonEmpty as NE +import Data.Semigroup (Semigroup (sconcat)) +import qualified Data.Text as T +import Debug.Trace (traceM) import qualified Development.IDE.Core.FileExists as FileExists import qualified Development.IDE.Core.OfInterest as OfInterest import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Shake (WithHieDb) +import Extra (sleep) +import Ide.Logger (Priority (Info), logWith) import Ide.Types (IdePlugins) import System.Environment (lookupEnv) @@ -66,9 +79,10 @@ initialise :: Recorder (WithPriority Log) -> IdeOptions -> WithHieDb -> IndexQueue + -> ShakeOpQueue -> Monitoring -> IO IdeState -initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do +initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan sq metrics = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -84,6 +98,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with (optTesting options) withHieDb hiedbChan + sq (optShakeOptions options) metrics $ do @@ -94,7 +109,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with -- | Shutdown the Compiler Service. shutdown :: IdeState -> IO () -shutdown = shakeShut +shutdown st = shakeShut st -- This will return as soon as the result of the action is -- available. There might still be other rules running at this point, diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 2b95df4ed0..11279895a2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -25,10 +25,12 @@ module Development.IDE.Core.Shake( IdeState, shakeSessionInit, shakeExtras, shakeDb, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets, Target(..), toKnownFiles, - IdeRule, IdeResult, + IdeRule, IdeResult, restartRecorder, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), - shakeOpen, shakeShut, + shakeOpen, shakeShut, runWithShake, + doShakeRestart, shakeEnqueue, + ShakeOpQueue, newSession, use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, FastResult(..), @@ -76,7 +78,11 @@ module Development.IDE.Core.Shake( ) where import Control.Concurrent.Async +import Control.Concurrent.Extra (signalBarrier, + waitBarrier) import Control.Concurrent.STM +import Control.Concurrent.STM (readTQueue, + writeTQueue) import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq @@ -103,10 +109,13 @@ import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.List.Extra (foldl', partition, - takeEnd) +import Data.List (concat) +import Data.List.Extra (foldl', intercalate, + partition, takeEnd) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Semigroup (Semigroup (sconcat)) import qualified Data.SortedList as SL import Data.String (fromString) import qualified Data.Text as T @@ -117,6 +126,7 @@ import Data.Typeable import Data.Unique import Data.Vector (Vector) import qualified Data.Vector as Vector +import Debug.Trace (traceM) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping @@ -198,6 +208,7 @@ data Log | LogCancelledAction !T.Text | LogSessionInitialised | LogLookupPersistentKey !T.Text + | LogRestartDebounceCount !Int !String | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] @@ -244,6 +255,8 @@ instance Pretty Log where LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) + LogRestartDebounceCount count reason -> + "Restart debounce count:" <+> pretty count <+> ":" <+> pretty reason -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -262,6 +275,10 @@ data HieDbWriter -- with (currently) retry functionality type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +-- ShakeOpQueue is used to enqueue Shake operations. +-- shutdown, restart +type ShakeOpQueue = TQueue RestartArguments + -- Note [Semantic Tokens Cache Location] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- storing semantic tokens cache for each file in shakeExtras might @@ -334,6 +351,7 @@ 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 + , shakeOpQueue :: ShakeOpQueue } type WithProgressFunc = forall a. @@ -620,6 +638,7 @@ shakeOpen :: Recorder (WithPriority Log) -> IdeTesting -> WithHieDb -> IndexQueue + -> ShakeOpQueue -> ShakeOptions -> Monitoring -> Rules () @@ -627,7 +646,7 @@ shakeOpen :: Recorder (WithPriority Log) shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) - withHieDb indexQueue opts monitoring rules = mdo + withHieDb indexQueue shakeOpQueue opts monitoring rules = mdo #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames @@ -721,13 +740,13 @@ shakeSessionInit recorder IdeState{..} = do shakeShut :: IdeState -> IO () shakeShut IdeState{..} = do - runner <- tryReadMVar shakeSession -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. - for_ runner cancelShakeSession - void $ shakeDatabaseProfile shakeDb - progressStop $ progress shakeExtras - stopMonitoring + withMVar shakeSession $ \ShakeSession{cancelShakeSession} -> do + cancelShakeSession + void $ shakeDatabaseProfile shakeDb + progressStop $ progress shakeExtras + stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws @@ -752,36 +771,87 @@ delayedAction a = do extras <- ask liftIO $ shakeEnqueue extras a +data RestartArguments = RestartArguments + { restartVFS :: VFSModified + , restartReasons :: [String] + , restartActions :: [DelayedAction ()] + , restartActionBetweenShakeSession :: [IO [Key]] + -- barrier to wait for the session stopped + , restartBarriers :: [Barrier ()] + , restartRecorder :: Recorder (WithPriority Log) + , restartIdeState :: IdeState + } + +instance Semigroup RestartArguments where + RestartArguments a1 a2 a3 a4 a5 a6 _a7 <> RestartArguments b1 b2 b3 b4 b5 b6 b7 = + RestartArguments (a1 <> b1) (a2 <> b2) (a3 <> b3) (a4 <> b4) (a5 <> b5) b6 b7 + +runWithShake :: (ShakeOpQueue-> IO ()) -> IO () +runWithShake f = do + stopQueue <- newTQueueIO + -- withAsync (stopShakeLoop stopQueue doQueue) $ const $ + withAsync (runShakeLoop stopQueue) $ + const $ f stopQueue + where + runShakeLoop :: ShakeOpQueue -> IO () + runShakeLoop q = do + argHead <- atomically $ readTQueue q + -- sleep 0.1 + -- args <- atomically $ flushTQueue q + case NE.nonEmpty (argHead:[]) of + Nothing -> return () + Just xs -> do + let count = length xs + let arg = sconcat xs + let recorder = restartRecorder arg + logWith recorder Info $ LogRestartDebounceCount count (intercalate ", " (restartReasons arg)) + doShakeRestart arg + runShakeLoop q + + +doShakeRestart :: RestartArguments -> IO () +doShakeRestart RestartArguments{restartIdeState=IdeState{..}, ..} = do + withMVar' shakeSession + (\runner -> do + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + keys <- concat <$> sequence restartActionBetweenShakeSession + mapM_ (flip signalBarrier ()) restartBarriers + 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 restartRecorder Debug $ LogBuildSessionRestart (intercalate ", " restartReasons) 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 restartRecorder shakeExtras restartVFS shakeDb restartActions (intercalate ", " restartReasons)) + where + logErrorAfter :: Seconds -> IO () -> IO () + logErrorAfter seconds action = flip withAsync (const action) $ do + sleep seconds + logWith restartRecorder Error (LogBuildSessionRestartTakingTooLong seconds) + + -- | 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) - where - logErrorAfter :: Seconds -> IO () -> IO () - logErrorAfter seconds action = flip withAsync (const action) $ do - sleep seconds - logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = do + barrier <- newBarrier + let restartArgs = RestartArguments + { restartVFS = vfs + , restartReasons = [reason] + , restartActions = acts + , restartActionBetweenShakeSession = [ioActionBetweenShakeSession] + , restartBarriers = [barrier] + , restartRecorder = recorder + , restartIdeState = IdeState{..} + } + atomically $ writeTQueue (shakeOpQueue $ shakeExtras) restartArgs + waitBarrier barrier -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. @@ -806,6 +876,9 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do return (wait' b >>= either throwIO return) data VFSModified = VFSUnmodified | VFSModified !VFS +instance Semigroup VFSModified where + VFSUnmodified <> x = x + x <> _ = x -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2a4994f5b9..073233dad2 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -33,9 +33,12 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog +import Control.Concurrent.Extra (newBarrier) import Control.Monad.IO.Unlift (MonadUnliftIO) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Service (ShakeOpQueue, + runWithShake) +import Development.IDE.Core.Shake hiding (Log, Priority) import Development.IDE.Core.Tracing import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb) @@ -52,6 +55,7 @@ data Log | LogSession Session.Log | LogLspServer LspServerLog | LogServerShutdownMessage + | LogServerShutdownDoneMessage deriving Show instance Pretty Log where @@ -76,6 +80,7 @@ instance Pretty Log where LogSession msg -> pretty msg LogLspServer msg -> pretty msg LogServerShutdownMessage -> "Received shutdown message" + LogServerShutdownDoneMessage -> "Server shutdown done" -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb @@ -129,12 +134,12 @@ 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 -> IndexQueue -> ShakeOpQueue -> IO IdeState) -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do +setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available clientMsgChan :: Chan ReactorMessage <- newChan @@ -187,7 +192,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 -> IndexQueue -> ShakeOpQueue -> IO IdeState) -> MVar () -> IO () -> (SomeLspId -> IO ()) @@ -229,8 +234,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 $ runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do + putMVar dbMVar (WithHieDbShield withHieDb',hieChan',sq) forever $ do msg <- readChan clientMsgChan -- We dispatch notifications synchronously and requests asynchronously @@ -238,10 +243,11 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa case msg of ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + -- todo cancel shake session and log here logWith recorder Info LogReactorThreadStopped - (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb hieChan + (WithHieDbShield withHieDb,hieChan,sq) <- takeMVar dbMVar + ide <- getIdeState env root withHieDb hieChan sq registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) @@ -267,6 +273,7 @@ shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide + liftIO $ logWith recorder Debug LogServerShutdownDoneMessage resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 2c365475d0..946a16d288 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -50,8 +50,10 @@ import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), GetHieAst (GetHieAst), TypeCheck (TypeCheck)) -import Development.IDE.Core.Service (initialise, - runAction) +import Development.IDE.Core.Service (ShakeOpQueue, + initialise, + runAction, + runWithShake) import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), IndexQueue, @@ -326,8 +328,8 @@ 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 - getIdeState env rootPath withHieDb hieChan = do + let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> ShakeOpQueue -> IO IdeState + getIdeState env rootPath withHieDb hieChan sq = do traverse_ IO.setCurrentDirectory rootPath t <- ioT logWith recorder Info $ LogLspStartDuration t @@ -366,6 +368,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re ideOptions withHieDb hieChan + sq monitoring putMVar ideStateVar ide pure ide @@ -390,7 +393,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 + runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -418,7 +421,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , 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 hieChan sq mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -448,7 +451,7 @@ 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 + runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options @@ -456,7 +459,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , 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 hieChan sq mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/hls-graph/src/Paths.hs b/hls-graph/src/PathsHlsGraph.hs similarity index 100% rename from hls-graph/src/Paths.hs rename to hls-graph/src/PathsHlsGraph.hs