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.

1 files changed, 15 insertions, 0 deletions

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