diff --git a/ghcide-test/exe/Main.hs b/ghcide-test/exe/Main.hs index b41290198e..93c784672f 100644 --- a/ghcide-test/exe/Main.hs +++ b/ghcide-test/exe/Main.hs @@ -63,6 +63,7 @@ import ReferenceTests import ResolveTests import RootUriTests import SafeTests +import ShakeRestartTests import SymlinkTests import THTests import UnitTests @@ -105,4 +106,5 @@ main = do , GarbageCollectionTests.tests , HieDbRetry.tests , ExceptionTests.tests + , ShakeRestartTests.tests ] diff --git a/ghcide-test/exe/ShakeRestartTests.hs b/ghcide-test/exe/ShakeRestartTests.hs new file mode 100644 index 0000000000..2b91740302 --- /dev/null +++ b/ghcide-test/exe/ShakeRestartTests.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module ShakeRestartTests (tests) where + +import Control.Concurrent.STM +import Data.IORef +import Data.IORef.Extra (atomicModifyIORef'_) +import Development.IDE.Core.Shake +import Development.IDE.Graph (newKey) +import Language.LSP.VFS +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "shake restart merging" + [ testCase "newestVFSModified" $ do + let vfs1 = VFSModified (VFS mempty) + newestVFSModified VFSUnmodified VFSUnmodified @?= VFSUnmodified + newestVFSModified vfs1 VFSUnmodified @?= vfs1 + newestVFSModified VFSUnmodified vfs1 @?= vfs1 + + , testCase "mergePendingRestart Nothing" $ do + let p = PendingRestart VFSUnmodified [] ["reason"] [] [] + if mergePendingRestart p Nothing == p + then pure () + else assertFailure "merging with nothing should get new" + + , testCase "mergePendingRestart Just" $ do + done1 <- newEmptyTMVarIO + done2 <- newEmptyTMVarIO + let key1 = newKey ("1" :: String) + key2 = newKey ("2" :: String) + p1 = PendingRestart VFSUnmodified [pure [key1]] ["r1"] [] [done1] + p2 = PendingRestart VFSUnmodified [pure [key2]] ["r2"] [] [done2] + merged = mergePendingRestart p1 (Just p2) + + pendingRestartReasons merged @?= ["r1", "r2"] + keys <- sequence $ pendingRestartActionBetweenSessions merged + concat keys @?= [key2, key1] + + , testCase "RestartSlot coalescing" $ do + slot <- newRestartSlot + let p1 = PendingRestart VFSUnmodified [] ["r1"] [] [] + p2 = PendingRestart VFSUnmodified [] ["r2"] [] [] + + atomicModifyIORef'_ (queuedRestart slot) $ Just . mergePendingRestart p1 + atomicModifyIORef'_ (queuedRestart slot) $ Just . mergePendingRestart p2 + + res <- atomicModifyIORef' (queuedRestart slot) (Nothing,) + case res of + Nothing -> assertFailure "Should have a pending restart" + Just p -> pendingRestartReasons p @?= ["r2", "r1"] + ] + +instance Eq VFSModified where + VFSUnmodified == VFSUnmodified = True + VFSModified (VFS _) == VFSModified (VFS _) = True + _ == _ = False + +instance Eq PendingRestart where + p1 == p2 = pendingRestartVFS p1 == pendingRestartVFS p2 && + pendingRestartReasons p1 == pendingRestartReasons p2 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7e1a062a7a..ea2f44f86e 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -729,7 +729,7 @@ checkInCache sessionState ncfp = runMaybeT $ do -- | Modify the shake state. data SessionShake = SessionShake - { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () + { restartSession :: VFSModified -> T.Text -> [DelayedAction ()] -> IO [Key] -> IO () , invalidateCache :: IO Key , enqueueActions :: DelayedAction () -> IO (IO ()) } diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 37177a22d1..0f1859e829 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -280,7 +280,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do + restartShakeSession (shakeExtras state) vfs (T.pack (fromNormalizedFilePath nfp ++ " (modified)")) [] $ do keys<-actionBefore return (toKey GetModificationTime nfp:keys) when checkParents $ @@ -302,7 +302,7 @@ typecheckParentsAction recorder nfp = do -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified. -setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified :: VFSModified -> IdeState -> T.Text -> IO [Key] -> IO () setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c9e8b7b45e..47e3befb5d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -4,6 +4,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} @@ -28,6 +29,7 @@ module Development.IDE.Core.Shake( IdeRule, IdeResult, RestartQueue, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, + withRestartWorker, newRestartSlot, shakeEnqueue, newSession, use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, @@ -70,7 +72,11 @@ module Development.IDE.Core.Shake( IndexQueue, HieDb, HieDbWriter(..), + PendingRestart(..), + RestartSlot(..), addPersistentRule, + newestVFSModified, + mergePendingRestart, garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, Log(..), @@ -127,13 +133,12 @@ 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.WorkerThread import Development.IDE.Types.Options as Options import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.VFS as VFS import Development.IDE.Core.Tracing -import Development.IDE.Core.WorkerThread #if MIN_VERSION_ghc(9,13,0) import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater, @@ -144,6 +149,8 @@ import Development.IDE.GHC.Compat (NameCache, initNameCache, knownKeyNames) #endif +import Data.IORef.Extra (atomicModifyIORef'_) +import qualified Data.Text.Encoding as T import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue, action) @@ -185,13 +192,16 @@ import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra -import UnliftIO (MonadUnliftIO (withRunInIO)) +import UnliftIO (IORef, + MonadUnliftIO (withRunInIO), + atomicModifyIORef', + newIORef) data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) + | LogBuildSessionRestart ![T.Text] ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !(Maybe SomeException) @@ -204,6 +214,7 @@ data Log | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] + | LogRestartWorkerException !SomeException deriving Show instance Pretty Log where @@ -247,6 +258,8 @@ instance Pretty Log where LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) + LogRestartWorkerException e -> + "Restart worker exception:" <+> pretty (displayException e) -- | 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 @@ -268,9 +281,9 @@ type LoaderQueue = TaskQueue (IO ()) data ThreadQueue = ThreadQueue { - tIndexQueue :: IndexQueue - , tRestartQueue :: RestartQueue - , tLoaderQueue :: LoaderQueue + tIndexQueue :: IndexQueue + , tRestartSlot :: RestartSlot + , tLoaderQueue :: LoaderQueue } -- Note [Semantic Tokens Cache Location] @@ -314,7 +327,7 @@ data ShakeExtras = ShakeExtras -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession :: VFSModified - -> String + -> T.Text -> [DelayedAction ()] -> IO [Key] -> IO () @@ -341,8 +354,8 @@ 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 :: RestartQueue - -- ^ Queue of restart actions to be run. + , restartSlot :: RestartSlot + -- ^ Restart action to be run. , loaderQueue :: LoaderQueue -- ^ Queue of loader actions to be run. } @@ -674,7 +687,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer withHieDb threadQueue opts monitoring rules rootDir = mdo -- see Note [Serializing runs in separate thread] let indexQueue = tIndexQueue threadQueue - restartQueue = tRestartQueue threadQueue + restartSlot = tRestartSlot threadQueue loaderQueue = tLoaderQueue threadQueue #if MIN_VERSION_ghc(9,13,0) @@ -691,7 +704,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer semanticTokensCache <- STM.newIO positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets - let restartShakeSession = shakeRestart recorder ideState + let restartShakeSession = shakeRestart ideState persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 @@ -765,7 +778,7 @@ shakeSessionInit recorder IdeState{..} = do -- Take a snapshot of the VFS - it should be empty as we've received no notifications -- till now, but it can't hurt to be in sync with the `lsp` library. vfs <- vfsSnapshot (lspEnv shakeExtras) - initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" + initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] ["shakeSessionInit"] putMVar shakeSession initSession logWith recorder Debug LogSessionInitialised @@ -803,38 +816,113 @@ delayedAction a = do extras <- ask liftIO $ shakeEnqueue extras a +data PendingRestart = PendingRestart + { pendingRestartVFS :: !VFSModified + , pendingRestartActionBetweenSessions :: ![IO [Key]] + , pendingRestartReasons :: ![T.Text] + , pendingRestartActions :: ![DelayedActionInternal] + , pendingRestartDoneSignals :: ![TMVar ()] + } + +newestVFSModified :: VFSModified -> VFSModified -> VFSModified +newestVFSModified VFSUnmodified old = old +newestVFSModified new@(VFSModified _) _ = new + +mergePendingRestart :: PendingRestart -> Maybe PendingRestart -> PendingRestart +mergePendingRestart new Nothing = new +mergePendingRestart new (Just old) = PendingRestart + { pendingRestartVFS = newestVFSModified (pendingRestartVFS new) (pendingRestartVFS old) + , pendingRestartReasons = pendingRestartReasons new ++ pendingRestartReasons old + , pendingRestartActions = pendingRestartActions new ++ pendingRestartActions old + , pendingRestartActionBetweenSessions = pendingRestartActionBetweenSessions new ++ pendingRestartActionBetweenSessions old + , pendingRestartDoneSignals = pendingRestartDoneSignals new ++ pendingRestartDoneSignals old + } + +data RestartSlot = RestartSlot + { queuedRestart :: IORef (Maybe PendingRestart) + , restartSignal :: MVar () + , lastRestartBarrier :: TVar (TMVar ()) + -- ^ A barrier that is filled when the most recent shake restart completes. + -- + -- Each call to 'shakeRestart' replaces this with a fresh empty TMVar. The + -- restart worker fills it when the restart finishes. Dependents on the + -- restart can then wait on this. + } + +newRestartSlot :: IO RestartSlot +newRestartSlot = do + initialBarrier <- newTMVarIO () -- starts filled (no pending restart) + RestartSlot <$> newIORef Nothing <*> newEmptyMVar <*> newTVarIO initialBarrier -- | 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 = - void $ awaitRunInThread (restartQueue shakeExtras) $ do - withMVar' - shakeSession - (\runner -> do - (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - keys <- ioActionBetweenShakeSession - -- it is every important to update the dirty keys after we enter the critical section - -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys - res <- shakeDatabaseProfile shakeDb - backlog <- readTVarIO $ dirtyKeys shakeExtras - queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - - -- this log is required by tests - logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res - ) - -- It is crucial to be masked here, otherwise we can get killed - -- between spawning the new thread and updating shakeSession. - -- See https://github.com/haskell/ghcide/issues/79 - (\() -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) - where - logErrorAfter :: Seconds -> IO () -> IO () - logErrorAfter seconds action = flip withAsync (const action) $ do - sleep seconds - logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) +-- +-- Any actions running in the current session will be aborted, but actions added +-- via 'shakeEnqueue' will be requeued. +shakeRestart :: IdeState -> VFSModified -> T.Text -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart IdeState{..} vfs reason acts ioActionBetweenShakeSession = do + restartDone <- newEmptyTMVarIO + let slot = restartSlot shakeExtras + -- Publish this restart's barrier, that dependents LSP requests can wait on. + atomically $ writeTVar (lastRestartBarrier slot) restartDone + atomicModifyIORef'_ (queuedRestart slot) $ Just . mergePendingRestart PendingRestart + { pendingRestartVFS = vfs + , pendingRestartActionBetweenSessions = [ioActionBetweenShakeSession] + , pendingRestartReasons = [reason] + , pendingRestartActions = acts + , pendingRestartDoneSignals = [restartDone] + } + void $ tryPutMVar (restartSignal slot) () + -- Block until the restart (including ioActionBetweenShakeSession) completes. + -- This preserves the invariant from the original synchronous shakeRestart: + -- callers (e.g. the session loader) must not proceed until their + -- between-session actions have run, otherwise downstream rules can observe + -- stale results (see Note at Session.hs restartSession call site). + atomically $ readTMVar restartDone + +-- | Run a worker that asynchronously processes shake restart requests. Will +-- only ever queue upto 1 additional restart, accumulating data while processing +-- any restart. +withRestartWorker :: IdeState -> IO r -> IO r +withRestartWorker ide@IdeState{..} action = + withAsync (forever $ + processPendingRestart (shakeRecorder shakeExtras) ide + `catch` \(e :: SomeException) -> + logWith (shakeRecorder shakeExtras) Error (LogRestartWorkerException e)) $ + \_ -> action + +processPendingRestart :: Recorder (WithPriority Log) -> IdeState -> IO () +processPendingRestart recorder IdeState{..} = do + takeMVar (restartSignal (restartSlot shakeExtras)) + pendingRestart <- atomicModifyIORef' (queuedRestart (restartSlot shakeExtras)) (Nothing,) + void $ forM pendingRestart $ \PendingRestart {..} -> do + flip finally (atomically $ traverse (flip tryPutTMVar ()) (reverse pendingRestartDoneSignals)) $ do + let sessionAction runner = do + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + keys <- fmap concat (sequence (reverse pendingRestartActionBetweenSessions)) + -- 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 (reverse pendingRestartReasons) queue backlog stopTime res + + withMVar' shakeSession sessionAction $ \() -> + -- 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 + (,()) <$> newSession recorder shakeExtras pendingRestartVFS shakeDb + (reverse pendingRestartActions) + (reverse pendingRestartReasons) + pure () + where + logErrorAfter :: Seconds -> IO () -> IO () + logErrorAfter seconds action = flip withAsync (const action) $ do + sleep seconds + logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) + -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. @@ -859,6 +947,7 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do return (wait' b >>= either throwIO return) data VFSModified = VFSUnmodified | VFSModified !VFS + deriving Show -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. @@ -868,9 +957,9 @@ newSession -> VFSModified -> ShakeDatabase -> [DelayedActionInternal] - -> String + -> [T.Text] -> IO ShakeSession -newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do +newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reasons = do -- Take a new VFS snapshot case vfsMod of @@ -901,7 +990,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do -- The inferred type signature doesn't work in ghc >= 9.0.1 workRun :: (forall b. IO b -> IO b) -> IO (IO ()) workRun restore = withSpan "Shake session" $ \otSpan -> do - setTag otSpan "reason" (fromString reason) + setTag otSpan "reason" (T.encodeUtf8 (T.intercalate ", " reasons)) setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued) whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index ad21bc68f7..c64be33e3c 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -40,7 +40,8 @@ import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier) import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Trans.Cont (evalContT) +import Control.Monad.Trans.Cont (ContT (..), evalContT) +import Data.Foldable (traverse_) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service (shutdown) import Development.IDE.Core.Shake hiding (Log) @@ -54,6 +55,7 @@ import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) import System.Timeout (timeout) + data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException @@ -291,9 +293,8 @@ handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "In ideMVar <- newEmptyMVar let - handleServerExceptionOrShutDown me = do + loggedTeardown me = do -- shutdown shake - tryReadMVar ideMVar >>= mapM_ shutdown case me of Left e -> do lifetimeConfirm "due to exception in reactor thread" @@ -326,35 +327,77 @@ handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "In $ \(e :: SomeException) -> do exceptionInHandler e k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing - _ <- flip forkFinally handleServerExceptionOrShutDown $ do - runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> do - ide <- ctxGetIdeState lifecycleCtx env root withHieDb' threadQueue' - putMVar ideMVar ide - -- Keep this after putMVar ideMVar ide; otherwise shutdown during - -- initialization could leave handleInit blocked indefinitely on readMVar. - untilReactorStopSignal $ forever $ do - msg <- readChan $ ctxClientMsgChan lifecycleCtx - -- We dispatch notifications synchronously and requests asynchronously - -- This is to ensure that all file edits and config changes are applied before a request is handled - case msg of - ReactorNotification act -> handle exceptionInHandler act - ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - logWith recorder Info LogReactorThreadStopped + _ <- flip forkFinally loggedTeardown $ do + -- Need to be careful about when the shutdown occurs, it needs to be shut + -- down after the session loader and restarting threads, and before the + -- hiedb connections are closed. + let shutdownSession = tryReadMVar ideMVar >>= traverse_ shutdown + + -- Ensure that any request waits for all notifications that preceded + -- it in the channel to complete, so file edits and config changes + -- are applied before a request is handled. Notifications and requests + -- are each concurrent within their own kind. + -- + -- Implemented using a list of MVars, one per in-flight notification. + -- Requests snapshot this list at dequeue time and wait on all of them. + -- Completed MVars are pruned when new notifications are added. + notificationLocks <- newTVarIO ([] :: [TMVar ()]) + let + consumeChannel threadQueue = do + msg <- readChan $ ctxClientMsgChan lifecycleCtx + case msg of + ReactorNotification act -> do + done <- newEmptyTMVarIO + atomically $ do + old <- readTVar notificationLocks + pruned <- filterM (\m -> isNothing <$> tryReadTMVar m) old + writeTVar notificationLocks (done : pruned) + let + slot = tRestartSlot threadQueue + -- After the notification handler returns, check whether + -- a shake restart was triggered. + -- + -- If so, wait for it to complete before signaling 'done' + -- so that subsequent requests see the updated VFS / + -- session. + restartDone = do + barrier <- atomically $ readTVar (lastRestartBarrier slot) + async $ atomically $ do + readTMVar barrier + putTMVar done () + + finally (handle exceptionInHandler act) restartDone + ReactorRequest _id act k -> do + currentNotifications <- readTVarIO notificationLocks + void $ async $ do + void $ atomically (traverse readTMVar currentNotifications) + checkCancelled _id act k + + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc shutdownSession $ \withHieDb' threadQueue' -> do + ide <- ctxGetIdeState lifecycleCtx env root withHieDb' threadQueue' + registerIdeConfiguration (shakeExtras ide) initConfig + putMVar ideMVar ide + + withRestartWorker ide $ untilReactorStopSignal $ forever (consumeChannel threadQueue') + logWith recorder Info LogReactorThreadStopped ide <- readMVar ideMVar - registerIdeConfiguration (shakeExtras ide) initConfig - pure $ Right (env,ide) + 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 - (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc - sessionRestartTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "RestartTQueue" - sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue" - liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) +runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> IO () -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () +runWithWorkerThreads recorder dbLoc shutdownSession f = evalContT $ do + (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc + -- The shake session needs to be shut down prior to the hiedb connections + -- being cleaned up, otherwise shake could be referencing dead connections. + -- This is passed in via the callsites. + ContT $ \action -> action () `finally` shutdownSession + sessionRestartTQueue <- liftIO $ newRestartSlot + sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue" + liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. -- It is important, that the thread that puts the 'MVar' is not dropped before it puts the 'MVar' i.e. it should diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 4f5475442c..ac6aa51eb8 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -94,7 +94,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do let msg = "Closed text document: " <> getUri _uri - setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do + setSomethingModified (VFSModified vfs) ide msg $ do scheduleGarbageCollection ide deleteFileOfInterest ide file logWith recorder Debug $ LogClosedTextDocument _uri @@ -113,8 +113,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat , not $ HM.member nfp filesOfInterest ] unless (null fileEvents') $ do - let msg = show fileEvents' - logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) + let msg = Text.pack (show fileEvents') + logWith recorder Debug $ LogWatchedFileEvents msg setSomethingModified (VFSModified vfs) ide msg $ do ks1 <- resetFileStore ide fileEvents' ks2 <- modifyFileExists ide fileEvents' diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 58cffe27e7..8316b6297a 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -53,7 +53,8 @@ import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), ThreadQueue (tLoaderQueue), shakeSessionInit, - uses) + uses, + withRestartWorker) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, @@ -378,7 +379,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Check argFiles -> do let dir = argsProjectRoot dbLoc <- getHieDbLoc dir - runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -407,22 +408,23 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty dir - shakeSessionInit (cmapWithPrio LogShake recorder) ide - registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) - - putStrLn "\nStep 4/4: Type checking the files" - setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') absoluteFiles - results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' absoluteFiles) - _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' absoluteFiles) - _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' absoluteFiles) - let (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles - when (failed /= []) $ - putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed - - let nfiles xs = let n' = length xs in if n' == 1 then "1 file" else show n' ++ " files" - putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" - - unless (null failed) (exitWith $ ExitFailure (length failed)) + withRestartWorker ide $ do + shakeSessionInit (cmapWithPrio LogShake recorder) ide + registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) + + putStrLn "\nStep 4/4: Type checking the files" + setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') absoluteFiles + results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' absoluteFiles) + _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' absoluteFiles) + _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' absoluteFiles) + let (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles + when (failed /= []) $ + putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed + + let nfiles xs = let n' = length xs in if n' == 1 then "1 file" else show n' ++ " files" + putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" + + unless (null failed) (exitWith $ ExitFailure (length failed)) Db opts cmd -> do let root = argsProjectRoot dbLoc <- getHieDbLoc root @@ -436,7 +438,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Custom (IdeCommand c) -> do let root = argsProjectRoot dbLoc <- getHieDbLoc root - runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options @@ -445,9 +447,10 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty root - shakeSessionInit (cmapWithPrio LogShake recorder) ide - registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) - c ide + withRestartWorker ide $ do + shakeSessionInit (cmapWithPrio LogShake recorder) ide + registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) + c ide -- | List the haskell files given some paths -- diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 682d81dd10..47c4b1f619 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2107,6 +2107,7 @@ test-suite ghcide-tests , extra , filepath , ghcide + , hls-graph , hls-plugin-api , lens , list-t @@ -2174,6 +2175,7 @@ test-suite ghcide-tests ResolveTests RootUriTests SafeTests + ShakeRestartTests SymlinkTests THTests UnitTests diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index dadc5503fc..47d2489682 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -180,7 +180,7 @@ Then we restart the shake session, so that changes to our virtual files are actu -} restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras (VFSModified vfs) (T.pack (List.intercalate " " [fromNormalizedFilePath file, actionMsg])) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:keys) @@ -189,7 +189,7 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d -- rule to get re-run if the file changes on disk. restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras (VFSModified vfs) (T.pack (List.intercalate " " [fromNormalizedFilePath file, actionMsg])) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys)