ghc-bin: Add --merge-objs mode

This adds a new mode, `--merge-objs`, which can be used to produce
merged GHCi library objects.

As future work we will rip out the object-merging logic in Hadrian and
Cabal and instead use this mode.

Closes #20712.

4 files changed, 38 insertions, 27 deletions

diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs
index 2b4e234d12..31a1e45361 100644
--- a/compiler/GHC/Driver/Phases.hs
+++ b/compiler/GHC/Driver/Phases.hs
@@ -66,19 +66,20 @@ import System.FilePath
    C compiler (opt.)      | .hc or .c     | -S            | .s
    assembler              | .s  or .S     | -c            | .o
    linker                 | other         | -             | a.out
+   linker (merge objects) | other         | -             | .o
 -}
 
 -- Phases we can actually stop after
-data StopPhase = StopPreprocess -- -E
-               | StopC  -- -C
-               | StopAs -- -S
-               | NoStop -- -c
+data StopPhase = StopPreprocess -- ^ @-E@
+               | StopC          -- ^ @-C@
+               | StopAs         -- ^ @-S@
+               | NoStop         -- ^ @-c@
 
 stopPhaseToPhase :: StopPhase -> Phase
 stopPhaseToPhase StopPreprocess = anyHsc
-stopPhaseToPhase StopC   = HCc
-stopPhaseToPhase StopAs  = As False
-stopPhaseToPhase NoStop  = StopLn
+stopPhaseToPhase StopC          = HCc
+stopPhaseToPhase StopAs         = As False
+stopPhaseToPhase NoStop         = StopLn
 
 -- | Untyped Phase description
 data Phase
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 92782176b2..22bd9c3280 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -378,9 +378,10 @@ link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =
   case linkHook hooks of
       Nothing -> case ghcLink of
           NoLink        -> return Succeeded
-          LinkBinary    -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt
-          LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt
-          LinkDynLib    -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt
+          LinkBinary    -> normal_link
+          LinkStaticLib -> normal_link
+          LinkDynLib    -> normal_link
+          LinkMergedObj -> normal_link
           LinkInMemory
               | platformMisc_ghcWithInterpreter $ platformMisc dflags
               -> -- Not Linking...(demand linker will do the job)
@@ -388,6 +389,8 @@ link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =
               | otherwise
               -> panicBadLink LinkInMemory
       Just h  -> h ghcLink dflags batch_attempt_linking hpt
+  where
+    normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking hpt
 
 
 panicBadLink :: GhcLink -> a
@@ -559,6 +562,11 @@ doLink hsc_env o_files =
         LinkBinary    -> linkBinary         logger tmpfs dflags unit_env o_files []
         LinkStaticLib -> linkStaticLib      logger       dflags unit_env o_files []
         LinkDynLib    -> linkDynLibCheck    logger tmpfs dflags unit_env o_files []
+        LinkMergedObj
+          | Just out <- outputFile dflags
+          , let objs = [ f | FileOption _ f <- ldInputs dflags ]
+                      -> joinObjectFiles hsc_env (o_files ++ objs) out
+          | otherwise -> panic "Output path must be specified for LinkMergedObj"
         other         -> panicBadLink other
 
 -----------------------------------------------------------------------------
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index ef311c64ff..2c371d17c9 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -165,10 +165,7 @@ runMergeForeign _pipe_env hsc_env input_fn foreign_os = do
                               (tmpDir (hsc_dflags hsc_env))
                               TFL_CurrentModule "o"
          copyFile input_fn new_o
-         let dflags = hsc_dflags hsc_env
-             logger = hsc_logger hsc_env
-         let tmpfs = hsc_tmpfs hsc_env
-         joinObjectFiles logger tmpfs dflags (new_o : foreign_os) input_fn
+         joinObjectFiles hsc_env (new_o : foreign_os) input_fn
          return input_fn
 
 runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
@@ -1098,7 +1095,7 @@ enabled in the toolchain:
 
 We must enable bigobj output in a few places:
 
- * When merging object files (GHC.Driver.Pipeline.joinObjectFiles)
+ * When merging object files (GHC.Driver.Pipeline.Execute.joinObjectFiles)
 
  * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...))
 
@@ -1123,19 +1120,12 @@ via gcc.
 
 -}
 
-joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO ()
-joinObjectFiles logger tmpfs dflags o_files output_fn = do
+joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()
+joinObjectFiles hsc_env o_files output_fn = do
   let toolSettings' = toolSettings dflags
       ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
-      osInfo = platformOS (targetPlatform dflags)
-      ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags (
-                        -- See Note [Produce big objects on Windows]
-                        concat
-                          [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]
-                          | OSMinGW32 == osInfo
-                          , not $ target32Bit (targetPlatform dflags)
-                          ]
-                     ++ map GHC.SysTools.Option ld_build_id
+      ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
+                        map GHC.SysTools.Option ld_build_id
                      ++ [ GHC.SysTools.Option "-o",
                           GHC.SysTools.FileOption "" output_fn ]
                      ++ args)
@@ -1144,7 +1134,7 @@ joinObjectFiles logger tmpfs dflags o_files output_fn = do
       -- which we don't need and sometimes causes ld to emit a
       -- warning:
       ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]
-                  | otherwise                     = []
+                  | otherwise                                    = []
 
   if ldIsGnuLd
      then do
@@ -1161,6 +1151,11 @@ joinObjectFiles logger tmpfs dflags o_files output_fn = do
                 GHC.SysTools.FileOption "" filelist]
      else
           ld_r (map (GHC.SysTools.FileOption "") o_files)
+  where
+    dflags = hsc_dflags hsc_env
+    tmpfs = hsc_tmpfs hsc_env
+    logger = hsc_logger hsc_env
+
 
 -----------------------------------------------------------------------------
 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 232740dfe4..33b27c2f9f 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -917,6 +917,7 @@ data GhcLink
                         --   bytecode and object code).
   | LinkDynLib          -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)
   | LinkStaticLib       -- ^ Link objects into a static lib
+  | LinkMergedObj       -- ^ Link objects into a merged "GHCi object"
   deriving (Eq, Show)
 
 isNoLink :: GhcLink -> Bool
@@ -2174,6 +2175,8 @@ dynamic_flags_deps = [
         (noArg (\d -> d { ghcLink=LinkDynLib }))
   , make_ord_flag defGhcFlag "staticlib"
         (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib })))
+  , make_ord_flag defGhcFlag "merge-objs"
+        (noArg (\d -> d { ghcLink=LinkMergedObj }))
   , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)
   , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)
 
@@ -4665,6 +4668,10 @@ makeDynFlagsConsistent dflags
     = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}
          "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"
 
+ | LinkMergedObj <- ghcLink dflags
+ , Nothing <- outputFile dflags
+ = pgmError "--output must be specified when using --merge-objs"
+
  | otherwise = (dflags, [])
     where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
           loop updated_dflags warning