From 7c813d0688f03c782d3c3a93a8369a48b7e74c8d Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 8 Mar 2023 06:15:54 -0600 Subject: hadrian: Fix flavour compiler stage options off-by-one error !9193 pointed out that ghcDebugAssertions was supposed to be a predicate on the stage of the built compiler, but in practice it was a predicate on the stage of the compiler used to build. Unfortunately, while it fixed that issue for ghcDebugAssertions, it documented every other similar option as behaving the same way when in fact they all used the old behavior. The new behavior of ghcDebugAssertions seems more intuitive, so this commit changes the interpretation of every other option to match. It also improves the enableProfiledGhc and debugGhc flavour transformers by making them more selective about which stages in which they build additional library/RTS ways. --- hadrian/doc/user-settings.md | 8 ++++-- hadrian/src/Expression.hs | 13 +++++++++- hadrian/src/Flavour.hs | 38 +++++++++++++++++++--------- hadrian/src/Oracles/Flavour.hs | 3 ++- hadrian/src/Settings/Builders/Ghc.hs | 2 +- hadrian/src/Settings/Builders/RunTest.hs | 6 +++-- hadrian/src/Settings/Flavours/Development.hs | 7 +++-- hadrian/src/Settings/Flavours/Quick.hs | 2 +- hadrian/src/Settings/Packages.hs | 15 +++++------ 9 files changed, 61 insertions(+), 33 deletions(-) (limited to 'hadrian') diff --git a/hadrian/doc/user-settings.md b/hadrian/doc/user-settings.md index 795f877557..5616d871be 100644 --- a/hadrian/doc/user-settings.md +++ b/hadrian/doc/user-settings.md @@ -227,17 +227,21 @@ prefixes, and `*` matches an entire path component, excluding any separators. What was previously achieved by having `GhcDebugged=YES` in `mk/build.mk` can be done by defining a custom flavour in the user settings file, one that -sets the `ghcDebugged` field of `Flavour` to `True`, e.g: +sets the `ghcDebugged` field of `Flavour` to `const True`, e.g: ``` haskell quickDebug :: Flavour -quickDebug = quickFlavour { name = "dbg", ghcDebugged = True } +quickDebug = quickFlavour { name = "dbg", ghcDebugged = const True } ``` Running `build --flavour=dbg` will build a `quick`-flavoured GHC and link GHC, iserv, iserv-proxy and remote-iserv against the debugged RTS, by passing `-debug` to the commands that link those executables. +More generally, a predicate on `Stage` can be provided to specify which stages should be built debugged. For example, setting `ghcDebugged = (>= Stage2)` will build a debugged compiler at stage 2 or higher, but not stage 1. + +Finally, the `debug_ghc` and `debug_stage1_ghc` [flavour transformers](#flavour-transformers) provide a convenient way to enable `ghcDebugged` on the command line without the need to define a separate custom flavour. + ### Packages Users can add and remove packages from particular build stages. As an example, diff --git a/hadrian/src/Expression.hs b/hadrian/src/Expression.hs index db437013b4..0b9c50ef3a 100644 --- a/hadrian/src/Expression.hs +++ b/hadrian/src/Expression.hs @@ -8,7 +8,8 @@ module Expression ( expr, exprIO, arg, remove, cabalFlag, -- ** Predicates - (?), stage, stage0, stage1, stage2, notStage0, threadedBootstrapper, + (?), stage, stage0, stage1, stage2, notStage0, buildingCompilerStage, + buildingCompilerStage', threadedBootstrapper, package, notPackage, packageOneOf, cross, notCross, libraryPackage, builder, way, input, inputs, output, outputs, @@ -128,6 +129,16 @@ stage2 = stage Stage2 notStage0 :: Predicate notStage0 = notM Expression.stage0 +-- | Are we currently building a compiler for a particular stage? +buildingCompilerStage :: Stage -> Predicate +buildingCompilerStage s = buildingCompilerStage' (== s) + +-- | Like 'buildingCompilerStage', but lifts an arbitrary predicate on 'Stage', +-- which is useful for checking flavour fields like 'ghcProfiled' and +-- 'ghcDebugged'. +buildingCompilerStage' :: (Stage -> Bool) -> Predicate +buildingCompilerStage' f = f . succStage <$> getStage + -- | Whether or not the bootstrapping compiler provides a threaded RTS. We need -- to know this when building stage 1, since stage 1 links against the diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs index 79eb18bed4..6f68d6c6ba 100644 --- a/hadrian/src/Flavour.hs +++ b/hadrian/src/Flavour.hs @@ -59,8 +59,8 @@ flavourTransformers = M.fromList , "fully_static" =: fullyStatic , "collect_timings" =: collectTimings , "assertions" =: enableAssertions - , "debug_ghc" =: debugGhc Stage1 - , "debug_stage1_ghc" =: debugGhc stage0InTree + , "debug_ghc" =: debugGhc Stage2 + , "debug_stage1_ghc" =: debugGhc Stage1 , "lint" =: enableLinting , "haddock" =: enableHaddock , "hi_core" =: enableHiCore @@ -215,18 +215,29 @@ enableThreadSanitizer = addArgs $ notStage0 ? mconcat viaLlvmBackend :: Flavour -> Flavour viaLlvmBackend = addArgs $ notStage0 ? builder Ghc ? arg "-fllvm" --- | Build the GHC executable with profiling enabled in stages 1 and later. It +-- | Build the GHC executable with profiling enabled in stages 2 and later. It -- is also recommended that you use this with @'dynamicGhcPrograms' = False@ -- since GHC does not support loading of profiled libraries with the -- dynamically-linker. enableProfiledGhc :: Flavour -> Flavour enableProfiledGhc flavour = - enableLateCCS flavour { rtsWays = do - ws <- rtsWays flavour - pure $ (Set.map (\w -> if wayUnit Dynamic w then w else w <> profiling) ws) <> ws - , libraryWays = (Set.singleton profiling <>) <$> (libraryWays flavour) - , ghcProfiled = (>= Stage1) - } + enableLateCCS flavour + { rtsWays = do + ws <- rtsWays flavour + mconcat + [ pure ws + , buildingCompilerStage' (>= Stage2) ? pure (foldMap profiled_ways ws) + ] + , libraryWays = mconcat + [ libraryWays flavour + , buildingCompilerStage' (>= Stage2) ? pure (Set.singleton profiling) + ] + , ghcProfiled = (>= Stage2) + } + where + profiled_ways w + | wayUnit Dynamic w = Set.empty + | otherwise = Set.singleton (w <> profiling) -- | Disable 'dynamicGhcPrograms'. disableDynamicGhcPrograms :: Flavour -> Flavour @@ -350,11 +361,14 @@ collectTimings = -- | Build ghc with debug rts (i.e. -debug) in and after this stage debugGhc :: Stage -> Flavour -> Flavour -debugGhc stage f = f - { ghcDebugged = (>= stage) +debugGhc ghcStage f = f + { ghcDebugged = (>= ghcStage) , rtsWays = do ws <- rtsWays f - pure $ (Set.map (\w -> w <> debug) ws) <> ws + mconcat + [ pure ws + , buildingCompilerStage' (>= ghcStage) ? pure (Set.map (<> debug) ws) + ] } -- * CLI and /hadrian.settings options diff --git a/hadrian/src/Oracles/Flavour.hs b/hadrian/src/Oracles/Flavour.hs index 040787a7b2..cf9ec7e3c2 100644 --- a/hadrian/src/Oracles/Flavour.hs +++ b/hadrian/src/Oracles/Flavour.hs @@ -24,7 +24,8 @@ type instance RuleResult GhcProfiled = Bool oracles :: Rules () oracles = do void $ addOracle $ \(DynGhcPrograms _) -> dynamicGhcPrograms =<< flavour - void $ addOracle $ \(GhcProfiled stage) -> ghcProfiled <$> flavour <*> pure stage + void $ addOracle $ \(GhcProfiled stage) -> + ghcProfiled <$> flavour <*> pure (succStage stage) askDynGhcPrograms :: Action Bool askDynGhcPrograms = askOracle $ DynGhcPrograms () diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs index 88bd26bd62..aa243db30c 100644 --- a/hadrian/src/Settings/Builders/Ghc.hs +++ b/hadrian/src/Settings/Builders/Ghc.hs @@ -116,7 +116,7 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do useSystemFfi <- expr (flag UseSystemFfi) buildPath <- getBuildPath libffiName' <- libffiName - debugged <- ghcDebugged <$> expr flavour <*> getStage + debugged <- buildingCompilerStage' . ghcDebugged =<< expr flavour osxTarget <- expr isOsxTarget winTarget <- expr isWinTarget diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs index b096f05a45..a0a245458b 100644 --- a/hadrian/src/Settings/Builders/RunTest.hs +++ b/hadrian/src/Settings/Builders/RunTest.hs @@ -101,8 +101,10 @@ inTreeCompilerArgs stg = do unregisterised <- flag GhcUnregisterised tables_next_to_code <- flag TablesNextToCode targetWithSMP <- targetSupportsSMP - debugAssertions <- ($ succStage stg) . ghcDebugAssertions <$> flavour - profiled <- ghcProfiled <$> flavour <*> pure stg + + let ghcStage = succStage stg + debugAssertions <- ghcDebugAssertions <$> flavour <*> pure ghcStage + profiled <- ghcProfiled <$> flavour <*> pure ghcStage os <- setting HostOs arch <- setting TargetArch diff --git a/hadrian/src/Settings/Flavours/Development.hs b/hadrian/src/Settings/Flavours/Development.hs index ccc592cdc6..c710d8855f 100644 --- a/hadrian/src/Settings/Flavours/Development.hs +++ b/hadrian/src/Settings/Flavours/Development.hs @@ -24,8 +24,7 @@ developmentFlavour ghcStage = defaultFlavour stageString s = error ("developmentFlavour not supported for " ++ show s) developmentArgs :: Stage -> Args -developmentArgs ghcStage = do - stage <- getStage +developmentArgs ghcStage = sourceArgs SourceArgs { hsDefault = mconcat [ pure ["-O", "-H64m"], -- Disable optimization when building Cabal; @@ -33,5 +32,5 @@ developmentArgs ghcStage = do package cabal ? pure ["-O0"]] , hsLibrary = notStage0 ? arg "-dlint" , hsCompiler = mconcat [stage0 ? arg "-O2", - stage == predStage ghcStage ? pure ["-O0"]] - , hsGhc = stage == predStage ghcStage ? pure ["-O0"] } + buildingCompilerStage ghcStage ? pure ["-O0"]] + , hsGhc = buildingCompilerStage ghcStage ? pure ["-O0"] } diff --git a/hadrian/src/Settings/Flavours/Quick.hs b/hadrian/src/Settings/Flavours/Quick.hs index 25a5624b9b..6df22c5712 100644 --- a/hadrian/src/Settings/Flavours/Quick.hs +++ b/hadrian/src/Settings/Flavours/Quick.hs @@ -42,5 +42,5 @@ quickArgs = sourceArgs SourceArgs quickDebugFlavour :: Flavour quickDebugFlavour = quickFlavour { name = "quick-debug" - , ghcDebugged = (>= Stage1) + , ghcDebugged = (>= Stage2) } diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs index e2afd72ee5..05f7b6fb1e 100644 --- a/hadrian/src/Settings/Packages.hs +++ b/hadrian/src/Settings/Packages.hs @@ -6,7 +6,6 @@ import Oracles.Setting import Oracles.Flag import Packages import Settings -import Oracles.Flavour -- | Package-specific command-line arguments. packageArgs :: Args @@ -24,14 +23,12 @@ packageArgs = do -- are building. This is used to build cross-compilers bootCross = (==) <$> ghcVersionStage (stage0InTree) <*> ghcVersionStage Stage1 + compilerStageOption f = buildingCompilerStage' . f =<< expr flavour + cursesIncludeDir <- getSetting CursesIncludeDir cursesLibraryDir <- getSetting CursesLibDir ffiIncludeDir <- getSetting FfiIncludeDir ffiLibraryDir <- getSetting FfiLibDir - debugAssertions <- ( `ghcDebugAssertions` (succStage stage) ) <$> expr flavour - -- NB: in this function, "stage" is the stage of the compiler we are - -- using to build, but ghcDebugAssertions wants the stage of the compiler - -- we are building, which we get using succStage. mconcat --------------------------------- base --------------------------------- @@ -54,7 +51,7 @@ packageArgs = do [ builder Alex ? arg "--latin1" , builder (Ghc CompileHs) ? mconcat - [ debugAssertions ? arg "-DDEBUG" + [ compilerStageOption ghcDebugAssertions ? arg "-DDEBUG" , inputs ["**/GHC.hs", "**/GHC/Driver/Make.hs"] ? arg "-fprof-auto" , input "**/Parser.hs" ? @@ -71,7 +68,7 @@ packageArgs = do , builder (Cabal Setup) ? mconcat [ arg "--disable-library-for-ghci" , anyTargetOs ["openbsd"] ? arg "--ld-options=-E" - , (getStage >>= expr . askGhcProfiled) ? arg "--ghc-pkg-option=--force" ] + , compilerStageOption ghcProfiled ? arg "--ghc-pkg-option=--force" ] , builder (Cabal Flags) ? mconcat [ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter" @@ -85,7 +82,7 @@ packageArgs = do , package ghc ? mconcat [ builder Ghc ? mconcat [ arg ("-I" ++ compilerPath) - , debugAssertions ? arg "-DDEBUG" ] + , compilerStageOption ghcDebugAssertions ? arg "-DDEBUG" ] , builder (Cabal Flags) ? mconcat [ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter" @@ -96,7 +93,7 @@ packageArgs = do -- We build a threaded stage N, N>1 if the configuration calls -- for it. - ((ghcThreaded <$> expr flavour <*> getStage ) `cabalFlag` "threaded") + (compilerStageOption ghcThreaded `cabalFlag` "threaded") ] ] -- cgit v1.2.1