summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2021-10-20 09:54:23 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-10-22 19:21:56 -0400
commit621608c990d01dd35cb2c4fb8fc49089bef81d57 (patch)
tree790d18ffcef6b6a91638cbfcd1707eb5e4292d5a
parent47ba842b1753b2870c720fb2297371731d444c35 (diff)
downloadhaskell-621608c990d01dd35cb2c4fb8fc49089bef81d57.tar.gz
driver: Don't use the log queue abstraction when j = 1
This simplifies the code path for -j1 by not using the log queue queue abstraction. The result is that trace output isn't interleaved with other dump output like it can be with -j<N>.
-rw-r--r--compiler/GHC/Driver/Make.hs67
1 files changed, 44 insertions, 23 deletions
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 2f88539421..efaf68aeaf 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -928,7 +928,11 @@ withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
-- | Environment used when compiling a module
data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module
, compile_sem :: !AbstractSem
- , lqq_var :: !(TVar LogQueueQueue)
+ -- Modify the environment for module k, with the supplied logger modification function.
+ -- For -j1, this wrapper doesn't do anything
+ -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output
+ -- into the log queue.
+ , withLogger :: forall a . Int -> ((Logger -> Logger) -> RunMakeM a) -> RunMakeM a
, env_messager :: !(Maybe Messager)
}
@@ -2226,9 +2230,8 @@ wrapAction hsc_env k = do
_ -> errorMsg lcl_logger (text (show exc))
return Nothing
-withParLog :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a
-withParLog k cont = do
- MakeEnv{lqq_var, hsc_env} <- ask
+withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> RunMakeM b) -> RunMakeM b
+withParLog lqq_var k cont = do
let init_log = liftIO $ do
-- Make a new log queue
lq <- newLogQueue k
@@ -2236,9 +2239,13 @@ withParLog k cont = do
atomically $ initLogQueue lqq_var lq
return lq
finish_log lq = liftIO (finishLogQueue lq)
- MC.bracket init_log finish_log $ \lq -> do
- -- Modify the logger to use the log queue
- let lcl_logger = pushLogHook (const (parLogAction lq)) (hsc_logger hsc_env)
+ MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))
+
+withLoggerHsc :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a
+withLoggerHsc k cont = do
+ MakeEnv{withLogger, hsc_env} <- ask
+ withLogger k $ \modifyLogger -> do
+ let lcl_logger = modifyLogger (hsc_logger hsc_env)
hsc_env' = hsc_env { hsc_logger = lcl_logger }
-- Run continuation with modified logger
cont hsc_env'
@@ -2251,7 +2258,7 @@ executeInstantiationNode :: Int
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode k n wait_deps iu = do
- withParLog k $ \hsc_env -> do
+ withLoggerHsc k $ \hsc_env -> do
-- Wait for the dependencies of this node
deps <- wait_deps
-- Output of the logger is mediated by a central worker to
@@ -2282,7 +2289,7 @@ executeCompileNode k n !old_hmi wait_deps mknot_var mod = do
_ -> return emptyModuleEnv
knot_var <- liftIO $ maybe mk_mod return mknot_var
deps <- wait_deps
- withParLog k $ \hsc_env -> do
+ withLoggerHsc k $ \hsc_env -> do
let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas
lcl_dynflags = ms_hspp_opts mod
let lcl_hsc_env =
@@ -2358,15 +2365,34 @@ label_self thread_name = do
self_tid <- CC.myThreadId
CC.labelThread self_tid thread_name
+
+runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
+runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do
+ liftIO $ label_self "main --make thread"
+
+ plugins_hsc_env <- initializePlugins orig_hsc_env Nothing
+ case n_job of
+ 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines
+ _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines
+
+runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
+runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =
+ let env = MakeEnv { hsc_env = plugin_hsc_env
+ , withLogger = \_ k -> k id
+ , compile_sem = AbstractSem (return ()) (return ())
+ , env_messager = mHscMessager
+ }
+ in runAllPipelines 1 env all_pipelines
+
+
-- | Build and run a pipeline
-runPipelines :: Int -- ^ How many capabilities to use
+runParPipelines :: Int -- ^ How many capabilities to use
-> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module
-> Maybe Messager -- ^ Optional custom messager to use to report progress
-> [MakeAction] -- ^ The build plan for all the module nodes
-> IO ()
-runPipelines n_jobs orig_hsc_env mHscMessager all_pipelines = do
+runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do
- liftIO $ label_self "main --make thread"
-- A variable which we write to when an error has happened and we have to tell the
-- logging thread to gracefully shut down.
@@ -2375,13 +2401,12 @@ runPipelines n_jobs orig_hsc_env mHscMessager all_pipelines = do
-- will add it's LogQueue into this queue.
log_queue_queue_var <- newTVarIO newLogQueueQueue
-- Thread which coordinates the printing of logs
- wait_log_thread <- logThread (hsc_logger orig_hsc_env) stopped_var log_queue_queue_var
+ wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var
- plugins_hsc_env <- initializePlugins orig_hsc_env Nothing
-- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.
- thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger orig_hsc_env)
- let thread_safe_hsc_env = plugins_hsc_env { hsc_logger = thread_safe_logger }
+ thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
+ let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
let updNumCapabilities = liftIO $ do
n_capabilities <- getNumCapabilities
@@ -2398,15 +2423,11 @@ runPipelines n_jobs orig_hsc_env mHscMessager all_pipelines = do
atomically $ writeTVar stopped_var True
wait_log_thread
- abstract_sem <-
- case n_jobs of
- 1 -> return $ AbstractSem (return ()) (return ())
- _ -> do
- compile_sem <- newQSem n_jobs
- return $ AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)
+ compile_sem <- newQSem n_jobs
+ let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)
-- Reset the number of capabilities once the upsweep ends.
let env = MakeEnv { hsc_env = thread_safe_hsc_env
- , lqq_var = log_queue_queue_var
+ , withLogger = withParLog log_queue_queue_var
, compile_sem = abstract_sem
, env_messager = mHscMessager
}