From f05c1ca6a948c153bd0eece7d8d89c6b7b090dcd Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Thu, 16 May 2024 14:02:32 +0200
Subject: [PATCH] use thread-safe loggers
---
compiler/GHC/Driver/Make.hs | 115 +++++++++++++++++++++---------------
1 file changed, 66 insertions(+), 49 deletions(-)
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 30acc2aee44b..84a37dada96a 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
-- -----------------------------------------------------------------------------
--
@@ -110,6 +111,7 @@ import GHC.Unit.Module.ModDetails
import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Data.Traversable (for)
import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
import qualified GHC.Conc as CC
@@ -1566,7 +1568,9 @@ downsweep :: WorkerLimit
-- which case there can be repeats
downsweep n_jobs hsc_env old_summaries excl_mods allow_dup_roots
= do
- (root_errs, rootSummariesOk) <- rootSummariesPar n_jobs hsc_env getRootSummary roots
+ (root_errs, rootSummariesOk) <-
+ rootSummariesParallel n_jobs hsc_env
+ (getRootSummary excl_mods old_summary_map) roots
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
(deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)
@@ -1616,37 +1620,6 @@ downsweep n_jobs hsc_env old_summaries excl_mods allow_dup_roots
old_summary_map :: M.Map (UnitId, FilePath) ModSummary
old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]
- getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
- getRootSummary Target { targetId = TargetFile file mb_phase
- , targetContents = maybe_buf
- , targetUnitId = uid
- }
- = do let offset_file = augmentByWorkingDirectory dflags file
- exists <- liftIO $ doesFileExist offset_file
- if exists || isJust maybe_buf
- then first (uid,) <$>
- summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
- maybe_buf
- else return $ Left $ (uid,) $ singleMessage
- $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
- where
- dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
- home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
- getRootSummary Target { targetId = TargetModule modl
- , targetContents = maybe_buf
- , targetUnitId = uid
- }
- = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
- (L rootLoc modl) (ThisPkg (homeUnitId home_unit))
- maybe_buf excl_mods
- case maybe_summary of
- FoundHome s -> return (Right s)
- FoundHomeWithError err -> return (Left err)
- _ -> return $ Left $ (uid, moduleNotFoundErr modl)
- where
- home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
- rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
-
-- In a root module, the filename is allowed to diverge from the module
-- name, so we have to check that there aren't multiple root files
-- defining the same module (otherwise the duplicates will be silently
@@ -1738,40 +1711,84 @@ downsweep n_jobs hsc_env old_summaries excl_mods allow_dup_roots
GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
wanted_mod = L loc mod
+getRootSummary ::
+ [ModuleName] ->
+ M.Map (UnitId, FilePath) ModSummary ->
+ HscEnv ->
+ Target ->
+ IO (Either (UnitId, DriverMessages) ModSummary)
+getRootSummary excl_mods old_summary_map hsc_env target
+ | TargetFile file mb_phase <- targetId
+ = do
+ let offset_file = augmentByWorkingDirectory dflags file
+ exists <- liftIO $ doesFileExist offset_file
+ if exists || isJust maybe_buf
+ then first (uid,) <$>
+ summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
+ maybe_buf
+ else
+ return $ Left $ (uid,) $ singleMessage $
+ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
+ | TargetModule modl <- targetId
+ = do
+ maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
+ (L rootLoc modl) (ThisPkg (homeUnitId home_unit))
+ maybe_buf excl_mods
+ pure case maybe_summary of
+ FoundHome s -> Right s
+ FoundHomeWithError err -> Left err
+ _ -> Left (uid, moduleNotFoundErr modl)
+ where
+ Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target
+ home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
+ rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
+ dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
+
-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline
-- system.
--- Create 'MakeAction's for each 'Target' that uses 'withAbstractSem' to wait
--- for a free slot, limiting the number of concurrently computed summaries to
--- the value of the @-j@ option or the slots allocated by the job server, if
--- that is used.
+-- Create bundles of 'MakeAction's for each 'Target' that uses 'withAbstractSem'
+-- to wait for a free slot, limiting the number of concurrently computed
+-- summaries to the value of the @-j@ option or the slots allocated by the job
+-- server, if that is used.
+--
+-- The bundle size for @n@ targets on a machine with @c@ capabilites (threads)
+-- is computed as @n / (2 c)@.
+-- This is a best guess based on benchmarking some synthetic sets of modules
+-- with @ghc -M@.
+-- If you can come up with a more rigorously determined optimum, feel free to
+-- change it!
--
-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because
-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the
-- result won't be read anyway here.
-rootSummariesPar ::
+rootSummariesParallel ::
WorkerLimit ->
HscEnv ->
- (Target -> IO (Either (UnitId, DriverMessages) ModSummary)) ->
+ (HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)) ->
[Target] ->
IO ([(UnitId, DriverMessages)], [ModSummary])
-rootSummariesPar n_jobs hsc_env getRootSummary targets = do
+rootSummariesParallel n_jobs hsc_env getRootSummary targets = do
n_cap <- getNumCapabilities
let bundle_size = max 1 (length targets `div` (n_cap * 2))
- (actions, results) <- unzip <$> mapM mk_action (bundles bundle_size targets)
- runPipelines n_jobs hsc_env mkUnknownDiagnostic (Just (mkBatchMsg hsc_env)) actions
- partitionEithers . concat . catMaybes <$> sequence results
+ bundles = mk_bundles bundle_size targets
+ (actions, results) <- unzip <$> mapM action_and_result (zip [1..] bundles)
+ runPipelines n_jobs hsc_env mkUnknownDiagnostic messager actions
+ partitionEithers . concat . catMaybes <$!> sequence results
where
- bundles sz = unfoldr $ \case
+ mk_bundles sz = unfoldr \case
[] -> Nothing
ts -> Just (splitAt sz ts)
- mk_action ts = do
+ action_and_result (log_queue_id, ts) = do
res_var <- liftIO newEmptyMVar
- let
- action = do
- MakeEnv {compile_sem} <- ask
- lift $ lift $ withAbstractSem compile_sem (mapM getRootSummary ts)
- pure (MakeAction action res_var, readMVar res_var)
+ pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)
+
+ action log_queue_id ts = do
+ env@MakeEnv {compile_sem} <- ask
+ lift $ lift $ withAbstractSem compile_sem do
+ withLoggerHsc log_queue_id env (for ts . getRootSummary)
+
+ messager = Just (mkBatchMsg hsc_env)
-- | This function checks then important property that if both p and q are home units
-- then any dependency of p, which transitively depends on q is also a home unit.
--
GitLab