Skip to content

Commit 5978cad

Browse files
crtschincrtschin
committed
Move withRestartWorker to the other worker functions
1 parent 1882610 commit 5978cad

3 files changed

Lines changed: 46 additions & 37 deletions

File tree

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

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -882,15 +882,17 @@ shakeRestart IdeState{..} vfs reason acts ioActionBetweenShakeSession = do
882882
-- | Run a worker that asynchronously processes shake restart requests. Will
883883
-- only ever queue upto 1 additional restart, accumulating data while processing
884884
-- any restart.
885-
withRestartWorker :: IdeState -> IO r -> IO r
886-
withRestartWorker ide@IdeState{..} action =
887-
withAsync (forever $
888-
processPendingRestart (shakeRecorder shakeExtras) ide
885+
withRestartWorker :: MVar IdeState -> IO r -> IO r
886+
withRestartWorker ideMVar action = do
887+
let restartWorkerAction = do
888+
ide@IdeState{..} <- readMVar ideMVar
889+
forever (processPendingRestart (shakeRecorder shakeExtras) ide)
889890
`catch` \(e :: SomeException) ->
890891
case fromException e of
891-
Just AsyncCancelled -> throwIO e
892-
_ -> logWith (shakeRecorder shakeExtras) Error (LogRestartWorkerException e)) $
893-
\_ -> action
892+
Just AsyncCancelled -> throwIO e
893+
_ -> logWith (shakeRecorder shakeExtras) Error (LogRestartWorkerException e)
894+
895+
withAsync restartWorkerAction $ \_ -> action
894896

895897
processPendingRestart :: Recorder (WithPriority Log) -> IdeState -> IO ()
896898
processPendingRestart recorder IdeState{..} = do
@@ -918,7 +920,6 @@ processPendingRestart recorder IdeState{..} = do
918920
(,()) <$> newSession recorder shakeExtras pendingRestartVFS shakeDb
919921
(reverse pendingRestartActions)
920922
(reverse pendingRestartReasons)
921-
pure ()
922923
where
923924
logErrorAfter :: Seconds -> IO () -> IO ()
924925
logErrorAfter seconds action = flip withAsync (const action) $ do

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

Lines changed: 11 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -373,12 +373,12 @@ handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "In
373373
void $ atomically (traverse readTMVar currentNotifications)
374374
checkCancelled _id act k
375375

376-
runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc shutdownSession $ \withHieDb' threadQueue' -> do
376+
runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc shutdownSession ideMVar $ \withHieDb' threadQueue' -> do
377377
ide <- ctxGetIdeState lifecycleCtx env root withHieDb' threadQueue'
378378
registerIdeConfiguration (shakeExtras ide) initConfig
379379
putMVar ideMVar ide
380380

381-
withRestartWorker ide $ untilReactorStopSignal $ forever (consumeChannel threadQueue')
381+
untilReactorStopSignal $ forever (consumeChannel threadQueue')
382382
logWith recorder Info LogReactorThreadStopped
383383

384384
ide <- readMVar ideMVar
@@ -388,15 +388,22 @@ handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "In
388388
-- | runWithWorkerThreads
389389
-- create several threads to run the session, db and session loader
390390
-- see Note [Serializing runs in separate thread]
391-
runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> IO () -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
392-
runWithWorkerThreads recorder dbLoc shutdownSession f = evalContT $ do
391+
runWithWorkerThreads
392+
:: Recorder (WithPriority Session.Log)
393+
-> FilePath
394+
-> IO ()
395+
-> MVar IdeState
396+
-> (WithHieDb -> ThreadQueue -> IO ())
397+
-> IO ()
398+
runWithWorkerThreads recorder dbLoc shutdownSession ideMVar f = evalContT $ do
393399
(WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc
394400
-- The shake session needs to be shut down prior to the hiedb connections
395401
-- being cleaned up, otherwise shake could be referencing dead connections.
396402
-- This is passed in via the callsites.
397403
ContT $ \action -> action () `finally` shutdownSession
398404
sessionRestartTQueue <- liftIO $ newRestartSlot
399405
sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue"
406+
ContT $ \action -> withRestartWorker ideMVar $ action ()
400407
liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)
401408

402409
-- | Runs the action until it ends or until the given MVar is put.

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

Lines changed: 26 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -53,8 +53,7 @@ import qualified Development.IDE.Core.Service as Service
5353
import Development.IDE.Core.Shake (IdeState (shakeExtras),
5454
ThreadQueue (tLoaderQueue),
5555
shakeSessionInit,
56-
uses,
57-
withRestartWorker)
56+
uses)
5857
import qualified Development.IDE.Core.Shake as Shake
5958
import Development.IDE.Graph (action)
6059
import Development.IDE.LSP.LanguageServer (runLanguageServer,
@@ -379,7 +378,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
379378
Check argFiles -> do
380379
let dir = argsProjectRoot
381380
dbLoc <- getHieDbLoc dir
382-
runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do
381+
ideMVar <- newEmptyMVar
382+
runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty ideMVar $ \hiedb threadQueue -> do
383383
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
384384
hSetEncoding stdout utf8
385385
hSetEncoding stderr utf8
@@ -408,23 +408,23 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
408408
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
409409
}
410410
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty dir
411-
withRestartWorker ide $ do
412-
shakeSessionInit (cmapWithPrio LogShake recorder) ide
413-
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
414-
415-
putStrLn "\nStep 4/4: Type checking the files"
416-
setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') absoluteFiles
417-
results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' absoluteFiles)
418-
_results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' absoluteFiles)
419-
_results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' absoluteFiles)
420-
let (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles
421-
when (failed /= []) $
422-
putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
423-
424-
let nfiles xs = let n' = length xs in if n' == 1 then "1 file" else show n' ++ " files"
425-
putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"
426-
427-
unless (null failed) (exitWith $ ExitFailure (length failed))
411+
putMVar ideMVar ide
412+
shakeSessionInit (cmapWithPrio LogShake recorder) ide
413+
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
414+
415+
putStrLn "\nStep 4/4: Type checking the files"
416+
setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') absoluteFiles
417+
results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' absoluteFiles)
418+
_results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' absoluteFiles)
419+
_results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' absoluteFiles)
420+
let (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles
421+
when (failed /= []) $
422+
putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
423+
424+
let nfiles xs = let n' = length xs in if n' == 1 then "1 file" else show n' ++ " files"
425+
putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"
426+
427+
unless (null failed) (exitWith $ ExitFailure (length failed))
428428
Db opts cmd -> do
429429
let root = argsProjectRoot
430430
dbLoc <- getHieDbLoc root
@@ -438,7 +438,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
438438
Custom (IdeCommand c) -> do
439439
let root = argsProjectRoot
440440
dbLoc <- getHieDbLoc root
441-
runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do
441+
ideMVar <- newEmptyMVar
442+
runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty ideMVar $ \hiedb threadQueue -> do
442443
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue)
443444
let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
444445
ideOptions = def_options
@@ -447,10 +448,10 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
447448
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
448449
}
449450
ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty root
450-
withRestartWorker ide $ do
451-
shakeSessionInit (cmapWithPrio LogShake recorder) ide
452-
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
453-
c ide
451+
putMVar ideMVar ide
452+
shakeSessionInit (cmapWithPrio LogShake recorder) ide
453+
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
454+
c ide
454455

455456
-- | List the haskell files given some paths
456457
--

0 commit comments

Comments
 (0)