Skip to content

Commit 277998e

Browse files
soulomoonsoulomoon
committed
thread shake restart to a worker thread
1 parent 240254e commit 277998e

File tree

4 files changed

+44
-16
lines changed

4 files changed

+44
-16
lines changed

‎ghcide/src/Development/IDE/Core/Service.hs‎

Lines changed: 19 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,8 @@
99
module Development.IDE.Core.Service(
1010
getIdeOptions, getIdeOptionsIO,
1111
IdeState, initialise, shutdown,
12+
runWithShake,
13+
ShakeOpQueue,
1214
runAction,
1315
getDiagnostics,
1416
ideLogger,
@@ -40,6 +42,8 @@ import Development.IDE.Types.Monitoring (Monitoring)
4042
import Development.IDE.Types.Shake (WithHieDb)
4143
import Ide.Types (IdePlugins)
4244
import System.Environment (lookupEnv)
45+
import Control.Concurrent.STM (TQueue, newTQueueIO, atomically, readTQueue, writeTQueue, writeTBQueue)
46+
import Control.Concurrent.Async (withAsync, async)
4347

4448
data Log
4549
= LogShake Shake.Log
@@ -66,9 +70,10 @@ initialise :: Recorder (WithPriority Log)
6670
-> IdeOptions
6771
-> WithHieDb
6872
-> IndexQueue
73+
-> ShakeOpQueue
6974
-> Monitoring
7075
-> IO IdeState
71-
initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do
76+
initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan sq metrics = do
7277
shakeProfiling <- do
7378
let fromConf = optShakeProfiling options
7479
fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
@@ -84,6 +89,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with
8489
(optTesting options)
8590
withHieDb
8691
hiedbChan
92+
sq
8793
(optShakeOptions options)
8894
metrics
8995
$ do
@@ -94,11 +100,22 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with
94100

95101
-- | Shutdown the Compiler Service.
96102
shutdown :: IdeState -> IO ()
97-
shutdown = shakeShut
103+
shutdown st = atomically $ writeTQueue (shakeOpQueue $ shakeExtras st) $ shakeShut st
98104

99105
-- This will return as soon as the result of the action is
100106
-- available. There might still be other rules running at this point,
101107
-- e.g., the ofInterestRule.
102108
runAction :: String -> IdeState -> Action a -> IO a
103109
runAction herald ide act =
104110
join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug act)
111+
112+
113+
runWithShake :: (ShakeOpQueue-> IO ()) -> IO ()
114+
runWithShake f = do
115+
q <- newTQueueIO
116+
withAsync (runShakeOp q) $ const $ f q
117+
where
118+
runShakeOp :: ShakeOpQueue -> IO ()
119+
runShakeOp q = do
120+
join $ atomically $ readTQueue q
121+
runShakeOp q

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

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ module Development.IDE.Core.Shake(
2929
GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
3030
shakeOpen, shakeShut,
3131
shakeEnqueue,
32+
ShakeOpQueue,
3233
newSession,
3334
use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,
3435
FastResult(..),
@@ -172,6 +173,7 @@ import qualified StmContainers.Map as STM
172173
import System.FilePath hiding (makeRelative)
173174
import System.IO.Unsafe (unsafePerformIO)
174175
import System.Time.Extra
176+
import Control.Concurrent.STM (writeTQueue)
175177
-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
176178

177179
#if !MIN_VERSION_ghc(9,3,0)
@@ -257,6 +259,10 @@ data HieDbWriter
257259
-- with (currently) retry functionality
258260
type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
259261

262+
-- ShakeOpQueue is used to enqueue Shake operations.
263+
-- shutdown, restart
264+
type ShakeOpQueue = TQueue (IO ())
265+
260266
-- Note [Semantic Tokens Cache Location]
261267
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
262268
-- storing semantic tokens cache for each file in shakeExtras might
@@ -329,6 +335,7 @@ data ShakeExtras = ShakeExtras
329335
-- ^ Default HLS config, only relevant if the client does not provide any Config
330336
, dirtyKeys :: TVar KeySet
331337
-- ^ Set of dirty rule keys since the last Shake run
338+
, shakeOpQueue :: ShakeOpQueue
332339
}
333340

334341
type WithProgressFunc = forall a.
@@ -614,14 +621,15 @@ shakeOpen :: Recorder (WithPriority Log)
614621
-> IdeTesting
615622
-> WithHieDb
616623
-> IndexQueue
624+
-> ShakeOpQueue
617625
-> ShakeOptions
618626
-> Monitoring
619627
-> Rules ()
620628
-> IO IdeState
621629
shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
622630
shakeProfileDir (IdeReportProgress reportProgress)
623631
ideTesting@(IdeTesting testing)
624-
withHieDb indexQueue opts monitoring rules = mdo
632+
withHieDb indexQueue shakeOpQueue opts monitoring rules = mdo
625633

626634
#if MIN_VERSION_ghc(9,3,0)
627635
ideNc <- initNameCache 'r' knownKeyNames
@@ -752,6 +760,7 @@ delayedAction a = do
752760
-- but actions added via 'shakeEnqueue' will be requeued.
753761
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
754762
shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
763+
atomically $ writeTQueue (shakeOpQueue $ shakeExtras) $
755764
withMVar'
756765
shakeSession
757766
(\runner -> do

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

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ import Ide.Logger
4242
import Language.LSP.Server (LanguageContextEnv,
4343
LspServerLog,
4444
type (<~>))
45+
import Development.IDE.Core.Service (runWithShake, ShakeOpQueue)
4546
data Log
4647
= LogRegisteringIdeConfig !IdeConfiguration
4748
| LogReactorThreadException !SomeException
@@ -128,7 +129,7 @@ setupLSP ::
128129
Recorder (WithPriority Log)
129130
-> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
130131
-> LSP.Handlers (ServerM config)
131-
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
132+
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> ShakeOpQueue -> IO IdeState)
132133
-> MVar ()
133134
-> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
134135
LSP.Handlers (ServerM config),
@@ -186,7 +187,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
186187
handleInit
187188
:: Recorder (WithPriority Log)
188189
-> (FilePath -> IO FilePath)
189-
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
190+
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> ShakeOpQueue -> IO IdeState)
190191
-> MVar ()
191192
-> IO ()
192193
-> (SomeLspId -> IO ())
@@ -228,8 +229,8 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa
228229
exceptionInHandler e
229230
k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing
230231
_ <- flip forkFinally handleServerException $ do
231-
untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do
232-
putMVar dbMVar (WithHieDbShield withHieDb',hieChan')
232+
untilMVar lifetime $ runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do
233+
putMVar dbMVar (WithHieDbShield withHieDb',hieChan',sq)
233234
forever $ do
234235
msg <- readChan clientMsgChan
235236
-- We dispatch notifications synchronously and requests asynchronously
@@ -239,8 +240,8 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa
239240
ReactorRequest _id act k -> void $ async $ checkCancelled _id act k
240241
logWith recorder Info LogReactorThreadStopped
241242

242-
(WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar
243-
ide <- getIdeState env root withHieDb hieChan
243+
(WithHieDbShield withHieDb,hieChan,sq) <- takeMVar dbMVar
244+
ide <- getIdeState env root withHieDb hieChan sq
244245
registerIdeConfiguration (shakeExtras ide) initConfig
245246
pure $ Right (env,ide)
246247

‎ghcide/src/Development/IDE/Main.hs‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ import Development.IDE.Core.RuleTypes (GenerateCore (Generat
5252
GetHieAst (GetHieAst),
5353
TypeCheck (TypeCheck))
5454
import Development.IDE.Core.Service (initialise,
55-
runAction)
55+
runAction, ShakeOpQueue, runWithShake)
5656
import qualified Development.IDE.Core.Service as Service
5757
import Development.IDE.Core.Shake (IdeState (shakeExtras),
5858
IndexQueue,
@@ -309,8 +309,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
309309
logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)
310310

311311
ideStateVar <- newEmptyMVar
312-
let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState
313-
getIdeState env rootPath withHieDb hieChan = do
312+
let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> ShakeOpQueue -> IO IdeState
313+
getIdeState env rootPath withHieDb hieChan sq = do
314314
traverse_ IO.setCurrentDirectory rootPath
315315
t <- ioT
316316
logWith recorder Info $ LogLspStartDuration t
@@ -349,6 +349,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
349349
ideOptions
350350
withHieDb
351351
hieChan
352+
sq
352353
monitoring
353354
putMVar ideStateVar ide
354355
pure ide
@@ -373,7 +374,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
373374
Check argFiles -> do
374375
dir <- maybe IO.getCurrentDirectory return argsProjectRoot
375376
dbLoc <- getHieDbLoc dir
376-
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
377+
runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
377378
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
378379
hSetEncoding stdout utf8
379380
hSetEncoding stderr utf8
@@ -401,7 +402,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
401402
, optCheckProject = pure False
402403
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
403404
}
404-
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty
405+
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan sq mempty
405406
shakeSessionInit (cmapWithPrio LogShake recorder) ide
406407
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
407408

@@ -431,15 +432,15 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
431432
Custom (IdeCommand c) -> do
432433
root <- maybe IO.getCurrentDirectory return argsProjectRoot
433434
dbLoc <- getHieDbLoc root
434-
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
435+
runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
435436
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."
436437
let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
437438
ideOptions = def_options
438439
{ optCheckParents = pure NeverCheck
439440
, optCheckProject = pure False
440441
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
441442
}
442-
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty
443+
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan sq mempty
443444
shakeSessionInit (cmapWithPrio LogShake recorder) ide
444445
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
445446
c ide

0 commit comments

Comments
 (0)