Rodrigo Mesquita pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: 273838c8 by Rodrigo Mesquita at 2026-08-13T15:36:46+01:00 Parallelize downsweep traversal TODO:Commit message, include benchmark of cabal test -M which is 2x crrscts fxes - - - - - c8f76a77 by Rodrigo Mesquita at 2026-08-13T15:52:28+01:00 handle excpss - - - - - f8a0bbf2 by Rodrigo Mesquita at 2026-08-13T16:31:23+01:00 fixes fixe - - - - - 1 changed file: - compiler/GHC/Driver/Downsweep.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -112,8 +112,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] @@ -256,8 +259,8 @@ 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 + 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) @@ -341,8 +344,8 @@ downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." njobs <- mkWorkerLimit (hsc_dflags hsc_env) - summs <- newIORef (mkModSummaryCache [(mod_summary,SummOld)]) - imps <- newIORef mempty + 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 @@ -386,8 +389,8 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do let cached_nodes = Map.fromList [ (mkNodeKey n, NSuccess n) | n <- mg_mss (hsc_mod_graph hsc_env) ] n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) - summ_cache <- newIORef mempty - imps_cache <- newIORef mempty + 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 @@ -431,8 +434,8 @@ downsweepInstalledModules hsc_env mods = do njobs <- mkWorkerLimit (hsc_dflags hsc_env) nodes <- mapM process installed_mods - summs <- newIORef mempty - imps <- newIORef mempty + summs <- newMVar mempty + imps <- newMVar mempty withMakeEnv njobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do let env = DownsweepEnv { ds_hsc_env = hsc_env @@ -459,8 +462,8 @@ downsweepInstalledModules hsc_env mods = do -- * 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 @@ -514,7 +517,7 @@ downsweepFromRootNodes maybe_base_graph allow_dup_roots root_nodes root_uids = all_deps <- loopUnits module_deps (hscActiveUnitId ds_hsc_env) root_uids deps' <- loopInstantiations all_deps (getHomeUnitInstantiations ds_hsc_env) return deps' - f_cache <- readIORef ds_summaries_cache + f_cache <- readMVar ds_summaries_cache let downsweep_errs = lefts (M.elems f_cache) downsweep_nodes = [ s | NSuccess s <- M.elems deps' ] @@ -573,8 +576,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 r f = modifyMVar r (\c -> let !r = f c in pure (r, ())) +modifyImpsCache r f = modifyMVar r (\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 @@ -597,7 +600,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) @@ -696,7 +699,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)) @@ -1328,7 +1331,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 @@ -1508,7 +1511,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 @@ -1550,7 +1553,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. @@ -1741,7 +1744,7 @@ data NodeRes v -- abort. | NSkip --- | In a depth-first order, and starting from the given roots, traverse a +-- | In a parallel 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. -- @@ -1759,13 +1762,10 @@ data NodeRes v -- 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) +parDfsBuild :: 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. @@ -1773,29 +1773,85 @@ 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 -- signal this var when there's an exception + visited_var <- newTVarIO (fromMaybe Map.empty base_map) + pending <- newTVarIO Set.empty + worklist <- newTQueueIO + coord_tid <- forkIO $ + coordinator ds_env exc_var visited_var worklist pending + `MC.catch` \(e::MC.SomeException) -> atomically (modifyTVar' exc_var (<|> Just e)) + mapM_ (atomically . writeTQueue worklist) roots + mb_exc <- atomically $ do + readTVar exc_var >>= \case + Just e -> + -- exit if there's an exception + return (Just e) + Nothing -> do + -- otherwise, exit only when pending and worklist are both empty, + -- *atomically*; else, `retry`. + empty_worklist <- isEmptyTQueue worklist + empty_pending <- Set.null <$> readTVar pending + unless (empty_worklist && empty_pending) retry + return Nothing + killThread coord_tid + 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 + coordinator ds_env exc_var visvar worklist pendvar = 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 + withLocalTmpFSMake (ds_make_env ds_env) $ \make_env -> + forkIO $ + worker ds_env{ds_make_env = make_env} exc_var visvar + worklist pendvar k node + return () + + worker ds_env@DownsweepEnv{..} exc_var visvar worklist pendvar k node = + withAbstractSem (compile_sem ds_make_env) $ -- acquire -j par token + withLoggerHsc 1{- TODO: seq numb-} ds_make_env \ lcl_hsc_env -> do + + r <- MC.try $ runDownsweepM ds_env{ds_hsc_env = lcl_hsc_env} $ + expand node -- do the main work! + + case r of + Left (e :: MC.SomeException) -> + -- signal exception in this thread for the main thread to throw it + atomically $ modifyTVar' exc_var (<|> Just e) + Right NSkip -> + -- write node skip; nothing new to queue + atomically $ modifyTVar' visvar (Map.insert k NSkip) + Right (NSuccess (v,ns)) -> do + -- write success result; queue the next nodes + atomically $ modifyTVar' visvar (Map.insert k (NSuccess v)) + mapM_ (atomically . writeTQueue worklist) ns + + -- no longer pending: + atomically $ modifyTVar' pendvar (Set.delete k) {- Note [Downsweep Control Flow and Caching] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/db2f5ad37f9dec233ae589a3aaf3593... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/db2f5ad37f9dec233ae589a3aaf3593... 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