Rodrigo Mesquita pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: 9d247a48 by Rodrigo Mesquita at 2026-08-14T16:12:49+01:00 Refactor GHC.Driver.Downsweep in preparation for parallel downsweep Pure refactor to improve the code to facilitate implementing parallel downsweep in the next commit. This commit puts a MakeEnv into the DownsweepEnv, gives the fields proper names and uses RecordWildcards to simplify, rather than passing around all diagnostic wrappers, driver-message-things and using 10s of positional fields. No behavior changes here! - - - - - 8d5b8c69 by Rodrigo Mesquita at 2026-08-14T16:15:18+01:00 Parallelize downsweep traversal Parallelize the downsweep pass s.t. processing and discovering the module graph can be done in parallel (parallelizing work like pre-processing CPP in modules) according to the -j<N> flag used. Using Cabal as an example with -j8, parallel downsweep was 2x faster (from 2s to 1s in downsweep time). The parallel downsweep is all implemented in the previous `dfsBuild` (now named `parDfsBuild`): - We launch a thread for every module we discover that needs to be expanded next, in the `coordinator` thread - Every launched worker thread blocks waiting for a semaphore token (`withAbstractSem`), to respect -j<N> - The main thread waits until both the worklist and pending list is cleared. STM is used crucially to guarantee e.g. we don't have race conditions between taking from the worklist and writing to the pending list while checking whether they are clear. Exceptions are bubbled up to the main thread, which is unblocked and re-throws the exception signaled in `exc_var`, mimicking the previous behavior of `dfsBuild`. See also Note [Parallel Downsweep] Fixes #27514 - - - - - d09148c1 by Rodrigo Mesquita at 2026-08-14T16:17:03+01:00 fixup: kill coordinator thread with MC.finally - - - - - 6ef52d70 by Rodrigo Mesquita at 2026-08-14T16:17:17+01:00 fixup: keep track of worker threads - - - - - dec07585 by Rodrigo Mesquita at 2026-08-14T16:17:17+01:00 fixup: move withLocalTmpFS inside on downsweep opened #27690 about the bug in runLoop - - - - - 8 changed files: - + changelog.d/parallel-downsweep - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/MakeAction.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/splice-imports/SI35.hs - utils/check-ppr/Main.hs Changes: ===================================== changelog.d/parallel-downsweep ===================================== @@ -0,0 +1,11 @@ +section: compiler +synopsis: Parallelize the downsweep/module-discovery pass +issues: #27514 +mrs: !16394 +description: { + Parallelize the downsweep pass s.t. processing and discovering the module + graph can be done in parallel (parallelizing work like pre-processing CPP + in modules) according to the -j<N> flag used. Using Cabal as an example + with -j8, parallel downsweep was 2x faster (from 2s to 1s in downsweep time). +} + ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -14,6 +14,8 @@ module GHC.Driver.Downsweep , downsweepFromRootNodes , downsweepInteractiveImports , DownsweepMode(..) + , DownsweepM, DownsweepEnv(..) + , runDownsweepM -- * Summary functions , summariseModule , summariseFile @@ -62,7 +64,7 @@ import GHC.Data.OsPath ( OsPath, unsafeEncodeUtf ) import GHC.Data.StringBuffer import GHC.Data.Graph.Directed.Reachability -import GHC.Utils.Exception ( throwIO, SomeAsyncException ) +import GHC.Utils.Exception ( throwIO, SomeAsyncException, AsyncException (..) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc @@ -112,8 +114,11 @@ import Control.Monad.Trans.Reader import qualified Data.Map.Strict as M import Control.Monad.Trans.Class import System.IO.Unsafe (unsafeInterleaveIO) -import Data.IORef import qualified Data.List.NonEmpty as NE +import Control.Concurrent +import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM +import Control.Applicative {- Note [The ModuleGraph] @@ -176,8 +181,9 @@ incrementally constructing a ModuleGraph using the GHC API; See #27054). So `downsweep` takes a `Maybe ModuleGraph` as one of its arguments. Downsweep iteratively *expands* each so-called 'DownsweepNode' into a list of -its dependencies, and recursively traverses all reachable nodes in a -depth-first order using 'dfsBuild'. A 'DownsweepNode' is *expanded* by 'dsNodeExpand': +its dependencies, and recursively traverses all reachable nodes in a parallel +non-det-depth-first order using 'parDfsBuild'. A 'DownsweepNode' is *expanded* +by 'dsNodeExpand': dsNodeExpand :: DownsweepNode -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode])) @@ -256,38 +262,48 @@ downsweep :: HscEnv -- which case there can be repeats downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) - summ_cache <- newIORef (mkModSummaryCache (zip old_summaries (repeat SummOld))) - imps_cache <- newIORef Map.empty - (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg - (getRootSummary excl_mods summ_cache imps_cache) - let closure_errs = checkHomeUnitsClosed unit_env - unit_env = hsc_unit_env hsc_env - - all_errs = closure_errs ++ root_errs - - case all_errs of - [] -> do - (downsweep_errs, downsweep_nodes) <- - downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph - excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] - - let (other_errs, unit_nodes) = partitionEithers $ - HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] - (hsc_HUG hsc_env) - - let all_nodes = downsweep_nodes ++ unit_nodes - let all_errs = downsweep_errs ++ other_errs - - let logger = hsc_logger hsc_env - tmpfs = hsc_tmpfs hsc_env - -- if we have been passed -fno-code, we enable code generation - -- for dependencies of modules that have -XTemplateHaskell, - -- otherwise those modules will fail to compile. - -- See Note [-fno-code mode] #8025 - th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes - - return (all_errs, th_configured_nodes) - _ -> return (all_errs, emptyMG) + summ_cache <- newMVar (mkModSummaryCache (zip old_summaries (repeat SummOld))) + imps_cache <- newMVar Map.empty + withMakeEnv n_jobs hsc_env diag_wrapper msg $ \make_env -> do + (root_errs, root_summaries) <- rootSummariesParallel n_jobs make_env (hsc_targets hsc_env) + (getRootSummary excl_mods summ_cache imps_cache) + let closure_errs = checkHomeUnitsClosed unit_env + unit_env = hsc_unit_env hsc_env + + all_errs = closure_errs ++ root_errs + + case all_errs of + [] -> do + let env = DownsweepEnv + { ds_hsc_env = hsc_env + , ds_summaries_cache = summ_cache + , ds_imports_cache = imps_cache + , ds_mode = DownsweepUseCompile + , ds_excl_mods = excl_mods + , ds_n_jobs = n_jobs + , ds_make_env = make_env + } + (downsweep_errs, downsweep_nodes) <- runDownsweepM env $ + downsweepFromRootNodes maybe_base_graph allow_dup_roots + (map ModuleNodeCompile root_summaries) [] + + let (other_errs, unit_nodes) = partitionEithers $ + HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] + (hsc_HUG hsc_env) + + let all_nodes = downsweep_nodes ++ unit_nodes + let all_errs = downsweep_errs ++ other_errs + + let logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + -- if we have been passed -fno-code, we enable code generation + -- for dependencies of modules that have -XTemplateHaskell, + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes + + return (all_errs, th_configured_nodes) + _ -> return (all_errs, emptyMG) where -- Dependencies arising on a unit (backpack and module linking deps) unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] @@ -330,15 +346,28 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." - summs <- newIORef (mkModSummaryCache [(mod_summary,SummOld)]) - imps <- newIORef mempty - ~(errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] - let dflags = hsc_dflags hsc_env - liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) - (initPrintConfig dflags) - (initDiagOpts dflags) - (GhcDriverMessage <$> unionManyMessages errs) - return (mkModuleGraph mg) + njobs <- mkWorkerLimit (hsc_dflags hsc_env) + summs <- newMVar (mkModSummaryCache [(mod_summary,SummOld)]) + imps <- newMVar mempty + withMakeEnv njobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do + let env = DownsweepEnv + { ds_hsc_env = hsc_env + , ds_summaries_cache = summs + , ds_imports_cache = imps + , ds_mode = DownsweepUseFixed + , ds_excl_mods = [] + , ds_n_jobs = njobs + , ds_make_env = make_env + } + ~(errs, mg) <- runDownsweepM env $ + downsweepFromRootNodes Nothing True + [ModuleNodeCompile mod_summary] [] + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + return (mkModuleGraph mg) -- | Construct a module graph starting from the interactive context. -- Produces, a thunk, which when forced will perform the downsweep. @@ -362,13 +391,23 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do -- :load. Any home package modules need to already be in here. let cached_nodes = Map.fromList [ (mkNodeKey n, NSuccess n) | n <- mg_mss (hsc_mod_graph hsc_env) ] - summ_cache <- newIORef mempty - imps_cache <- newIORef mempty - let env = DownsweepEnv hsc_env DownsweepUseFixed{-or DownsweepUseCompile?-} summ_cache imps_cache [] - graph <- runDownsweepM env do - loopFromInteractive cached_nodes interactive_mn imps - let all_nodes = [s | NSuccess s <- M.elems graph ] - return $ mkModuleGraph all_nodes + n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) + summ_cache <- newMVar mempty + imps_cache <- newMVar mempty + withMakeEnv n_jobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do + let env = DownsweepEnv + { ds_hsc_env = hsc_env + , ds_mode = DownsweepUseFixed{-or DownsweepUseCompile?-} + , ds_summaries_cache = summ_cache + , ds_imports_cache = imps_cache + , ds_excl_mods = [] + , ds_n_jobs = n_jobs + , ds_make_env = make_env + } + graph <- runDownsweepM env do + loopFromInteractive cached_nodes interactive_mn imps + let all_nodes = [s | NSuccess s <- M.elems graph ] + return $ mkModuleGraph all_nodes -- | Create a module graph from a list of installed modules. -- This is used by the loader when we need to load modules but there @@ -396,26 +435,38 @@ downsweepInstalledModules hsc_env mods = do -- already know that we can find the modules we need to load. _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i + njobs <- mkWorkerLimit (hsc_dflags hsc_env) nodes <- mapM process installed_mods - summs <- newIORef mempty - imps <- newIORef mempty - (errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed nodes external_uids + summs <- newMVar mempty + imps <- newMVar mempty + withMakeEnv njobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do + let env = DownsweepEnv + { ds_hsc_env = hsc_env + , ds_summaries_cache = summs + , ds_imports_cache = imps + , ds_mode = DownsweepUseFixed + , ds_excl_mods = [] + , ds_n_jobs = njobs + , ds_make_env = make_env + } + (errs, mg) <- runDownsweepM env $ + downsweepFromRootNodes Nothing True nodes external_uids - -- Similarly here, we should really not get any errors, but print them out if we do. - let dflags = hsc_dflags hsc_env - liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) - (initPrintConfig dflags) - (initDiagOpts dflags) - (GhcDriverMessage <$> unionManyMessages errs) + -- Similarly here, we should really not get any errors, but print them out if we do. + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) - return (mkModuleGraph mg) + return (mkModuleGraph mg) ----------------------------------------------------------------------------- -- * Orchestrator: downsweepFromRootNodes ----------------------------------------------------------------------------- -type ModSummaryCache = IORef ModSummaryCacheMap -type ImportsCache = IORef ImportsCacheMap +type ModSummaryCache = MVar ModSummaryCacheMap +type ImportsCache = MVar ImportsCacheMap -- | A cache from file paths to the already summarised modules. The same file -- can be used in multiple units so the map is actually also keyed by which @@ -450,30 +501,26 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed -- 'UnitId's. -- This function will start at the given roots, and traverse downwards to find -- all the dependencies, all the way to the leaf units. -downsweepFromRootNodes :: HscEnv - -> ModSummaryCache - -> ImportsCache - -> Maybe ModuleGraph - -> [ModuleName] - -> Bool - -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies - -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo - -> [UnitId] -- ^ The starting units - -> IO ([DriverMessages], [ModuleGraphNode]) -downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids = do +downsweepFromRootNodes + :: Maybe ModuleGraph + -> Bool + -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo + -> [UnitId] -- ^ The starting units + -> DownsweepM ([DriverMessages], [ModuleGraphNode]) +downsweepFromRootNodes maybe_base_graph allow_dup_roots root_nodes root_uids = + ReaderT $ \env@DownsweepEnv{..} -> do when (not allow_dup_roots) $ case root_duplicates of [] -> return () - (dup_root:_) -> multiRootsErr sec dup_root - modifyImpsCache imps_cache (`M.union` mkRootMap root_nodes) -- add root nodes to imports cache - let env = DownsweepEnv hsc_env mode summ_cache imps_cache excl_mods - deps' <- runDownsweepM env $ do + (dup_root:_) -> multiRootsErr (sec ds_hsc_env) dup_root + modifyImpsCache ds_imports_cache (`M.union` mkRootMap root_nodes) -- add root nodes to imports cache + deps' <- runDownsweepM env $ do let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph module_deps <- loopModuleNodeInfos base_nodes root_nodes - all_deps <- loopUnits module_deps (hscActiveUnitId hsc_env) root_uids - deps' <- loopInstantiations all_deps (getHomeUnitInstantiations hsc_env) + all_deps <- loopUnits module_deps (hscActiveUnitId ds_hsc_env) root_uids + deps' <- loopInstantiations all_deps (getHomeUnitInstantiations ds_hsc_env) return deps' - f_cache <- readIORef summ_cache + f_cache <- readMVar ds_summaries_cache let downsweep_errs = lefts (M.elems f_cache) downsweep_nodes = [ s | NSuccess s <- M.elems deps' ] @@ -501,7 +548,7 @@ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods moduleGraphNodeMap graph = M.fromList [(mkNodeKey node, NSuccess node) | node <- mgModSummaries' graph] - sec = initSourceErrorContext (hsc_dflags hsc_env) + sec hsc_env = initSourceErrorContext (hsc_dflags hsc_env) -------------------------------------------------------------------------------- -- ** 'DownsweepM' @@ -509,11 +556,14 @@ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods type DownsweepM a = ReaderT DownsweepEnv IO a data DownsweepEnv = DownsweepEnv { - downsweep_hsc_env :: HscEnv - , _downsweep_mode :: DownsweepMode - , _downsweep_summaries_cache :: ModSummaryCache - , downsweep_imports_cache :: ImportsCache - , _downsweep_excl_mods :: [ModuleName] + ds_hsc_env :: HscEnv + , ds_mode :: DownsweepMode + -- ^ Whether to create fixed or compile nodes for dependencies + , ds_summaries_cache :: ModSummaryCache + , ds_imports_cache :: ImportsCache + , ds_excl_mods :: [ModuleName] + , ds_n_jobs :: WorkerLimit + , ds_make_env :: MakeEnv } mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap @@ -529,8 +579,8 @@ addModSummaryCache ms pr fe = upd_fe fe modifySummCache :: ModSummaryCache -> (ModSummaryCacheMap -> ModSummaryCacheMap) -> IO () modifyImpsCache :: ImportsCache -> (ImportsCacheMap -> ImportsCacheMap) -> IO () -modifySummCache r f = atomicModifyIORef' r (\c -> (f c, ())) -modifyImpsCache r f = atomicModifyIORef' r (\c -> (f c, ())) +modifySummCache v f = modifyMVar v (\c -> let !r = f c in pure (r, ())) +modifyImpsCache v f = modifyMVar v (\c -> let !r = f c in pure (r, ())) -- | A cache from a module import (in given home unit context, with a package -- qualifier, and the imported module name (with or without SOURCE)) to the @@ -553,7 +603,7 @@ loopModuleNodeInfos :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [ModuleNodeInf loopUnits :: M.Map NodeKey (NodeRes ModuleGraphNode) -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode)) loopInstantiations :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode)) loopFromInteractive :: M.Map NodeKey (NodeRes ModuleGraphNode) -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode)) -loopDownsweepNodes base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand +loopDownsweepNodes base_map nodes = parDfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand loopModuleNodeInfos base_map = loopDownsweepNodes base_map . map DSMod loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit homud) loopInstantiations base_map = loopDownsweepNodes base_map . map (uncurry DSInst) @@ -617,7 +667,7 @@ dsNodeExpand = \case expandModuleSummary :: ModSummary -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode])) expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that. - hsc_env <- asks downsweep_hsc_env + hsc_env <- asks ds_hsc_env let home_uid = ms_unitid ms home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) (final_deps, todo) <- unzip <$> mapM (expandModImport home_uid home_unit) (calcDeps ms) @@ -652,7 +702,7 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do FoundHomeWithError (_uid, _e) -> return ( Nothing, [] ) -- the error @e@ is already stored in the summarisation cache, - -- (the IORef in DownsweepM) and will get reported at the end. + -- (the MVar in DownsweepM) and will get reported at the end. FoundHome s -> return -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. ( Just $ mkModuleEdge lvl (NodeKey_Module (mnKey s)) @@ -673,7 +723,7 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do -- NB: If you ever reach a Fixed node, everything under that also must be fixed. expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode])) expandFixedModuleNode key loc = do - hsc_env <- asks downsweep_hsc_env + hsc_env <- asks ds_hsc_env -- MP: TODO, we should just read the dependency info from the interface rather than either -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) @@ -732,7 +782,7 @@ expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @n expandUnitNode node_uid home_context_uid = do -- Set active unit so that looking loopUnit finds the correct -- -package flags in the unit state. - hsc_env <- asks downsweep_hsc_env + hsc_env <- asks ds_hsc_env let lcl_hsc_env = hscSetActiveUnitId home_context_uid hsc_env case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) node_uid of Just us -> pure $ NSuccess ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us) @@ -745,8 +795,8 @@ expandInstantiatedUnit iud home_uid = pure $ NSuccess expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode])) expandInteractiveImports imod imps = do - hsc_env <- asks downsweep_hsc_env - imps_cache <- asks downsweep_imports_cache + hsc_env <- asks ds_hsc_env + imps_cache <- asks ds_imports_cache let -- A simple edge to a module from the same home unit @@ -807,13 +857,13 @@ downsweepSummarise :: HomeUnit -> Maybe (StringBuffer, UTCTime) -> DownsweepM SummariseResult downsweepSummarise home_unit imp maybe_buf = do - DownsweepEnv hsc_env mode summaries_cache_ref imports_cache_ref excl_mods <- ask - liftIO $ case mode of + DownsweepEnv{..} <- ask + liftIO $ case ds_mode of DownsweepUseCompile -> - summariseModule hsc_env home_unit summaries_cache_ref imports_cache_ref - imp maybe_buf excl_mods + summariseModule ds_hsc_env home_unit ds_summaries_cache ds_imports_cache + imp maybe_buf ds_excl_mods DownsweepUseFixed -> - summariseModuleInterface hsc_env home_unit imports_cache_ref imp excl_mods + summariseModuleInterface ds_hsc_env home_unit ds_imports_cache imp ds_excl_mods multiRootsErr :: SourceErrorContext -> NE.NonEmpty ModuleNodeInfo -> IO () multiRootsErr sec (summ1 NE.:| summs) @@ -878,56 +928,15 @@ getRootSummary excl_mods summ_cache imports_cache hsc_env target 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 bundles of 'Target's wrapped in a 'MakeAction' 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 '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. --- --- To emulate the current behavior, we funnel exceptions past the concurrency --- barrier and rethrow the first one afterwards. -rootSummariesParallel :: - WorkerLimit -> - HscEnv -> - (GhcMessage -> AnyGhcDiagnostic) -> - Maybe Messager -> - (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) -> - IO ([DriverMessages], [ModSummary]) -rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do - (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles) - runPipelines n_jobs hsc_env diag_wrapper msg actions - (sequence . catMaybes <$> sequence get_results) >>= \case - Right results -> pure (partitionEithers (concat results)) - Left exc -> throwIO exc - where - bundles = mk_bundles targets - - mk_bundles = unfoldr \case - [] -> Nothing - ts -> Just (splitAt bundle_size ts) - - bundle_size = 20 - - targets = hsc_targets hsc_env - - action_and_result (log_queue_id, ts) = do - res_var <- liftIO newEmptyMVar - pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var) - - action log_queue_id target_bundle = do - env@MakeEnv {compile_sem} <- ask - lift $ lift $ - withAbstractSem compile_sem $ - withLoggerHsc log_queue_id env \ lcl_hsc_env -> - MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case - Left e | Just (_ :: SomeAsyncException) <- fromException e -> - throwIO e - a -> pure a +-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline system. +rootSummariesParallel + :: WorkerLimit -> MakeEnv -> [Target] + -> (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) + -> IO ([DriverMessages], [ModSummary]) +rootSummariesParallel n_jobs make_env targets get_summary = do + partitionEithers <$> mapConcDS n_jobs bundle_size make_env get_summary targets + where + bundle_size = 20 -------------------------------------------------------------------------------- -- * Check/validate properties and error out @@ -1325,7 +1334,7 @@ summariseFile -> IO (Either DriverMessages ModSummary) summariseFile hsc_env' home_unit summ_cache_ref src_fn mb_phase maybe_buf - = do file_summ_cache <- readIORef summ_cache_ref + = do file_summ_cache <- readMVar summ_cache_ref case M.lookup (homeUnitId home_unit, src_fn_os) file_summ_cache of Just (Right (chd_summary, SummFresh)) -> -- Fresh: use it straight away @@ -1505,7 +1514,7 @@ summariseModuleDispatch k hsc_env' imps_cache_ref home_unit imp excl_mods find_it :: IO SummariseResult find_it = do - imps_cache <- readIORef imps_cache_ref + imps_cache <- readMVar imps_cache_ref case M.lookup cache_key imps_cache of Just result -> return result Nothing -> do @@ -1547,7 +1556,7 @@ summariseModuleWithSource home_unit summ_cache_ref is_boot maybe_buf hsc_env loc -- Adjust location to point to the hs-boot source file, -- hi file, object file, when is_boot says so let src_fn = expectJust (ml_hs_file location) - summ_cache <- readIORef summ_cache_ref + summ_cache <- readMVar summ_cache_ref -- Reject the cache result if the module name doesn't match the inferred -- module name based on the file name. @@ -1722,10 +1731,10 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do return PreprocessedImports {..} -------------------------------------------------------------------------------- --- * Generic traversal of iteratively-built graph: dfsBuild +-- * Generic traversal of iteratively-built graph: parDfsBuild -------------------------------------------------------------------------------- --- | The result of expanding a node in 'dfsBuild'. +-- | The result of expanding a node in 'parDfsBuild'. data NodeRes v -- | Computed the node payload successfully = NSuccess v @@ -1738,7 +1747,7 @@ data NodeRes v -- abort. | NSkip --- | In a depth-first order, and starting from the given roots, traverse a +-- | In a parallel non-det-depth-first order, and starting from the given roots, traverse a -- graph by iteratively expanding a node into a payload and a list of children -- nodes to visit next. -- @@ -1751,18 +1760,17 @@ data NodeRes v -- The result is a mapping from the key of every node transitively reachable -- from the root nodes (inclusively) to the payload returned by expanding that -- node. The result includes the previously visited nodes given in @base_map@, --- s.t. @dfsBuild base_map [] _ _ == base_map@. +-- s.t. @parDfsBuild base_map [] _ _ == base_map@. -- -- The @expand@ function returns an 'NResult'. See the 'NResult' documentation -- for more information about each result type. -- --- Error handling and exiting early can be achieved by selecting a @Monad m@ --- accordingly, such as @Control.Monad.Except.Except@ --- -- Example usage: @n@ is instanced to @DownsweepNode@, @k@ is @NodeKey@, and @v@ is @ModuleNodeEdge@. -- --- See also Note [Downsweep Control Flow and Caching] -dfsBuild :: (Ord k, Monad m) +-- See Note [Parallel Downsweep] for more information about how parallelism is +-- achieved, and See Note [Downsweep Control Flow and Caching] for information +-- about the various caches used. +parDfsBuild :: forall k v n. Ord k => Maybe (Map.Map k (NodeRes v)) -- ^ Base map, existing results. We won't re-expand any of the nodes -- already present in this map. @@ -1770,34 +1778,102 @@ dfsBuild :: (Ord k, Monad m) -- ^ The root nodes from where to start traversal -> (n -> k) -- ^ Compute the key which uniquely identifies this node - -> (n -> m (NodeRes (v,[n]))) + -> (n -> DownsweepM (NodeRes (v,[n]))) -- ^ Expand this node into its payload result and into the list of -- children nodes to visit next. - -> m (Map.Map k (NodeRes v)) + -> DownsweepM (Map.Map k (NodeRes v)) -- ^ The result accumulates the payload of expanding the root nodes -- and all nodes transitively reachable from those roots. -dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map) +parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do + exc_var <- newTVarIO $ Nothing @MC.SomeException + visited_var <- newTVarIO $ fromMaybe Map.empty base_map + pending <- newTVarIO $ Set.empty @k + worklist <- newTQueueIO @n + threads <- newTVarIO [] + + coord_tid <- forkIO $ + coordinator ds_env exc_var visited_var worklist pending threads + `MC.catch` \case + (e::MC.SomeException) + -- exit cleanly when killed + | Just ThreadKilled <- fromException e -> return () + -- if the coordinator somehow else crashes, + -- signal the exc_var for the main thread to throw it + | otherwise -> atomically (modifyTVar' exc_var (<|> Just e)) + + atomically $ mapM_ (writeTQueue worklist) roots + + mb_exc <- wait_done exc_var worklist pending + `MC.finally` do + killThread coord_tid + mapM_ killThread =<< readTVarIO threads + + case mb_exc of + Just e -> throwIO e + Nothing -> readTVarIO visited_var + where - go [] visited = pure visited - go (s:ss) visited - | k `Map.member` visited - = go ss visited - | otherwise - = do r <- expand s - case r of - NSkip -> - go ss - (Map.insert k NSkip visited) -- Skip! - NSuccess (v,ns) -> - go (ns ++ ss) - (Map.insert k (NSuccess v) visited) - where - k = key s + wait_done exc_var worklist pending = + -- this txn retries until all work is done or an exception is signaled + atomically $ do + readTVar exc_var >>= \case + Just e -> return (Just e) + Nothing -> do + empty_worklist <- isEmptyTQueue worklist + empty_pending <- Set.null <$> readTVar pending + check (empty_worklist && empty_pending) + return Nothing + + coordinator ds_env exc_var visvar worklist pendvar threads = forever $ do + mb_node_to_expand <- atomically $ do + node <- readTQueue worklist + let k = key node + + visited <- readTVar visvar + pending <- readTVar pendvar + + if (k `Set.member` pending || k `Map.member` visited) + then return Nothing + else do + -- must add to pending in the same transaction as worklist dequeue, + -- otherwise the main thread may find both the worklist and pending + -- lists empty and exit prematurely. + modifyTVar' pendvar (Set.insert k) + return (Just (k, node)) + + case mb_node_to_expand of + Nothing -> return () + Just (k, node) -> do + tid <- MC.mask_ $ forkIOWithUnmask $ \unmask -> + unmask (withLocalTmpFSMake (ds_make_env ds_env) $ \make_env -> + worker ds_env{ds_make_env = make_env} visvar worklist pendvar k node) + `MC.catch` \case + e | Just (_ :: SomeAsyncException) <- fromException e + -> throwIO e -- async exceptions like KillThread get thrown + | otherwise -- exceptions in workers are written for main thread + -> atomically (modifyTVar' exc_var (<|> Just e)) + + atomically $ modifyTVar' threads (tid:) + + worker ds_env@DownsweepEnv{..} visvar worklist pendvar k node = + withAbstractSem (compile_sem ds_make_env) $ do + r <- runDownsweepM ds_env $ + expand node -- do the main work! + + atomically $ do + case r of + NSkip -> + modifyTVar' visvar (Map.insert k NSkip) + NSuccess (v,ns) -> do + modifyTVar' visvar (Map.insert k (NSuccess v)) + mapM_ (writeTQueue worklist) ns + + modifyTVar' pendvar (Set.delete k) {- Note [Downsweep Control Flow and Caching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The control flow of downsweep is extracted into a single function `dfsBuild`, +The control flow of downsweep is extracted into a single function `parDfsBuild`, which takes care of iteratively expanding and traversing all nodes of the in-construction module graph necessary to build a full `ModuleGraph` at the end. @@ -1806,7 +1882,7 @@ There are three levels of caching going on, all of which are necessary to make sure we don't do repeated work (notably, we NEVER summarise the same module twice). -1. `dfsBuild` accumulates the final module graph and never revisits the +1. `parDfsBuild` accumulates the final module graph and never revisits the same node of the module graph. Cache is keyed by the final `ModuleGraph`s `NodeKey`s. @@ -1874,6 +1950,83 @@ twice). See tests T27461a and T27461b. -See also Note [Downsweep: building and maintaining the module graph] and -Note [The ModuleGraph]. +See also Note [Downsweep: building and maintaining the module graph] and Note [The ModuleGraph]. + + +Note [Parallel Downsweep] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Downsweep traverses the modules iteratively to discover the module graph +structure (see Note [Downsweep: building and maintaining the module graph]) + +Each module has to be expanded/processed to discover dependencies amongst other +things, and that processing can often be costly (e.g. see `expandModuleSummary`). + +We leverage multiple threads in this traversal to expand more than one module +at once, respecting -j<N> to mean we never expand more than N modules at once. +The parallel downsweep is all handled by `parDfsBuild` as follows: + +- We launch a thread for every module we discover that needs to be + expanded in the `coordinator` thread, popping it from the worklist +- Every launched `worker` thread blocks waiting for a semaphore token + (`withAbstractSem`) to respect -j<N> +- The main thread waits until both the worklist and pending list is + cleared, atomically. + +STM is used crucially to guarantee e.g. we don't have race conditions +between taking from the worklist and writing to the pending list while +checking whether they are clear. + +Exceptions are bubbled up to the main thread. The "main" thread, which is +typically waiting for the worklist+pending lists to be clear, instead gets +unblocked by this exception (signaled in `exc_var`) and re-throws it. -} + +-------------------------------------------------------------------------------- +-- * Concurrent utilities +-------------------------------------------------------------------------------- + +-- | Map an action over a list using the parallelism pipeline system. +-- Create bundles of the list elems wrapped in a 'MakeAction' 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 '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. +-- +-- To emulate the current behavior, we funnel exceptions past the concurrency +-- barrier and rethrow the first one afterwards. +mapConcDS :: + WorkerLimit -> + Int {-^ Batch size -} -> + MakeEnv -> + (HscEnv -> a -> IO b) -> + [a] -> + IO ([b]) +mapConcDS n_jobs bundle_size make_env run_action xs = do + (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles) + runAllPipelines n_jobs make_env actions + (sequence . catMaybes <$> sequence get_results) >>= \case + Right results -> pure (concat results) + Left exc -> throwIO exc + where + bundles = mk_bundles xs + + mk_bundles = unfoldr \case + [] -> Nothing + ts -> Just (splitAt bundle_size ts) + + action_and_result (log_queue_id, ts) = do + res_var <- liftIO newEmptyMVar + pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var) + + action log_queue_id target_bundle = do + env@MakeEnv {compile_sem} <- ask + lift $ lift $ + withAbstractSem compile_sem $ + withLoggerHsc log_queue_id env \ lcl_hsc_env -> + MC.try (mapM (run_action lcl_hsc_env) target_bundle) >>= \case + Left e | Just (_ :: SomeAsyncException) <- fromException e -> + throwIO e + a -> pure a ===================================== compiler/GHC/Driver/MakeAction.hs ===================================== @@ -185,7 +185,8 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do -- withLocalTmpFs has to occur outside of fork to remain deterministic new_thread <- withLocalTmpFSMake env $ \lcl_env -> - fork_thread $ \unmask -> (do + MC.mask_ $ + fork_thread $ \unmask -> (do mres <- (unmask $ run_pipeline lcl_env act) `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure. putMVar res_var mres) ===================================== testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs ===================================== @@ -24,7 +24,7 @@ import Control.Monad.Catch (handle, throwM) import Control.Exception.Context import GHC.Driver.MakeFile import GHC.Utils.Outputable -import Data.IORef (newIORef) +import Control.Concurrent.MVar -- | Convert a ModuleNodeCompile to a ModuleNodeFixed convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo convertToFixed (ModuleNodeCompile ms) = @@ -152,6 +152,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - summ_cache <- liftIO $ newIORef mempty + summ_cache <- liftIO $ newMVar mempty Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs ===================================== @@ -6,6 +6,7 @@ import GHC.Driver.Session import GHC.Driver.Monad import GHC.Driver.Env import GHC.Driver.Make (summariseFile) +import GHC.Driver.MakeAction import GHC.Driver.Downsweep import GHC.Unit.Module.Graph import GHC.Unit.Module.ModSummary @@ -16,12 +17,13 @@ import GHC.Types.SourceFile import System.Environment import Control.Monad (void, when) import Data.Maybe (fromJust) -import Data.IORef (newIORef) +import Control.Concurrent.MVar import Control.Exception (ExceptionWithContext(..), SomeException) import Control.Monad.Catch (handle, throwM) import Control.Exception.Context import GHC.Utils.Outputable import Data.List +import GHC.Types.Error import GHC.Unit.Env import GHC.Unit.State import GHC.Tc.Utils.Monad @@ -60,7 +62,7 @@ main = do hsc_env <- getSession setSession $ hsc_env { hsc_dflags = (hsc_dflags hsc_env) { ghcMode = OneShot } } hsc_env <- getSession - + n_jobs <- liftIO $ mkWorkerLimit (hsc_dflags hsc_env) -- Create ModNodeKeys with unit IDs let keyA = msKey msA @@ -68,10 +70,21 @@ main = do keyC = msKey msC let mkGraph s = do - summ_cache <- newIORef mempty - imps_cache <- newIORef mempty - ([], nodes) <- downsweepFromRootNodes hsc_env summ_cache imps_cache Nothing [] True DownsweepUseFixed s [] - return $ mkModuleGraph nodes + summ_cache <- newMVar mempty + imps_cache <- newMVar mempty + withMakeEnv n_jobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do + let env = DownsweepEnv + { ds_hsc_env = hsc_env + , ds_summaries_cache = summ_cache + , ds_imports_cache = imps_cache + , ds_mode = DownsweepUseFixed + , ds_excl_mods = [] + , ds_n_jobs = n_jobs + , ds_make_env = make_env + } + ([], nodes) <- runDownsweepM env $ + downsweepFromRootNodes Nothing True s [] + return $ mkModuleGraph nodes graph <- liftIO $ mkGraph [ModuleNodeCompile msC] @@ -101,6 +114,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - summ_cache <- liftIO $ newIORef mempty + summ_cache <- liftIO $ newMVar mempty Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs ===================================== @@ -23,7 +23,7 @@ import Control.Monad.Catch (handle, throwM) import Control.Exception.Context import GHC.Utils.Outputable import Data.List -import Data.IORef (newIORef) +import Control.Concurrent.MVar -- | Convert a ModuleNodeCompile to a ModuleNodeFixed convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo @@ -133,6 +133,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - summ_cache <- liftIO $ newIORef mempty + summ_cache <- liftIO $ newMVar mempty Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing return ms ===================================== testsuite/tests/splice-imports/SI35.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Unit.Module.Stage import GHC.Data.Graph.Directed.Reachability import GHC.Utils.Trace import GHC.Unit.Module.Graph -import Data.IORef (newIORef) +import Control.Concurrent.MVar main :: IO () main = do @@ -76,6 +76,6 @@ main = do getModSummaryFromTarget :: FilePath -> Ghc ModSummary getModSummaryFromTarget file = do hsc_env <- getSession - summ_cache <- liftIO $ newIORef mempty + summ_cache <- liftIO $ newMVar mempty Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) summ_cache file Nothing Nothing - return ms \ No newline at end of file + return ms ===================================== utils/check-ppr/Main.hs ===================================== @@ -18,7 +18,7 @@ import System.Environment( getArgs ) import System.Exit import System.FilePath import System.IO -import Data.IORef +import Control.Concurrent.MVar usage :: String usage = unlines @@ -86,7 +86,7 @@ parseOneFile libdir fileName = do let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream _ <- setSessionDynFlags dflags2 hsc_env <- getSession - cache <- liftIO $ newIORef mempty + cache <- liftIO $ newMVar mempty mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) cache fileName Nothing Nothing case mms of Left _err -> error "parseOneFile" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/abbdbdf9b82c3d8de76bfe72603095b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/abbdbdf9b82c3d8de76bfe72603095b... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help