Wolfgang Jeltsch pushed to branch wip/jeltsch/module-graph-reuse-in-downsweep at Glasgow Haskell Compiler / GHC Commits: b859a2f0 by Wolfgang Jeltsch at 2026-05-27T18:23:23+03:00 Allow `downsweep` to use nodes of an existing module graph To this end, `downsweep` has not been able to use the nodes of a module graph obtained from a previous downsweeping round. In some GHC API applications, downsweeping is performed somewhat incrementally and therefore could profit from reusing such existing results. This contribution makes this possible. Resolves #27054. Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com> - - - - - 16 changed files: - + changelog.d/module-graph-reuse-in-downsweep - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Make.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/A.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/B.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/C.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/D.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/X.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Y.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Z.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/downsweep/all.T - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs Changes: ===================================== changelog.d/module-graph-reuse-in-downsweep ===================================== @@ -0,0 +1,9 @@ +section: compiler +synopsis: Allow `downsweep` to use nodes of an existing module graph +issues: #27054 +mrs: !16028 +description: { + This contribution enables `downsweep` to use the nodes of a module + graph obtained from a previous downsweeping round, which allows GHC + API applications to build module graphs somewhat incrementally. +} ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -146,6 +146,10 @@ The result is having a uniform graph available for the whole compilation pipelin -- an import of this module mean. type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo] +moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode +moduleGraphNodeMap graph + = M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] + ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) for --make mode @@ -158,6 +162,13 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv -- cache to avoid recalculating a module summary if the source is -- unchanged. -- +-- Downsweeping can start from scratch for from a given module graph. In the +-- latter case, the given graph is fully included in the resulting graph, even +-- if parts of it are not reachable from any of the given roots. When an import +-- is processed, the source of the imported module is not consulted if this +-- module is already mentioned in the given graph. The sources of the root +-- modules are always consulted, though. +-- -- The returned ModuleGraph has one node for each home-package -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. @@ -172,6 +183,8 @@ downsweep :: HscEnv -> Maybe Messager -> [ModSummary] -- ^ Old summaries + -> Maybe ModuleGraph + -- ^ Optionally a module graph to extend -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have @@ -181,7 +194,7 @@ downsweep :: HscEnv -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats -downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do +downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary let closure_errs = checkHomeUnitsClosed unit_env @@ -191,7 +204,7 @@ downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do case all_errs of [] -> do - (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] + (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map 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) @@ -232,7 +245,7 @@ downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." - ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] + ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] let dflags = hsc_dflags hsc_env liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) (initPrintConfig dflags) @@ -360,7 +373,7 @@ downsweepInstalledModules hsc_env mods = do _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i nodes <- mapM process installed_mods - (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids + (errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed 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 @@ -385,19 +398,21 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed -- all the dependencies, all the way to the leaf units. downsweepFromRootNodes :: HscEnv -> M.Map (UnitId, OsPath) ModSummary + -> 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 old_summaries excl_mods allow_dup_roots mode root_nodes root_uids +downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids = do let root_map = mkRootMap root_nodes checkDuplicates root_map let env = DownsweepEnv hsc_env mode old_summaries excl_mods (deps', map0) <- runDownsweepM env $ do - (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) + let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph + (module_deps, map0) <- loopModuleNodeInfos root_nodes (base_nodes, root_map) let all_deps = loopUnit hsc_env module_deps root_uids let all_instantiations = getHomeUnitInstantiations hsc_env deps' <- loopInstantiations all_instantiations all_deps ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -232,7 +232,7 @@ depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) (errs, mod_graph) <- liftIO $ downsweep - hsc_env diag_wrapper msg (mgModSummaries old_graph) + hsc_env diag_wrapper msg (mgModSummaries old_graph) Nothing excluded_mods allow_dup_roots return (unionManyMessages errs, mod_graph) ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs ===================================== @@ -0,0 +1,105 @@ +{-# LANGUAGE Haskell2010 #-} + +{-# OPTIONS_GHC -Wall -Werror #-} + +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Arrow ((>>>)) +import Data.List (sort) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (stderr) +import System.Directory (removeFile) +import Language.Haskell.Syntax.Module.Name (moduleNameString) +import GHC.Utils.Ppr (Mode (PageMode)) +import GHC.Utils.Outputable (vcat, defaultSDocContext, printSDocLn, ppr) +import GHC.Utils.Logger (getLogger) +import GHC.Types.SrcLoc (noLoc) +import GHC.Types.Error (mkUnknownDiagnostic) +import GHC.Unit.Types (moduleName) +import GHC.Unit.Module.ModSummary (ms_mod) +import GHC.Unit.Module.Graph (ModuleGraph, mgModSummaries) +import GHC.Driver.DynFlags (defaultFatalMessager, defaultFlushOut) +import GHC.Driver.Monad (Ghc, getSession, getSessionDynFlags) +import GHC.Driver.Make (downsweep) +import GHC.Driver.Errors.Types (DriverMessages) +import GHC + ( + defaultErrorHandler, + guessTarget, + setTargets, + parseDynamicFlags, + setSessionDynFlags, + runGhc + ) + +sourceDirectory :: String +sourceDirectory = "IncrementalDownsweep.modules" + +withSimpleErrorHandler :: Ghc a -> Ghc a +withSimpleErrorHandler = defaultErrorHandler defaultFatalMessager + defaultFlushOut + +handleDriverMessages :: [DriverMessages] -> IO () +handleDriverMessages driverMsgs + = unless (null driverMsgs) $ + do + printSDocLn defaultSDocContext + (PageMode True) + stderr + (vcat (map ppr driverMsgs)) + exitFailure + +performDownsweepTurn :: Maybe ModuleGraph -> String -> Ghc ModuleGraph +performDownsweepTurn maybeGivenModuleGraph rootModuleName = do + target <- guessTarget rootModuleName Nothing Nothing + setTargets [target] + session <- getSession + (driverMsgs, resultingModuleGraph) + <- liftIO $ downsweep session + mkUnknownDiagnostic + Nothing + [] + maybeGivenModuleGraph + [] + False + liftIO $ handleDriverMessages driverMsgs + return resultingModuleGraph + +outputModuleNamesInGraph :: ModuleGraph -> IO () +outputModuleNamesInGraph = mgModSummaries >>> + map (ms_mod >>> moduleName >>> moduleNameString) >>> + sort >>> + print + +main :: IO () +main = do + libDir : otherArgs <- getArgs + runGhc (Just libDir) $ withSimpleErrorHandler $ do + + -- Setup + logger <- getLogger + originalDynFlags <- getSessionDynFlags + (finalDynFlags, _, _) + <- parseDynamicFlags logger originalDynFlags $ + map noLoc (["-i", "-i" ++ sourceDirectory] ++ otherArgs) + _ <- setSessionDynFlags finalDynFlags + + -- Turn 1: From scratch, using 'A' as root + moduleGraph1 <- performDownsweepTurn Nothing "A" + liftIO $ outputModuleNamesInGraph moduleGraph1 + + -- Turn 2: From scratch, using 'X' as root + -- NOTE: 'A' is not included, because it is not reachable. + moduleGraph2 <- performDownsweepTurn Nothing "X" + liftIO $ outputModuleNamesInGraph moduleGraph2 + + -- Deletion of the source files used in turn 1 + _ <- liftIO $ + mapM_ (((sourceDirectory ++ "/") ++) >>> (++ ".hs") >>> removeFile) + ["A", "B", "C", "D"] + + -- Turn 3: Based on the result of turn 1, using 'X' as root + -- NOTE: 'A' is included, because the result of turn 1 contains it. + moduleGraph3 <- performDownsweepTurn (Just moduleGraph1) "X" + liftIO $ outputModuleNamesInGraph moduleGraph3 ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/A.hs ===================================== @@ -0,0 +1,4 @@ +module A where + +import B +import C ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/B.hs ===================================== @@ -0,0 +1,3 @@ +module B where + +import D ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/C.hs ===================================== @@ -0,0 +1,3 @@ +module C where + +import D ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/D.hs ===================================== @@ -0,0 +1 @@ +module D where ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/X.hs ===================================== @@ -0,0 +1,4 @@ +module X where + +import Y +import Z ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Y.hs ===================================== @@ -0,0 +1,3 @@ +module Y where + +import B ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Z.hs ===================================== @@ -0,0 +1,3 @@ +module Z where + +import C ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout ===================================== @@ -0,0 +1,3 @@ +["A","B","C","D"] +["B","C","D","X","Y","Z"] +["A","B","C","D","X","Y","Z"] ===================================== testsuite/tests/ghc-api/downsweep/OldModLocation.hs ===================================== @@ -48,13 +48,13 @@ main = do liftIO $ do - _emss <- downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False + _emss <- downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) createDirectoryIfMissing False "mydir" renameFile "B.hs" "mydir/B.hs" - (_, nodes) <- downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False + (_, nodes) <- downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with -- (ms_location old_summary) like summariseFile used to instead of ===================================== testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs ===================================== @@ -169,7 +169,7 @@ go label mods cnd = setTargets [tgt] hsc_env <- getSession - (_, nodes) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False + (_, nodes) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False it label $ cnd (mgModSummaries nodes) ===================================== testsuite/tests/ghc-api/downsweep/all.T ===================================== @@ -14,3 +14,10 @@ test('OldModLocation', ], compile_and_run, ['-package ghc']) + +test('IncrementalDownsweep', + [ extra_files(['IncrementalDownsweep.modules/']) + , extra_run_opts('"' + config.libdir + '"') + ], + compile_and_run, + ['-package ghc']) ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs ===================================== @@ -67,7 +67,7 @@ main = do keyC = msKey msC let mkGraph s = do - ([], nodes) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed s [] + ([], nodes) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed s [] return $ mkModuleGraph nodes graph <- liftIO $ mkGraph [ModuleNodeCompile msC] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b859a2f0dd8b9b924cabab566c0f4e12... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b859a2f0dd8b9b924cabab566c0f4e12... You're receiving this email because of your account on gitlab.haskell.org.