hadrian: Need builders needed by Cabal Configure in parallel

Because of the use of withStaged (which needs the necessary builder)
when configuring a package, the builds of stage1:exe:ghc-bin and
stage1:exe:ghc-pkg where being linearised when building a specific
target like `binary-dist-dir`.

Thankfully the fix is quite local, to supply all the `withStaged`
arguments together so the needs can be batched together and hence
performed in parallel.

Fixes #22093

4 files changed, 31 insertions, 29 deletions

diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs
index 79415ea926..5bc5cacc80 100644
--- a/hadrian/src/Builder.hs
+++ b/hadrian/src/Builder.hs
@@ -6,7 +6,7 @@ module Builder (
     TarMode (..), GitMode (..), Builder (..), Win32TarballsMode(..),
 
     -- * Builder properties
-    builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder,
+    builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilders,
     runBuilder, runBuilderWith, runBuilderWithCmdOptions, getBuilderPath,
     builderEnvironment,
 
@@ -266,7 +266,7 @@ instance H.Builder Builder where
         GhcPkg Dependencies _ -> do
             let input  = fromSingleton msgIn buildInputs
                 msgIn  = "[askBuilder] Exactly one input file expected."
-            needBuilder builder
+            needBuilders [builder]
             path <- H.builderPath builder
             -- we do not depend on bare builders. E.g. we won't depend on `clang`
             -- or `ld` or `ar`.  Unless they are provided with fully qualified paths
@@ -484,7 +484,7 @@ isSpecified = fmap (not . null) . systemBuilderPath
 applyPatch :: FilePath -> FilePath -> Action ()
 applyPatch dir patch = do
     let file = dir -/- patch
-    needBuilder Patch
+    needBuilders [Patch]
     path <- builderPath Patch
     putBuild $ "| Apply patch " ++ file
     quietly $ cmd' [Cwd dir, FileStdin file] [path, "-p0"]
diff --git a/hadrian/src/Hadrian/Builder.hs b/hadrian/src/Hadrian/Builder.hs
index 1f8f8595fa..630c58d603 100644
--- a/hadrian/src/Hadrian/Builder.hs
+++ b/hadrian/src/Hadrian/Builder.hs
@@ -12,7 +12,7 @@
 -- functions that can be used to invoke builders.
 -----------------------------------------------------------------------------
 module Hadrian.Builder (
-    Builder (..), BuildInfo (..), needBuilder, runBuilder,
+    Builder (..), BuildInfo (..), needBuilders, runBuilder,
     runBuilderWithCmdOptions, build, buildWithResources, buildWithCmdOptions,
     getBuilderPath, builderEnvironment, askWithResources
     ) where
@@ -26,7 +26,6 @@ import Hadrian.Oracles.ArgsHash
 import Hadrian.Target
 import Hadrian.Utilities
 
-import Base
 
 -- | This data structure captures all information relevant to invoking a builder.
 data BuildInfo = BuildInfo {
@@ -59,26 +58,23 @@ class ShakeValue b => Builder b where
     runBuilderWith :: b -> BuildInfo -> Action ()
     runBuilderWith builder buildInfo = do
         let args = buildArgs buildInfo
-        needBuilder builder
+        needBuilders [builder]
         path <- builderPath builder
         let msg = if null args then "" else " (" ++ intercalate ", " args ++ ")"
         putBuild $ "| Run " ++ show builder ++ msg
         quietly $ cmd (buildOptions buildInfo) [path] args
 
--- | Make sure a builder and its runtime dependencies are up-to-date.
-needBuilder :: Builder b => b -> Action ()
-needBuilder builder = do
-    path <- builderPath builder
-    deps <- runtimeDependencies builder
+needBuilders :: Builder b => [b] -> Action ()
+needBuilders bs = do
+    paths <- mapM builderPath bs
+    deps <- mapM runtimeDependencies bs
     -- so `path` might be just `gcc`, in which case we won't issue a "need" on
     -- it.  If someone really wants the full qualified path, he ought to pass
     -- CC=$(which gcc) to the configure script.  If CC=gcc was passed, we should
     -- respect that choice and not resolve that via $PATH into a fully qualified
     -- path.  We can only `need` fully qualified path's though, hence we won't
     -- `need` bare tool names.
-    when (path /= takeFileName path) $
-        need [path]
-    need deps
+    need (concat $ [path | path <- paths, path /= takeFileName path] : deps)
 
 -- | Run a builder with a specified list of command line arguments, reading a
 -- list of input files and writing a list of output files. A lightweight version
@@ -117,7 +113,7 @@ doWith :: (Builder b, ShakeValue c)
        -> (Target c b -> Action ())
        -> [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action a
 doWith f info rs opts target args = do
-    needBuilder (builder target)
+    needBuilders [builder target]
     argList <- interpret target args
     trackArgsHash target -- Rerun the rule if the hash of argList has changed.
     info target
@@ -163,6 +159,6 @@ getBuilderPath = expr . builderPath
 -- | Write a builder path into a given environment variable.
 builderEnvironment :: Builder b => String -> b -> Action CmdOption
 builderEnvironment variable builder = do
-    needBuilder builder
+    needBuilders [builder]
     path <- builderPath builder
     return $ AddEnv variable path
diff --git a/hadrian/src/Rules/Nofib.hs b/hadrian/src/Rules/Nofib.hs
index 1e7550b480..99f149d6aa 100644
--- a/hadrian/src/Rules/Nofib.hs
+++ b/hadrian/src/Rules/Nofib.hs
@@ -53,4 +53,4 @@ needNofibDeps = do
     unlitPath <- programPath (vanillaContext Stage1 unlit)
     mtlPath   <- pkgConfFile (vanillaContext Stage1 mtl  )
     need [ unlitPath, mtlPath ]
-    needBuilder (Ghc CompileHs Stage2)
+    needBuilders [Ghc CompileHs Stage2]
diff --git a/hadrian/src/Settings/Builders/Cabal.hs b/hadrian/src/Settings/Builders/Cabal.hs
index f13418a333..03e1f1c5ac 100644
--- a/hadrian/src/Settings/Builders/Cabal.hs
+++ b/hadrian/src/Settings/Builders/Cabal.hs
@@ -112,16 +112,15 @@ commonCabalArgs stage = do
             , arg "--htmldir"
             , arg $ "${pkgroot}/../../doc/html/libraries/" ++ package_id
 
-            , withStaged $ Ghc CompileHs
+            -- These trigger a need on each dependency, so every important to need
+            -- them in parallel or  it linearises the build of Ghc and GhcPkg
+            , withStageds [Ghc CompileHs, GhcPkg Update, Cc CompileC, Ar Pack]
             , withBuilderArgs (Ghc CompileHs stage)
-            , withStaged (GhcPkg Update)
             , withBuilderArgs (GhcPkg Update stage)
             , bootPackageDatabaseArgs
             , libraryArgs
             , bootPackageConstraints
-            , withStaged $ Cc CompileC
             , notStage0 ? with (Ld stage)
-            , withStaged (Ar Pack)
             , with Alex
             , with Happy
             -- Update Target.trackArgument if changing these:
@@ -244,16 +243,23 @@ withBuilderArgs b = case b of
 
 -- | Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
 with :: Builder -> Args
-with b = do
-    path <- getBuilderPath b
-    if null path then mempty else do
-        top <- expr topDirectory
-        expr $ needBuilder b
+with b = withs [b]
+
+-- | Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
+withs :: [Builder] -> Args
+withs bs = do
+    paths <- filter (not . null . snd) <$> mapM (\b -> (b,) <$> getBuilderPath b) bs
+    let bs = map fst paths
+    expr $ (needBuilders bs)
+    top <- expr topDirectory
+    mconcat $ map (\(b, path) ->
         -- Do not inject top, if we have a bare name. E.g. do not turn
         -- `ar` into `$top/ar`. But let `ar` be `ar` as found on $PATH.
         arg  $ withBuilderKey b ++ unifyPath (if path /= takeFileName path
                                               then top </> path
-                                              else path)
+                                              else path)) paths
 
-withStaged :: (Stage -> Builder) -> Args
-withStaged sb = with . sb =<< getStage
+withStageds :: [Stage -> Builder] -> Args
+withStageds sb = do
+  st <- getStage
+  withs (map (\f -> f st) sb)