summaryrefslogtreecommitdiff
path: root/compiler/GHC/Driver
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2021-11-19 12:39:45 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-12-14 20:53:51 -0500
commit5686f47ba1866094a1546473ae2f0c523fb20d9e (patch)
tree97c2ba629c19186cccbf1cedfc295dcd00406fcf /compiler/GHC/Driver
parent71ecb55b0b3ada2c9841dbc9f4a36fed52eb652e (diff)
downloadhaskell-5686f47ba1866094a1546473ae2f0c523fb20d9e.tar.gz
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.
Diffstat (limited to 'compiler/GHC/Driver')
-rw-r--r--compiler/GHC/Driver/Phases.hs15
-rw-r--r--compiler/GHC/Driver/Pipeline.hs14
-rw-r--r--compiler/GHC/Driver/Pipeline/Execute.hs29
-rw-r--r--compiler/GHC/Driver/Session.hs7
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