Wolfgang Jeltsch pushed to branch wip/jeltsch/module-graph-reuse-in-downsweep at Glasgow Haskell Compiler / GHC Commits: eedd0f1f by Wolfgang Jeltsch at 2026-05-21T15:13:43+03:00 Add preliminary version of `IncrementalDownsweep` test - - - - - 10 changed files: - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/A.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/B.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/C.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/D.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/X.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/Y.hs - + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/Z.hs - testsuite/tests/ghc-api/downsweep/all.T Changes: ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs ===================================== @@ -0,0 +1,89 @@ +{-# 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 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" + +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 + logger <- getLogger + originalDynFlags <- getSessionDynFlags + (finalDynFlags, _, _) + <- parseDynamicFlags logger originalDynFlags $ + map noLoc (["-i", "-i" ++ sourceDirectory] ++ otherArgs) + _ <- setSessionDynFlags finalDynFlags + intermediateModuleGraph + <- performDownsweepTurn Nothing "A" + liftIO $ outputModuleNamesInGraph intermediateModuleGraph + finalModuleGraph + <- performDownsweepTurn (Just intermediateModuleGraph) "X" + liftIO $ outputModuleNamesInGraph finalModuleGraph ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout ===================================== @@ -0,0 +1,2 @@ +["A","B","C","D"] +["A","B","C","D","X","Y","Z"] ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/A.hs ===================================== @@ -0,0 +1,4 @@ +module A where + +import B +import C ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/B.hs ===================================== @@ -0,0 +1,3 @@ +module B where + +import D ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/C.hs ===================================== @@ -0,0 +1,3 @@ +module C where + +import D ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/D.hs ===================================== @@ -0,0 +1 @@ +module D where ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/X.hs ===================================== @@ -0,0 +1,4 @@ +module X where + +import Y +import Z ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/Y.hs ===================================== @@ -0,0 +1,3 @@ +module Y where + +import B ===================================== testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/Z.hs ===================================== @@ -0,0 +1,3 @@ +module Z where + +import C ===================================== testsuite/tests/ghc-api/downsweep/all.T ===================================== @@ -14,3 +14,9 @@ test('OldModLocation', ], compile_and_run, ['-package ghc']) + +test('IncrementalDownsweep', + [ extra_run_opts('"' + config.libdir + '"') + ], + compile_and_run, + ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eedd0f1ffa036c7552e68a3cff12ea4f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eedd0f1ffa036c7552e68a3cff12ea4f... You're receiving this email because of your account on gitlab.haskell.org.