Fix hanging after exit is sent #4152

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,

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

@@ -25,10 +25,12 @@
     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 @@
     ) 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 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,13 +126,14 @@
 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
 import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Tracing
 import           Development.IDE.GHC.Compat             (NameCache,
                                                          initNameCache,
                                                          knownKeyNames)
 import           Development.IDE.GHC.Orphans            ()
@@ -198,6 +208,7 @@
   | 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 @@
     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 @@
 -- 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 @@
       -- ^ 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,14 +638,15 @@
           -> IdeTesting
           -> WithHieDb
           -> IndexQueue
+          -> ShakeOpQueue
           -> ShakeOptions
           -> Monitoring
           -> Rules ()
           -> IO IdeState
 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 @@
 
 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 @@
   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 @@
     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.

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,19 +234,20 @@ 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
                 -- 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
+        -- 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)