summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlexis King <lexi.lambda@gmail.com>2023-03-08 06:15:54 -0600
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-03-08 15:03:10 -0500
commit7c813d0688f03c782d3c3a93a8369a48b7e74c8d (patch)
tree7d19bebfe690a170e8668efdb4d754904df3fd4a
parentba73a807edbb444c49e0cf21ab2ce89226a77f2e (diff)
downloadhaskell-7c813d0688f03c782d3c3a93a8369a48b7e74c8d.tar.gz
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.
-rw-r--r--hadrian/doc/user-settings.md8
-rw-r--r--hadrian/src/Expression.hs13
-rw-r--r--hadrian/src/Flavour.hs38
-rw-r--r--hadrian/src/Oracles/Flavour.hs3
-rw-r--r--hadrian/src/Settings/Builders/Ghc.hs2
-rw-r--r--hadrian/src/Settings/Builders/RunTest.hs6
-rw-r--r--hadrian/src/Settings/Flavours/Development.hs7
-rw-r--r--hadrian/src/Settings/Flavours/Quick.hs2
-rw-r--r--hadrian/src/Settings/Packages.hs15
9 files changed, 61 insertions, 33 deletions
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 <root>/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")
]
]