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.

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")
             ]
           ]