Use static archives as an alternative to object merging

Unfortunately, `lld`'s COFF backend does not currently support object
merging. With ld.bfd having broken support for high image-load base
addresses, it's necessary to find an alternative. Here I introduce
support in the driver for generating static archives, which we use on
Windows instead of object merging.

Closes #21068.

2 files changed, 11 insertions, 7 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 415bb5e38f..ceb4fa0ae0 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -760,14 +760,12 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
       Nothing -> return mlinkable
       Just o_fp -> do
         unlinked_time <- liftIO (liftIO getCurrentTime)
-        final_o <- use (T_MergeForeign pipe_env hsc_env o_fp fos)
-        let !linkable = LM unlinked_time
-                                    (ms_mod mod_sum)
-                                    [DotO final_o]
+        final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
+        let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]
         return (Just linkable)
   return (miface, final_linkable)
 
-asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
+asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m ObjFile
 asPipeline use_cpp pipe_env hsc_env location input_fn = do
   use (T_As use_cpp pipe_env hsc_env location input_fn)
 
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 909102b573..55a1573d92 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -130,7 +130,7 @@ runPhase (T_Cmm pipe_env hsc_env input_fn) = do
   output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
   mstub <- hscCompileCmmFile hsc_env input_fn output_fn
   stub_o <- mapM (compileStub hsc_env) mstub
-  let foreign_os = (maybeToList stub_o)
+  let foreign_os = maybeToList stub_o
   return (foreign_os, output_fn)
 
 runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn
@@ -1117,7 +1117,8 @@ via gcc.
 -}
 
 joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()
-joinObjectFiles hsc_env o_files output_fn = do
+joinObjectFiles hsc_env o_files output_fn
+  | can_merge_objs = do
   let toolSettings' = toolSettings dflags
       ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
       ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
@@ -1147,7 +1148,12 @@ joinObjectFiles hsc_env o_files output_fn = do
                 GHC.SysTools.FileOption "" filelist]
      else
           ld_r (map (GHC.SysTools.FileOption "") o_files)
+
+  | otherwise = do
+  withAtomicRename output_fn $ \tmp_ar ->
+      liftIO $ runAr logger dflags Nothing $ map Option $ ["rc", tmp_ar] ++ o_files
   where
+    can_merge_objs = False -- XXX
     dflags = hsc_dflags hsc_env
     tmpfs = hsc_tmpfs hsc_env
     logger = hsc_logger hsc_env