Only do async session restarts

Author: crtschin

ghcide/src/Development/IDE/Core/Shake.hs

@@ -817,11 +817,11 @@ delayedAction a = do
   liftIO $ shakeEnqueue extras a
 
 data PendingRestart = PendingRestart
-    { pendingRestartVFS                   :: VFSModified
-    , pendingRestartActionBetweenSessions :: IO [Key]
-    , pendingRestartReasons               :: [T.Text]
-    , pendingRestartActions               :: [DelayedActionInternal]
-    , pendingRestartDoneSignals           :: [TMVar ()]
+    { pendingRestartVFS                   :: !VFSModified
+    , pendingRestartActionBetweenSessions :: ![IO [Key]]
+    , pendingRestartReasons               :: ![T.Text]
+    , pendingRestartActions               :: ![DelayedActionInternal]
+    , pendingRestartDoneSignals           :: ![TMVar ()]
     }
 
 newestVFSModified :: VFSModified -> VFSModified -> VFSModified
@@ -832,35 +832,46 @@ 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
-    -- TODO: Contains a quadratic list append on the number of accumulated shake restarts.
-    , pendingRestartActions = pendingRestartActions old <> pendingRestartActions new
-    , pendingRestartActionBetweenSessions = pendingRestartActionBetweenSessions old <> pendingRestartActionBetweenSessions new
-    , pendingRestartDoneSignals = pendingRestartDoneSignals new <> pendingRestartDoneSignals 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 ()
+    { 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 = RestartSlot <$> newIORef Nothing <*> newEmptyMVar
+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.
+--
+-- 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
-    atomicModifyIORef'_ (queuedRestart (restartSlot shakeExtras)) $ Just . mergePendingRestart PendingRestart
+    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
+        , pendingRestartActionBetweenSessions = [ioActionBetweenShakeSession]
         , pendingRestartReasons = [reason]
         , pendingRestartActions = acts
         , pendingRestartDoneSignals = [restartDone]
         }
-    void $ tryPutMVar (restartSignal (restartSlot shakeExtras)) ()
-    atomically $ readTMVar restartDone
+    void $ tryPutMVar (restartSignal slot) ()
 
 -- | Run a worker that asynchronously processes shake restart requests. Will
 -- only ever queue upto 1 additional restart, accumulating data while processing
@@ -878,10 +889,10 @@ 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 ()) pendingRestartDoneSignals) $ do
+        flip finally (atomically $ traverse (flip tryPutTMVar ()) (reverse pendingRestartDoneSignals)) $ do
             let sessionAction runner = do
                     (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
-                    keys <- pendingRestartActionBetweenSessions
+                    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
@@ -890,13 +901,15 @@ processPendingRestart recorder IdeState{..} = do
                     queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
 
                     -- this log is required by tests
-                    logWith recorder Debug $ LogBuildSessionRestart pendingRestartReasons queue backlog stopTime res
+                    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 pendingRestartActions pendingRestartReasons
+                (,()) <$> newSession recorder shakeExtras pendingRestartVFS shakeDb
+                    (reverse pendingRestartActions)
+                    (reverse pendingRestartReasons)
     pure ()
   where
     logErrorAfter :: Seconds -> IO () -> IO ()

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -343,7 +343,7 @@ handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "In
         -- Completed MVars are pruned when new notifications are added.
         notificationLocks <- newTVarIO ([] :: [TMVar ()])
         let
-          consumeChannel = do
+          consumeChannel threadQueue = do
             msg <- readChan $ ctxClientMsgChan lifecycleCtx
             case msg of
               ReactorNotification act -> do
@@ -352,9 +352,21 @@ handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "In
                   old <- readTVar notificationLocks
                   pruned <- filterM (\m -> isNothing <$> tryReadTMVar m) old
                   writeTVar notificationLocks (done : pruned)
-                void $ async $
-                  handle exceptionInHandler act
-                    `finally` atomically (putTMVar done ())
+                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
@@ -365,14 +377,12 @@ handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "In
           ide <- ctxGetIdeState lifecycleCtx env root withHieDb' threadQueue'
           registerIdeConfiguration (shakeExtras ide) initConfig
           putMVar ideMVar ide
-          -- Keep this after putMVar ideMVar ide; otherwise shutdown during
-          -- initialization could leave handleInit blocked indefinitely on readMVar.
-          withRestartWorker ide $ do
-            untilReactorStopSignal $ forever consumeChannel
-        logWith recorder Info LogReactorThreadStopped
+
+          withRestartWorker ide $ untilReactorStopSignal $ forever (consumeChannel threadQueue')
+          logWith recorder Info LogReactorThreadStopped
 
     ide <- readMVar ideMVar
-    pure $ Right (env,ide)
+    pure $ Right (env, ide)
 
 
 -- | runWithWorkerThreads