hadrian: Add multi:<pkg> and multi targets for starting a multi-replwip/hadrian-multi

This patch adds support to hadrian for starting a multi-repl containing
all the packages which stage0 can build. In particular, there is the new
user-facing command:

```
./hadrian/ghci-multi
```

which when executed will start a multi-repl containing the `ghc` package
and all it's dependencies.

This is implemented by two new hadrian targets:

```
./hadrian/build multi:<pkg>
```

Construct the arguments for a multi-repl session where the top-level
package is <pkg>. For example, `./hadrian/ghci-multi` is implemented
using `multi:ghc` target.

There is also the `multi` command which constructs a repl for everything
in stage0 which we can build.

8 files changed, 138 insertions, 30 deletions

diff --git a/configure.ac b/configure.ac
index e6c9ed6ec7..71b5f680cf 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1179,7 +1179,7 @@ fi
 # Create the configuration for the Hadrian build system if it is present
 if test -e hadrian/cfg/system.config.in; then
     AC_CONFIG_FILES([hadrian/cfg/system.config])
-    AC_CONFIG_FILES([hadrian/ghci-cabal hadrian/ghci-stack])
+    AC_CONFIG_FILES([hadrian/ghci-cabal hadrian/ghci-stack hadrian/ghci-multi-cabal])
 fi
 
 # We got caught by
diff --git a/hadrian/.gitignore b/hadrian/.gitignore
index 360b19cbd7..d5aa7c0163 100644
--- a/hadrian/.gitignore
+++ b/hadrian/.gitignore
@@ -1,6 +1,7 @@
 # generated by the configure script
 cfg/system.config
 /ghci-stack
+/ghci-multi-cabal
 /ghci-cabal
 
 # build.bat and build specific
diff --git a/hadrian/README.md b/hadrian/README.md
index 6db6073551..388dc17ce4 100644
--- a/hadrian/README.md
+++ b/hadrian/README.md
@@ -193,6 +193,15 @@ build in parallel.
 ./hadrian/ghci -j8
 ```
 
+##### Multi-Repl Session
+
+You can also use the experimental multi-repl if you are booting with GHC-9.4 or
+later.
+
+```
+./hadrian/ghci-multi
+```
+
 #### Testing
 
 To run GHC testsuite, use `build test`. See
diff --git a/hadrian/ghci-multi b/hadrian/ghci-multi
new file mode 100755
index 0000000000..72c89f96b2
--- /dev/null
+++ b/hadrian/ghci-multi
@@ -0,0 +1,4 @@
+#!/usr/bin/env bash
+
+# By default on Linux/MacOS we build Hadrian using Cabal
+(. "hadrian/ghci-multi-cabal" $@)
diff --git a/hadrian/ghci-multi-cabal.in b/hadrian/ghci-multi-cabal.in
new file mode 100755
index 0000000000..525f5987a4
--- /dev/null
+++ b/hadrian/ghci-multi-cabal.in
@@ -0,0 +1,13 @@
+#!/usr/bin/env sh
+
+GHC=@WithGhc@
+if [[ $(printf "9.4.0\n%s\n" $($GHC --numeric-version) | sort -uV | head -n 1) != "9.4.0" ]]; then echo "Multi-repl needs at least GHC-9.4.1"; exit 1; fi
+
+# This file is generated by configure from ghci-multi.in
+
+set -e
+export TOOL_OUTPUT=.hadrian_ghci_multi/ghci_args
+# Replace newlines with spaces, as these otherwise break the ghci invocation on windows.
+CABFLAGS=-v0 "hadrian/build-cabal" multi:ghc --build-root=.hadrian_ghci_multi --flavour=ghc-in-ghci $HADRIAN_ARGS
+GHC_FLAGS="$GHC_FLAGS $(cat $TOOL_OUTPUT | tr '\n\r' ' ')"
+$GHC --interactive $GHC_FLAGS $@ -fno-code -fwrite-interface -hidir=.hadrian_ghci_multi/interface -O0 +RTS -A128m
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
index 079f675b6e..b14edd035c 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
@@ -45,6 +45,9 @@ import qualified Distribution.Utils.ShortText                  as C
 #if !MIN_VERSION_Cabal(3,4,0)
 import qualified Distribution.Types.CondTree                   as C
 #endif
+#if !MIN_VERSION_Cabal(3,5,0)
+import qualified Distribution.Types.ModuleReexport             as C
+#endif
 import qualified Distribution.Verbosity                        as C
 import Hadrian.Expression
 import Hadrian.Haskell.Cabal
@@ -92,13 +95,13 @@ parsePackageData pkg = do
 parseCabalPkgId :: FilePath -> IO String
 parseCabalPkgId file = C.display . C.package . C.packageDescription <$> C.readGenericPackageDescription C.silent file
 
-biModules :: C.PackageDescription -> (C.BuildInfo, [C.ModuleName], Maybe (C.ModuleName, String))
-biModules pd = go [ comp | comp@(bi,_,_) <-
+biModules :: C.PackageDescription -> (C.BuildInfo, [C.ModuleName], Maybe [C.ModuleName], Maybe (C.ModuleName, String))
+biModules pd = go [ comp | comp@(bi,_,_,_) <-
                              (map libBiModules . maybeToList $ C.library pd) ++
                              (map exeBiModules               $ C.executables pd)
                          , C.buildable bi ]
   where
-    libBiModules lib = (C.libBuildInfo lib, C.explicitLibModules lib, Nothing)
+    libBiModules lib = (C.libBuildInfo lib, C.explicitLibModules lib, Just (map C.moduleReexportName (C.reexportedModules lib)),  Nothing)
     exeBiModules exe = (C.buildInfo exe,
                        -- If "main-is: ..." is not a .hs or .lhs file, do not
                        -- inject "Main" into the modules.  This does not respect
@@ -107,7 +110,7 @@ biModules pd = go [ comp | comp@(bi,_,_) <-
                        if takeExtension (C.modulePath exe) `elem` [".hs", ".lhs"]
                            then C.main : C.exeModules exe
                                 -- The module `Main` still need to be kept in `modules` of PD.
-                           else C.exeModules exe,
+                           else C.exeModules exe, Nothing,
                        Just (C.main, C.modulePath exe))
     go []  = error "No buildable component found."
     go [x] = x
@@ -244,7 +247,7 @@ resolveContextData context@Context {..} = do
             -- @library-dirs@ here.
             _ -> error "No (or multiple) GHC rts package is registered!"
 
-        (buildInfo, modules, mainIs) = biModules (C.localPkgDescr lbi')
+        (buildInfo, modules, rexport_modules, mainIs) = biModules (C.localPkgDescr lbi')
 
         classifyMain :: FilePath -> MainSourceType
         classifyMain fp
@@ -259,6 +262,7 @@ resolveContextData context@Context {..} = do
           , mainIs          = main_src
           , modules         = map C.display modules
           , otherModules    = map C.display $ C.otherModules buildInfo
+          , reexportModules = map C.display (concat rexport_modules)
           , srcDirs         =
 #if MIN_VERSION_Cabal(3,5,0)
                               map C.getSymbolicPath
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs
index 664c7de790..756f5082bf 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs
@@ -43,6 +43,7 @@ data ContextData = ContextData
     , mainIs             :: Maybe (String, FilePath)  -- ("Main", filepath)
     , modules            :: [String]
     , otherModules       :: [String]
+    , reexportModules    :: [String]
     , srcDirs            :: [String]
     , depIds             :: [String]
     , depNames           :: [String]
diff --git a/hadrian/src/Rules/ToolArgs.hs b/hadrian/src/Rules/ToolArgs.hs
index d0905d4548..2641188f5b 100644
--- a/hadrian/src/Rules/ToolArgs.hs
+++ b/hadrian/src/Rules/ToolArgs.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ViewPatterns #-}
 module Rules.ToolArgs(toolArgsTarget) where
 
 import qualified Rules.Generate
@@ -13,6 +14,7 @@ import Hadrian.Oracles.Cabal
 import Hadrian.Haskell.Cabal.Type
 import System.Directory (canonicalizePath)
 import System.Environment (lookupEnv)
+import qualified Data.Set as Set
 
 -- | @tool:@ is used by tooling in order to get the arguments necessary
 -- to set up a GHC API session which can compile modules from GHC. When
@@ -25,10 +27,15 @@ import System.Environment (lookupEnv)
 -- that script so that we can load the whole library and executable
 -- components into GHCi.
 --
--- In the future where we have multi-component ghci this code can be
--- modified to supply the right arguments for that. At the moment it is
--- also used for GHC's support for multi-component ghcide (see the
--- `hadrian/hie-bios` script).
+-- The suitable arguments for a multi-component session can be queried using
+-- `multi:<pkg>`, for example `multi:ghc` will create a session which compiles the
+-- `ghc` package and all it's dependencies in a single session. This is what the ./hadrian-multi
+-- script uses to set-up a multi session.
+--
+-- The `multi` target can be used to create a session which loads **everything** that
+-- can be built by stage0 compiler, this is probably more than what you need so best stick
+-- with `multi:ghc` unless you're a pro.
+--
 
 
 -- | A phony target of form `tool:path/to/file.hs` which returns the
@@ -37,6 +44,62 @@ toolArgsTarget :: Rules ()
 toolArgsTarget = do
   phonys (\s -> if "tool:" `isPrefixOf` s then Just (toolRuleBody (drop 5 s)) else Nothing)
 
+  phonys (\s -> if "multi:" `isPrefixOf` s then Just (multiSetup (Just (drop 6 s))) else Nothing)
+
+  "multi" ~> multiSetup Nothing
+
+multiSetup :: Maybe String -> Action ()
+multiSetup pkg_s = do
+  -- Find the targets we want to build.
+  tool_targets <- case pkg_s of
+        Nothing -> return toolTargets
+        Just pkg_s -> case findPackageByName pkg_s of
+                        Just pkg -> (pkg :) . Set.toList <$> pkg_deps pkg
+                        Nothing  -> error $ "Unknown package: " ++ pkg_s
+  -- Get the arguments for all the targets
+  pargs <- mapM one_args tool_targets
+  -- Build any other dependencies (such as generated files)
+  allDeps
+  liftIO $ writeOutput (concatMap (\x -> ["-unit", x]) (map ( "@" <>) pargs))
+
+  where
+    resp_file root p = root </> "multi" </> pkgName p
+
+    pkg_deps pkg = do
+      deps <- readPackageData pkg
+      let immediate_deps = filter (`elem` toolTargets) (packageDependencies deps)
+      trans_deps <- Set.unions <$> mapM pkg_deps immediate_deps
+      return (Set.fromList immediate_deps `Set.union` trans_deps)
+
+    one_args p =  do
+      putProgressInfo ("Computing arguments for " ++ pkgName p)
+      root <- buildRoot
+      let fake_target = target (Context stage0InTree p (if windowsHost then vanilla else dynamic))
+                          (Ghc ToolArgs stage0InTree) [] ["ignored"]
+      arg_list <- interpret fake_target getArgs
+      let c = (Context stage0InTree p (if windowsHost then vanilla else dynamic))
+      -- readContextData has the effect of configuring the package so all
+      -- dependent packages will also be built.
+      cd <- readContextData c
+      let rexp m = ["-reexported-module", m]
+      writeFile' (resp_file root p) (intercalate "\n" (th_hack arg_list
+                                                      ++  modules cd
+                                                      ++ concatMap rexp (reexportModules cd) ))
+      return (resp_file root p)
+
+
+    -- The template-haskell package is compiled with -this-unit-id=template-haskell but
+    -- everything which depends on it depends on `-package-id-template-haskell-2.17.0.0`
+    -- and so the logic for detetecting which home-units depend on what is defeated.
+    -- The workaround here is just to rewrite all the `-package-id` arguments to
+    -- point to `template-haskell` instead which works for the multi-repl case.
+    -- See #20887
+    th_hack :: [String] -> [String]
+    th_hack ((isPrefixOf "-package-id template-haskell" -> True) : xs) = "-package-id" : "template-haskell" : xs
+    th_hack (x:xs) = x : th_hack xs
+    th_hack [] = []
+
+
 toolRuleBody :: FilePath -> Action ()
 toolRuleBody fp = do
   mm <- dirMap
@@ -45,6 +108,12 @@ toolRuleBody fp = do
     Just (_, (p, extra)) -> mkToolTarget extra p
     Nothing -> fail $ "No prefixes matched " ++ show fp ++ " IN\n " ++ show mm
 
+writeOutput :: [String] -> IO ()
+writeOutput args = do
+    liftIO $ lookupEnv "TOOL_OUTPUT" >>= \case
+      Nothing -> putStrLn (intercalate "\n" args)
+      Just out -> writeFile out (intercalate "\n" args)
+
 mkToolTarget :: [String] -> Package -> Action ()
 mkToolTarget es p = do
     -- This builds automatically generated dependencies. Not sure how to do
@@ -54,9 +123,7 @@ mkToolTarget es p = do
     let fake_target = target (Context stage0InTree p (if windowsHost then vanilla else dynamic))
                         (Ghc ToolArgs stage0InTree) [] ["ignored"]
     arg_list <- interpret fake_target getArgs
-    liftIO $ lookupEnv "TOOL_OUTPUT" >>= \case
-      Nothing -> putStrLn (intercalate "\n" (arg_list ++ es))
-      Just out -> writeFile out (intercalate "\n" (arg_list ++ es))
+    liftIO $ writeOutput (arg_list ++ es)
 
 allDeps :: Action ()
 allDeps = do
@@ -71,6 +138,7 @@ allDeps = do
     interpret fake_target Rules.Generate.compilerDependencies >>= need
 
     root <- buildRoot
+    let ghc_prim = buildDir (vanillaContext stage0InTree ghcPrim)
     let dir = buildDir (vanillaContext stage0InTree compiler)
     need [ root -/- dir -/- "GHC" -/- "Settings" -/- "Config.hs" ]
     need [ root -/- dir -/- "GHC" -/- "Parser.hs" ]
@@ -79,31 +147,39 @@ allDeps = do
     need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Parser.hs" ]
     need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Lexer.hs"  ]
 
+    need [ root -/- ghc_prim -/- "GHC" -/- "PrimopWrappers.hs" ]
+
 -- This list is quite a lot like stage0packages but doesn't include
 -- critically the `exe:ghc` component as that depends on the GHC library
 -- which takes a while to compile.
 toolTargets :: [Package]
-toolTargets = [ array
+toolTargets = [ binary
              , bytestring
-             , templateHaskell
-             , containers
-             , deepseq
-             , directory
-             , exceptions
-             , filepath
+             , cabalSyntax
+             , cabal
              , compiler
-             , ghcCompact
-             , ghcPrim
-             --, haskeline
-             , hp2ps
-             , hsc2hs
-             , pretty
+             , directory
              , process
-             , rts
-             , stm
+             , exceptions
+--             , ghc # depends on ghc library
+--             , runGhc # depends on ghc library
+             , ghcBoot
+             , ghcBootTh
+             , ghcHeap
+             , ghci
+--             , ghcPkg  # executable
+--             , haddock # depends on ghc library
+--             , hsc2hs  # executable
+             , hpc
+--             , hpcBin  # executable
+             , mtl
+             , parsec
              , time
-             , unlit
-             , xhtml ]
+             , templateHaskell
+             , text
+             , transformers
+--             , unlit  # executable
+             , unix ]
 
 -- | Create a mapping from files to which component it belongs to.
 dirMap :: Action [(FilePath, (Package, [String]))]