Hadrian: Generate GHC wrapper scripts

This is a temporary workaround for #16534. We generate wrapper scripts
<build-root>/ghc-stage1 and <build-root>/ghc-stage2 that can be used to
run Stage1 and Stage2 GHCs with the right arguments.

See https://gitlab.haskell.org/ghc/ghc/issues/16534.

2 files changed, 21 insertions, 1 deletions

diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
index d9fa167b50..78e3790d48 100644
--- a/hadrian/src/Rules.hs
+++ b/hadrian/src/Rules.hs
@@ -83,7 +83,12 @@ topLevelTargets = action $ do
     targets <- concatForM buildStages $ \stage -> do
         packages <- stagePackages stage
         mapM (path stage) packages
-    need targets
+
+    -- Why we need wrappers: https://gitlab.haskell.org/ghc/ghc/issues/16534.
+    root <- buildRoot
+    let wrappers = [ root -/- ("ghc-" ++ stageString s) | s <- [Stage1 ..]
+                                                        , s < finalStage ]
+    need (targets ++ wrappers)
   where
     -- either the package database config file for libraries or
     -- the programPath for programs. However this still does
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index 032f6a68c1..ba35e03d9d 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -170,6 +170,10 @@ copyRules = do
 generateRules :: Rules ()
 generateRules = do
     root <- buildRootRules
+
+    (root -/- "ghc-stage1") <~ ghcWrapper Stage1
+    (root -/- "ghc-stage2") <~ ghcWrapper Stage2
+
     priority 2.0 $ (root -/- generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
     priority 2.0 $ (root -/- generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
     priority 2.0 $ (root -/- generatedDir -/-  "ghcversion.h") <~ generateGhcVersionH
@@ -190,6 +194,17 @@ emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
 
 -- Generators
 
+-- | GHC wrapper scripts used for passing the path to the right package database
+-- when invoking in-tree GHC executables.
+ghcWrapper :: Stage -> Expr String
+ghcWrapper Stage0 = error "Stage0 GHC does not require a wrapper script to run."
+ghcWrapper stage  = do
+    dbPath  <- expr $ packageDbPath stage
+    ghcPath <- expr $ programPath (vanillaContext (pred stage) ghc)
+    return $ unwords $ map show $ [ ghcPath ]
+                               ++ [ "-package-db " ++ dbPath | stage == Stage1 ]
+                               ++ [ "$@" ]
+
 -- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
 -- the resulting 'String' is a valid C preprocessor identifier.
 cppify :: String -> String