summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2022-08-22 11:21:57 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-09-14 17:17:04 -0400
commite470e91f7dca7c85cc77508b1140a23722702c06 (patch)
treefa64ab2a66c5425dd3980e7fba91c3a5c343051a
parent6515c32b6616645918e7ea95db59b0467df12bfb (diff)
downloadhaskell-e470e91f7dca7c85cc77508b1140a23722702c06.tar.gz
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
-rw-r--r--hadrian/src/Builder.hs6
-rw-r--r--hadrian/src/Hadrian/Builder.hs22
-rw-r--r--hadrian/src/Rules/Nofib.hs2
-rw-r--r--hadrian/src/Settings/Builders/Cabal.hs30
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)