Refactor handling of object merging

Previously to merge a set of object files we would invoke the linker as
usual, adding -r to the command-line. However, this can result in
non-sensical command-lines which causes lld to balk (#17962).

To avoid this we introduce a new tool setting into GHC, -pgmlm, which is
the linker which we use to merge object files.

5 files changed, 63 insertions, 35 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 36010a76af..e422624fa6 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -2133,6 +2133,23 @@ We must enable bigobj output in a few places:
 
 Unfortunately the big object format is not supported on 32-bit targets so
 none of this can be used in that case.
+
+
+Note [Merging object files for GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHCi can usually loads standard linkable object files using GHC's linker
+implementation. However, most users build their projects with -split-sections,
+meaning that such object files can have an extremely high number of sections.
+As the linker must map each of these sections individually, loading such object
+files is very inefficient.
+
+To avoid this inefficiency, we use the linker's `-r` flag and a linker script
+to produce a merged relocatable object file. This file will contain a singe
+text section section and can consequently be mapped far more efficiently. As
+gcc tends to do unpredictable things to our linker command line, we opt to
+invoke ld directly in this case, in contrast to our usual strategy of linking
+via gcc.
+
 -}
 
 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
@@ -2140,34 +2157,13 @@ joinObjectFiles dflags o_files output_fn = do
   let toolSettings' = toolSettings dflags
       ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
       osInfo = platformOS (targetPlatform dflags)
-      ld_r args cc = GHC.SysTools.runLink dflags ([
-                       GHC.SysTools.Option "-nostdlib",
-                       GHC.SysTools.Option "-Wl,-r"
-                     ]
-                        -- See Note [No PIE while linking] in GHC.Driver.Session
-                     ++ (if toolSettings_ccSupportsNoPie toolSettings'
-                          then [GHC.SysTools.Option "-no-pie"]
-                          else [])
-
-                     ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
-                          then []
-                          else [GHC.SysTools.Option "-nodefaultlibs"])
-                     ++ (if osInfo == OSFreeBSD
-                          then [GHC.SysTools.Option "-L/usr/lib"]
-                          else [])
-                        -- gcc on sparc sets -Wl,--relax implicitly, but
-                        -- -r and --relax are incompatible for ld, so
-                        -- disable --relax explicitly.
-                     ++ (if platformArch (targetPlatform dflags)
-                                `elem` [ArchSPARC, ArchSPARC64]
-                         && ldIsGnuLd
-                            then [GHC.SysTools.Option "-Wl,-no-relax"]
-                            else [])
+      ld_r args = GHC.SysTools.runMergeObjects dflags (
                         -- See Note [Produce big objects on Windows]
-                     ++ [ GHC.SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"
-                        | OSMinGW32 == osInfo
-                        , not $ target32Bit (targetPlatform dflags)
-                        ]
+                        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
                      ++ [ GHC.SysTools.Option "-o",
                           GHC.SysTools.FileOption "" output_fn ]
@@ -2176,25 +2172,24 @@ joinObjectFiles dflags o_files output_fn = do
       -- suppress the generation of the .note.gnu.build-id section,
       -- which we don't need and sometimes causes ld to emit a
       -- warning:
-      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["-Wl,--build-id=none"]
+      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]
                   | otherwise                     = []
 
-  ccInfo <- getCompilerInfo dflags
   if ldIsGnuLd
      then do
           script <- newTempName dflags TFL_CurrentModule "ldscript"
           cwd <- getCurrentDirectory
           let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
           writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
-          ld_r [GHC.SysTools.FileOption "" script] ccInfo
+          ld_r [GHC.SysTools.FileOption "" script]
      else if toolSettings_ldSupportsFilelist toolSettings'
      then do
           filelist <- newTempName dflags TFL_CurrentModule "filelist"
           writeFile filelist $ unlines o_files
-          ld_r [GHC.SysTools.Option "-Wl,-filelist",
-                GHC.SysTools.FileOption "-Wl," filelist] ccInfo
+          ld_r [GHC.SysTools.Option "-filelist",
+                GHC.SysTools.FileOption "" filelist]
      else do
-          ld_r (map (GHC.SysTools.FileOption "") o_files) ccInfo
+          ld_r (map (GHC.SysTools.FileOption "") o_files)
 
 -- -----------------------------------------------------------------------------
 -- Misc.
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 01555dff8f..795cbf2256 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -102,6 +102,7 @@ module GHC.Driver.Session (
         sPgm_c,
         sPgm_a,
         sPgm_l,
+        sPgm_lm,
         sPgm_dll,
         sPgm_T,
         sPgm_windres,
@@ -120,6 +121,7 @@ module GHC.Driver.Session (
         sOpt_cxx,
         sOpt_a,
         sOpt_l,
+        sOpt_lm,
         sOpt_windres,
         sOpt_lo,
         sOpt_lc,
@@ -142,10 +144,10 @@ module GHC.Driver.Session (
         ghcUsagePath, ghciUsagePath, topDir, tmpDir,
         versionedAppDir, versionedFilePath,
         extraGccViaCFlags, globalPackageDatabasePath,
-        pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T,
+        pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,
         pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc,
         pgm_lcc, pgm_i,
-        opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_i,
+        opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,
         opt_P_signature,
         opt_windres, opt_lo, opt_lc, opt_lcc,
 
@@ -940,6 +942,8 @@ pgm_a                 :: DynFlags -> (String,[Option])
 pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags
 pgm_l                 :: DynFlags -> (String,[Option])
 pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags
+pgm_lm                 :: DynFlags -> (String,[Option])
+pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags
 pgm_dll               :: DynFlags -> (String,[Option])
 pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags
 pgm_T                 :: DynFlags -> String
@@ -986,6 +990,8 @@ opt_a dflags= toolSettings_opt_a $ toolSettings dflags
 opt_l                 :: DynFlags -> [String]
 opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)
             ++ toolSettings_opt_l (toolSettings dflags)
+opt_lm                :: DynFlags -> [String]
+opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags
 opt_windres           :: DynFlags -> [String]
 opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags
 opt_lcc                :: DynFlags -> [String]
diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs
index 49a2018252..e698f47dea 100644
--- a/compiler/GHC/Settings.hs
+++ b/compiler/GHC/Settings.hs
@@ -28,6 +28,7 @@ module GHC.Settings
   , sPgm_c
   , sPgm_a
   , sPgm_l
+  , sPgm_lm
   , sPgm_dll
   , sPgm_T
   , sPgm_windres
@@ -46,6 +47,7 @@ module GHC.Settings
   , sOpt_cxx
   , sOpt_a
   , sOpt_l
+  , sOpt_lm
   , sOpt_windres
   , sOpt_lo
   , sOpt_lc
@@ -99,6 +101,7 @@ data ToolSettings = ToolSettings
   , toolSettings_pgm_c       :: String
   , toolSettings_pgm_a       :: (String, [Option])
   , toolSettings_pgm_l       :: (String, [Option])
+  , toolSettings_pgm_lm      :: (String, [Option])
   , toolSettings_pgm_dll     :: (String, [Option])
   , toolSettings_pgm_T       :: String
   , toolSettings_pgm_windres :: String
@@ -124,6 +127,7 @@ data ToolSettings = ToolSettings
   , toolSettings_opt_cxx           :: [String]
   , toolSettings_opt_a             :: [String]
   , toolSettings_opt_l             :: [String]
+  , toolSettings_opt_lm            :: [String]
   , toolSettings_opt_windres       :: [String]
   , -- | LLVM: llvm optimiser
     toolSettings_opt_lo            :: [String]
@@ -200,6 +204,8 @@ sPgm_a :: Settings -> (String, [Option])
 sPgm_a = toolSettings_pgm_a . sToolSettings
 sPgm_l :: Settings -> (String, [Option])
 sPgm_l = toolSettings_pgm_l . sToolSettings
+sPgm_lm :: Settings -> (String, [Option])
+sPgm_lm = toolSettings_pgm_lm . sToolSettings
 sPgm_dll :: Settings -> (String, [Option])
 sPgm_dll = toolSettings_pgm_dll . sToolSettings
 sPgm_T :: Settings -> String
@@ -236,6 +242,8 @@ sOpt_a :: Settings -> [String]
 sOpt_a = toolSettings_opt_a . sToolSettings
 sOpt_l :: Settings -> [String]
 sOpt_l = toolSettings_opt_l . sToolSettings
+sOpt_lm :: Settings -> [String]
+sOpt_lm = toolSettings_opt_lm . sToolSettings
 sOpt_windres :: Settings -> [String]
 sOpt_windres = toolSettings_opt_windres . sToolSettings
 sOpt_lo :: Settings -> [String]
diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs
index d1ec388195..a3479ca2b5 100644
--- a/compiler/GHC/Settings/IO.hs
+++ b/compiler/GHC/Settings/IO.hs
@@ -137,6 +137,8 @@ initSettings top_dir = do
         as_args  = map Option cc_args
         ld_prog  = cc_prog
         ld_args  = map Option (cc_args ++ words cc_link_args_str)
+  ld_r_prog <- getSetting "Merge objects command"
+  ld_r_args <- getSetting "Merge objects flags"
 
   llvmTarget <- getSetting "LLVM target"
 
@@ -183,6 +185,7 @@ initSettings top_dir = do
       , toolSettings_pgm_c   = cc_prog
       , toolSettings_pgm_a   = (as_prog, as_args)
       , toolSettings_pgm_l   = (ld_prog, ld_args)
+      , toolSettings_pgm_lm  = (ld_r_prog, map Option $ words ld_r_args)
       , toolSettings_pgm_dll = (mkdll_prog,mkdll_args)
       , toolSettings_pgm_T   = touch_path
       , toolSettings_pgm_windres = windres_path
@@ -201,6 +204,7 @@ initSettings top_dir = do
       , toolSettings_opt_cxx     = cxx_args
       , toolSettings_opt_a       = []
       , toolSettings_opt_l       = []
+      , toolSettings_opt_lm      = []
       , toolSettings_opt_windres = []
       , toolSettings_opt_lcc     = []
       , toolSettings_opt_lo      = []
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
index 794a12b913..f9962284f9 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ b/compiler/GHC/SysTools/Tasks.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
 -----------------------------------------------------------------------------
 --
 -- Tasks running external programs for SysTools
@@ -299,6 +300,20 @@ ld: warning: symbol referencing errors
     ld_postfix = tail . snd . ld_warn_break
     ld_warning_found = not . null . snd . ld_warn_break
 
+-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
+runMergeObjects :: DynFlags -> [Option] -> IO ()
+runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do
+  let (p,args0) = pgm_lm dflags
+      optl_args = map Option (getOpts dflags opt_lm)
+      args2     = args0 ++ args ++ optl_args
+  -- N.B. Darwin's ld64 doesn't support response files. Consequently we only
+  -- use them on Windows where they are truly necessary.
+#if defined(mingw32_HOST_OS)
+  mb_env <- getGccEnv args2
+  runSomethingResponseFile dflags id "Merge objects" p args2 mb_env
+#else
+  runSomething dflags "Merge objects" p args2
+#endif
 
 runLibtool :: DynFlags -> [Option] -> IO ()
 runLibtool dflags args = traceToolCommand dflags "libtool" $ do