summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-10-12 12:43:38 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-11-03 17:40:34 -0500
commit14ce454f7294381225b4211dc191a167a386e380 (patch)
tree00dde0d9eeaee019842352560bc42f7147e4abaa /compiler/GHC
parent78f2767d4db5e69a142ac6a408a217b11c35949d (diff)
downloadhaskell-14ce454f7294381225b4211dc191a167a386e380.tar.gz
Linker: reorganize linker related code
Move linker related code into GHC.Linker. Previously it was scattered into GHC.Unit.State, GHC.Driver.Pipeline, GHC.Runtime.Linker, etc. Add documentation in GHC.Linker
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Driver/Backpack.hs2
-rw-r--r--compiler/GHC/Driver/Env.hs6
-rw-r--r--compiler/GHC/Driver/Main.hs17
-rw-r--r--compiler/GHC/Driver/Make.hs11
-rw-r--r--compiler/GHC/Driver/Pipeline.hs375
-rw-r--r--compiler/GHC/HsToCore/Usage.hs2
-rw-r--r--compiler/GHC/Iface/Tidy/StaticPtrTable.hs3
-rw-r--r--compiler/GHC/Linker.hs36
-rw-r--r--compiler/GHC/Linker/Dynamic.hs264
-rw-r--r--compiler/GHC/Linker/ExtraObj.hs (renamed from compiler/GHC/SysTools/ExtraObj.hs)21
-rw-r--r--compiler/GHC/Linker/Loader.hs (renamed from compiler/GHC/Runtime/Linker.hs)523
-rw-r--r--compiler/GHC/Linker/MacOS.hs183
-rw-r--r--compiler/GHC/Linker/Static.hs342
-rw-r--r--compiler/GHC/Linker/Types.hs (renamed from compiler/GHC/Runtime/Linker/Types.hs)83
-rw-r--r--compiler/GHC/Linker/Unit.hs134
-rw-r--r--compiler/GHC/Linker/Windows.hs64
-rw-r--r--compiler/GHC/Runtime/Debugger.hs11
-rw-r--r--compiler/GHC/Runtime/Eval.hs27
-rw-r--r--compiler/GHC/Runtime/Interpreter.hs3
-rw-r--r--compiler/GHC/Runtime/Loader.hs6
-rw-r--r--compiler/GHC/SysTools.hs298
-rw-r--r--compiler/GHC/SysTools/Tasks.hs37
-rw-r--r--compiler/GHC/Unit/Finder.hs2
-rw-r--r--compiler/GHC/Unit/Home/ModInfo.hs2
-rw-r--r--compiler/GHC/Unit/Module/ModGuts.hs2
-rw-r--r--compiler/GHC/Unit/State.hs120
26 files changed, 1382 insertions, 1192 deletions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 332023dd74..d35e32cc27 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -62,7 +62,7 @@ import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary (showModMsg)
import GHC.Unit.Home.ModInfo
-import GHC.Runtime.Linker.Types
+import GHC.Linker.Types
import qualified GHC.LanguageExtensions as LangExt
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index 324177ac0f..f155fc0187 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -30,7 +30,7 @@ import GHC.Unit.Finder.Types
import GHC.Runtime.Context
import GHC.Runtime.Interpreter.Types (Interp)
-import GHC.Runtime.Linker.Types ( DynLinker )
+import GHC.Linker.Types ( Loader )
import GHC.Unit
import GHC.Unit.Module.ModGuts
@@ -172,8 +172,8 @@ data HscEnv
-- ^ target code interpreter (if any) to use for TH and GHCi.
-- See Note [Target code interpreter]
- , hsc_dynLinker :: DynLinker
- -- ^ dynamic linker.
+ , hsc_loader :: Loader
+ -- ^ Loader (dynamic linker)
, hsc_home_unit :: !HomeUnit
-- ^ Home-unit
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 0f5476634e..c8905210ab 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -97,13 +97,14 @@ import GHC.Driver.Config
import GHC.Driver.Hooks
import GHC.Runtime.Context
-import GHC.Runtime.Linker
-import GHC.Runtime.Linker.Types
import GHC.Runtime.Interpreter ( addSptEntry )
import GHC.Runtime.Loader ( initializePlugins )
import GHCi.RemoteTypes ( ForeignHValue )
import GHC.ByteCode.Types
+import GHC.Linker.Loader
+import GHC.Linker.Types
+
import GHC.Hs
import GHC.Hs.Dump
import GHC.Hs.Stats ( ppSourceStats )
@@ -238,7 +239,7 @@ newHscEnv dflags = do
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
- emptyDynLinker <- uninitializedLinker
+ emptyLoader <- uninitializedLoader
return HscEnv { hsc_dflags = dflags
, hsc_targets = []
, hsc_mod_graph = emptyMG
@@ -249,7 +250,7 @@ newHscEnv dflags = do
, hsc_FC = fc_var
, hsc_type_env_var = Nothing
, hsc_interp = Nothing
- , hsc_dynLinker = emptyDynLinker
+ , hsc_loader = emptyLoader
, hsc_home_unit = home_unit
}
@@ -1799,7 +1800,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
prepd_binds data_tycons mod_breaks
let src_span = srcLocSpan interactiveSrcLoc
- liftIO $ linkDecls hsc_env src_span cbc
+ liftIO $ loadDecls hsc_env src_span cbc
{- Load static pointer table entries -}
liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
@@ -1831,7 +1832,7 @@ hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries hsc_env entries = do
let add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry i fpr) = do
- val <- getHValue hsc_env (idName i)
+ val <- loadName hsc_env (idName i)
addSptEntry hsc_env fpr val
mapM_ add_spt_entry entries
@@ -1961,8 +1962,8 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
; bcos <- coreExprToBCOs hsc_env
(icInteractiveModule (hsc_IC hsc_env)) prepd_expr
- {- link it -}
- ; linkExpr hsc_env srcspan bcos }
+ {- load it -}
+ ; loadExpr hsc_env srcspan bcos }
{- **********************************************************************
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 19bef47e42..53ae5897ed 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -36,9 +36,11 @@ module GHC.Driver.Make (
import GHC.Prelude
import GHC.Tc.Utils.Backpack
+import GHC.Tc.Utils.Monad ( initIfaceCheck )
+
+import qualified GHC.Linker.Loader as Linker
+import GHC.Linker.Types
-import qualified GHC.Runtime.Linker as Linker
-import GHC.Runtime.Linker.Types
import GHC.Runtime.Context
import GHC.Driver.Config
@@ -53,9 +55,7 @@ import GHC.Driver.Main
import GHC.Parser.Header
import GHC.Parser.Errors.Ppr
-import GHC.Utils.Error
import GHC.IfaceToCore ( typecheckIface )
-import GHC.Tc.Utils.Monad ( initIfaceCheck )
import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag )
import GHC.Data.Graph.Directed
@@ -63,13 +63,14 @@ import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt
-import GHC.SysTools.FileCleanup
import GHC.Utils.Exception ( tryIO )
import GHC.Utils.Monad ( allM )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
+import GHC.Utils.Error
+import GHC.SysTools.FileCleanup
import GHC.Types.Basic
import GHC.Types.Target
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 2a2d9e294c..d8abadc0e5 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -20,9 +20,6 @@ module GHC.Driver.Pipeline (
-- collection of source files.
oneShot, compileFile,
- -- Interfaces for the batch-mode driver
- linkBinary,
-
-- Interfaces for the compilation manager (interpreted/batch-mode)
preprocess,
compileOne, compileOne',
@@ -32,8 +29,7 @@ module GHC.Driver.Pipeline (
PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
- runPhase, exeFileName,
- maybeCreateManifest,
+ runPhase,
doCpp,
linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
) where
@@ -64,9 +60,14 @@ import GHC.Parser.Header
import GHC.Parser.Errors.Ppr
import GHC.SysTools
-import GHC.SysTools.ExtraObj
import GHC.SysTools.FileCleanup
-import GHC.SysTools.Ar
+
+import GHC.Linker.ExtraObj
+import GHC.Linker.Dynamic
+import GHC.Linker.MacOS
+import GHC.Linker.Unit
+import GHC.Linker.Static
+import GHC.Linker.Types
import GHC.Utils.Outputable
import GHC.Utils.Error
@@ -78,7 +79,6 @@ import GHC.Utils.Exception as Exception
import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList )
import qualified GHC.LanguageExtensions as LangExt
import GHC.Settings
-import GHC.Runtime.Linker.Types
import GHC.Data.Bag ( unitBag )
import GHC.Data.FastString ( mkFastString )
@@ -549,8 +549,8 @@ link' dflags batch_attempt_linking hpt
let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
obj_files = concatMap getOfiles linkables
-
- exe_file = exeFileName staticLink dflags
+ platform = targetPlatform dflags
+ exe_file = exeFileName platform staticLink (outputFile dflags)
linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
@@ -585,7 +585,8 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- if the modification time on the executable is later than the
-- modification times on all of the objects and libraries, then omit
-- linking (unless the -fforce-recomp flag was given).
- let exe_file = exeFileName staticLink dflags
+ let platform = targetPlatform dflags
+ exe_file = exeFileName platform staticLink (outputFile dflags)
e_exe_time <- tryIO $ getModificationUTCTime exe_file
case e_exe_time of
Left _ -> return True
@@ -606,7 +607,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
| Just c <- map (lookupUnitId unit_state) pkg_deps,
lib <- packageHsLibs dflags c ]
- pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
+ pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
if any isNothing pkg_libfiles then return True else do
e_lib_times <- mapM (tryIO . getModificationUTCTime)
(catMaybes pkg_libfiles)
@@ -615,11 +616,11 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
then return True
else checkLinkInfo dflags pkg_deps exe_file
-findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
-findHSLib dflags dirs lib = do
- let batch_lib_file = if WayDyn `notElem` ways dflags
+findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)
+findHSLib platform ws dirs lib = do
+ let batch_lib_file = if WayDyn `notElem` ws
then "lib" ++ lib <.> "a"
- else platformSOName (targetPlatform dflags) lib
+ else platformSOName platform lib
found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
case found of
[] -> return Nothing
@@ -1727,307 +1728,6 @@ getHCFilePackages filename =
_other ->
return []
------------------------------------------------------------------------------
--- Static linking, of .o files
-
--- The list of packages passed to link is the list of packages on
--- which this program depends, as discovered by the compilation
--- manager. It is combined with the list of packages that the user
--- specifies on the command line with -package flags.
---
--- In one-shot linking mode, we can't discover the package
--- dependencies (because we haven't actually done any compilation or
--- read any interface files), so the user must explicitly specify all
--- the packages.
-
-{-
-Note [-Xlinker -rpath vs -Wl,-rpath]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
--Wl takes a comma-separated list of options which in the case of
--Wl,-rpath -Wl,some,path,with,commas parses the path with commas
-as separate options.
-Buck, the build system, produces paths with commas in them.
-
--Xlinker doesn't have this disadvantage and as far as I can tell
-it is supported by both gcc and clang. Anecdotally nvcc supports
--Xlinker, but not -Wl.
--}
-
-linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
-linkBinary = linkBinary' False
-
-linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
-linkBinary' staticLink dflags o_files dep_units = do
- let platform = targetPlatform dflags
- toolSettings' = toolSettings dflags
- verbFlags = getVerbFlags dflags
- output_fn = exeFileName staticLink dflags
- home_unit = mkHomeUnitFromFlags dflags
-
- -- get the full list of packages to link with, by combining the
- -- explicit packages with the auto packages and all of their
- -- dependencies, and eliminating duplicates.
-
- full_output_fn <- if isAbsolute output_fn
- then return output_fn
- else do d <- getCurrentDirectory
- return $ normalise (d </> output_fn)
- pkg_lib_paths <- getUnitLibraryPath
- (initSDocContext dflags defaultUserStyle)
- (unitState dflags)
- home_unit
- (ways dflags)
- dep_units
- let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
- get_pkg_lib_path_opts l
- | osElfTarget (platformOS platform) &&
- dynLibLoader dflags == SystemDependent &&
- WayDyn `elem` ways dflags
- = let libpath = if gopt Opt_RelativeDynlibPaths dflags
- then "$ORIGIN" </>
- (l `makeRelativeTo` full_output_fn)
- else l
- -- See Note [-Xlinker -rpath vs -Wl,-rpath]
- rpath = if gopt Opt_RPath dflags
- then ["-Xlinker", "-rpath", "-Xlinker", libpath]
- else []
- -- Solaris 11's linker does not support -rpath-link option. It silently
- -- ignores it and then complains about next option which is -l<some
- -- dir> as being a directory and not expected object file, E.g
- -- ld: elf error: file
- -- /tmp/ghc-src/libraries/base/dist-install/build:
- -- elf_begin: I/O error: region read: Is a directory
- rpathlink = if (platformOS platform) == OSSolaris2
- then []
- else ["-Xlinker", "-rpath-link", "-Xlinker", l]
- in ["-L" ++ l] ++ rpathlink ++ rpath
- | osMachOTarget (platformOS platform) &&
- dynLibLoader dflags == SystemDependent &&
- WayDyn `elem` ways dflags &&
- gopt Opt_RPath dflags
- = let libpath = if gopt Opt_RelativeDynlibPaths dflags
- then "@loader_path" </>
- (l `makeRelativeTo` full_output_fn)
- else l
- in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
- | otherwise = ["-L" ++ l]
-
- pkg_lib_path_opts <-
- if gopt Opt_SingleLibFolder dflags
- then do
- libs <- getLibs dflags dep_units
- tmpDir <- newTempDir dflags
- sequence_ [ copyFile lib (tmpDir </> basename)
- | (lib, basename) <- libs]
- return [ "-L" ++ tmpDir ]
- else pure pkg_lib_path_opts
-
- let
- dead_strip
- | gopt Opt_WholeArchiveHsLibs dflags = []
- | otherwise = if osSubsectionsViaSymbols (platformOS platform)
- then ["-Wl,-dead_strip"]
- else []
- let lib_paths = libraryPaths dflags
- let lib_path_opts = map ("-L"++) lib_paths
-
- extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
- noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units
-
- let
- (pre_hs_libs, post_hs_libs)
- | gopt Opt_WholeArchiveHsLibs dflags
- = if platformOS platform == OSDarwin
- then (["-Wl,-all_load"], [])
- -- OS X does not have a flag to turn off -all_load
- else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
- | otherwise
- = ([],[])
-
- pkg_link_opts <- do
- (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units
- return $ if staticLink
- then package_hs_libs -- If building an executable really means making a static
- -- library (e.g. iOS), then we only keep the -l options for
- -- HS packages, because libtool doesn't accept other options.
- -- In the case of iOS these need to be added by hand to the
- -- final link in Xcode.
- else other_flags ++ dead_strip
- ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
- ++ extra_libs
- -- -Wl,-u,<sym> contained in other_flags
- -- needs to be put before -l<package>,
- -- otherwise Solaris linker fails linking
- -- a binary with unresolved symbols in RTS
- -- which are defined in base package
- -- the reason for this is a note in ld(1) about
- -- '-u' option: "The placement of this option
- -- on the command line is significant.
- -- This option must be placed before the library
- -- that defines the symbol."
-
- -- frameworks
- pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units
- let framework_opts = getFrameworkOpts dflags platform
-
- -- probably _stub.o files
- let extra_ld_inputs = ldInputs dflags
-
- rc_objs <- maybeCreateManifest dflags output_fn
-
- let link dflags args | staticLink = GHC.SysTools.runLibtool dflags args
- | platformOS platform == OSDarwin
- = GHC.SysTools.runLink dflags args >> GHC.SysTools.runInjectRPaths dflags pkg_lib_paths output_fn
- | otherwise
- = GHC.SysTools.runLink dflags args
-
- link dflags (
- map GHC.SysTools.Option verbFlags
- ++ [ GHC.SysTools.Option "-o"
- , GHC.SysTools.FileOption "" output_fn
- ]
- ++ libmLinkOpts
- ++ map GHC.SysTools.Option (
- []
-
- -- See Note [No PIE when linking]
- ++ picCCOpts dflags
-
- -- Permit the linker to auto link _symbol to _imp_symbol.
- -- This lets us link against DLLs without needing an "import library".
- ++ (if platformOS platform == OSMinGW32
- then ["-Wl,--enable-auto-import"]
- else [])
-
- -- '-no_compact_unwind'
- -- C++/Objective-C exceptions cannot use optimised
- -- stack unwinding code. The optimised form is the
- -- default in Xcode 4 on at least x86_64, and
- -- without this flag we're also seeing warnings
- -- like
- -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
- -- on x86.
- ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' &&
- not staticLink &&
- (platformOS platform == OSDarwin) &&
- case platformArch platform of
- ArchX86 -> True
- ArchX86_64 -> True
- ArchARM {} -> True
- ArchARM64 -> True
- _ -> False
- then ["-Wl,-no_compact_unwind"]
- else [])
-
- -- '-Wl,-read_only_relocs,suppress'
- -- ld gives loads of warnings like:
- -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
- -- when linking any program. We're not sure
- -- whether this is something we ought to fix, but
- -- for now this flags silences them.
- ++ (if platformOS platform == OSDarwin &&
- platformArch platform == ArchX86 &&
- not staticLink
- then ["-Wl,-read_only_relocs,suppress"]
- else [])
-
- ++ (if toolSettings_ldIsGnuLd toolSettings' &&
- not (gopt Opt_WholeArchiveHsLibs dflags)
- then ["-Wl,--gc-sections"]
- else [])
-
- ++ o_files
- ++ lib_path_opts)
- ++ extra_ld_inputs
- ++ map GHC.SysTools.Option (
- rc_objs
- ++ framework_opts
- ++ pkg_lib_path_opts
- ++ extraLinkObj:noteLinkObjs
- ++ pkg_link_opts
- ++ pkg_framework_opts
- ++ (if platformOS platform == OSDarwin
- -- dead_strip_dylibs, will remove unused dylibs, and thus save
- -- space in the load commands. The -headerpad is necessary so
- -- that we can inject more @rpath's later for the left over
- -- libraries during runInjectRpaths phase.
- --
- -- See Note [Dynamic linking on macOS].
- then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ]
- else [])
- ))
-
-exeFileName :: Bool -> DynFlags -> FilePath
-exeFileName staticLink dflags
- | Just s <- outputFile dflags =
- case platformOS (targetPlatform dflags) of
- OSMinGW32 -> s <?.> "exe"
- _ -> if staticLink
- then s <?.> "a"
- else s
- | otherwise =
- if platformOS (targetPlatform dflags) == OSMinGW32
- then "main.exe"
- else if staticLink
- then "liba.a"
- else "a.out"
- where s <?.> ext | null (takeExtension s) = s <.> ext
- | otherwise = s
-
-maybeCreateManifest
- :: DynFlags
- -> FilePath -- filename of executable
- -> IO [FilePath] -- extra objects to embed, maybe
-maybeCreateManifest dflags exe_filename
- | platformOS (targetPlatform dflags) == OSMinGW32 &&
- gopt Opt_GenManifest dflags
- = do let manifest_filename = exe_filename <.> "manifest"
-
- writeFile manifest_filename $
- "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
- " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
- " <assemblyIdentity version=\"1.0.0.0\"\n"++
- " processorArchitecture=\"X86\"\n"++
- " name=\"" ++ dropExtension exe_filename ++ "\"\n"++
- " type=\"win32\"/>\n\n"++
- " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
- " <security>\n"++
- " <requestedPrivileges>\n"++
- " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
- " </requestedPrivileges>\n"++
- " </security>\n"++
- " </trustInfo>\n"++
- "</assembly>\n"
-
- -- Windows will find the manifest file if it is named
- -- foo.exe.manifest. However, for extra robustness, and so that
- -- we can move the binary around, we can embed the manifest in
- -- the binary itself using windres:
- if not (gopt Opt_EmbedManifest dflags) then return [] else do
-
- rc_filename <- newTempName dflags TFL_CurrentModule "rc"
- rc_obj_filename <-
- newTempName dflags TFL_GhcSession (objectSuf dflags)
-
- writeFile rc_filename $
- "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
- -- magic numbers :-)
- -- show is a bit hackish above, but we need to escape the
- -- backslashes in the path.
-
- runWindres dflags $ map GHC.SysTools.Option $
- ["--input="++rc_filename,
- "--output="++rc_obj_filename,
- "--output-format=coff"]
- -- no FileOptions here: windres doesn't like seeing
- -- backslashes, apparently
-
- removeFile manifest_filename
-
- return [rc_obj_filename]
- | otherwise = return []
-
linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck dflags o_files dep_units = do
@@ -2038,47 +1738,6 @@ linkDynLibCheck dflags o_files dep_units = do
text " Call hs_init_ghc() from your main() function to set these options.")
linkDynLib dflags o_files dep_units
--- | Linking a static lib will not really link anything. It will merely produce
--- a static archive of all dependent static libraries. The resulting library
--- will still need to be linked with any remaining link flags.
-linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO ()
-linkStaticLib dflags o_files dep_units = do
- let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
- modules = o_files ++ extra_ld_inputs
- output_fn = exeFileName True dflags
- home_unit = mkHomeUnitFromFlags dflags
-
- full_output_fn <- if isAbsolute output_fn
- then return output_fn
- else do d <- getCurrentDirectory
- return $ normalise (d </> output_fn)
- output_exists <- doesFileExist full_output_fn
- (when output_exists) $ removeFile full_output_fn
-
- pkg_cfgs_init <- getPreloadUnitsAnd
- (initSDocContext dflags defaultUserStyle)
- (unitState dflags)
- home_unit
- dep_units
-
- let pkg_cfgs
- | gopt Opt_LinkRts dflags
- = pkg_cfgs_init
- | otherwise
- = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init
-
- archives <- concatMapM (collectArchives dflags) pkg_cfgs
-
- ar <- foldl mappend
- <$> (Archive <$> mapM loadObj modules)
- <*> mapM loadAr archives
-
- if toolSettings_ldIsGnuLd (toolSettings dflags)
- then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
- else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
-
- -- run ranlib over the archive. write*Ar does *not* create the symbol index.
- runRanlib dflags [GHC.SysTools.FileOption "" output_fn]
-- -----------------------------------------------------------------------------
-- Running CPP
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index bf0e77911e..2c49aea43b 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -37,6 +37,8 @@ import GHC.Unit.Module.Imported
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
+import GHC.Linker.Unit
+
import GHC.Data.Maybe
import Control.Monad (filterM)
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
index 8f83e35333..c3c032cd9b 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -142,7 +142,8 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Builtin.Names
import GHC.Tc.Utils.Env (lookupGlobal)
-import GHC.Runtime.Linker.Types
+
+import GHC.Linker.Types
import GHC.Types.Name
import GHC.Types.Id
diff --git a/compiler/GHC/Linker.hs b/compiler/GHC/Linker.hs
new file mode 100644
index 0000000000..8e4ca4de62
--- /dev/null
+++ b/compiler/GHC/Linker.hs
@@ -0,0 +1,36 @@
+module GHC.Linker
+ (
+ )
+where
+
+import GHC.Prelude ()
+ -- We need this dummy dependency for the make build system. Otherwise it
+ -- tries to load GHC.Types which may not be built yet.
+
+-- Note [Linkers and loaders]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Linkers are used to produce linked objects (.so, executables); loaders are
+-- used to link in memory (e.g., in GHCi) with the already loaded libraries
+-- (ghc-lib, rts, etc.).
+--
+-- Linking can usually be done with an external linker program ("ld"), but
+-- loading is more tricky:
+--
+-- * Fully dynamic:
+-- when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.)
+-- and the modules to load are also compiled for dynamic linking, a
+-- solution is to fully rely on external tools:
+--
+-- 1) link a .so with the external linker
+-- 2) load the .so with POSIX's "dlopen"
+--
+-- * When GHC is built as a static program or when libraries we want to load
+-- aren't compiled for dynamic linking, GHC uses its own loader ("runtime
+-- linker"). The runtime linker is part of the rts (rts/Linker.c).
+--
+-- Note that within GHC's codebase we often use the word "linker" to refer to
+-- the static object loader in the runtime system.
+--
+-- Loading can be delegated to an external interpreter ("iserv") when
+-- -fexternal-interpreter is used.
diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs
new file mode 100644
index 0000000000..745758f3e5
--- /dev/null
+++ b/compiler/GHC/Linker/Dynamic.hs
@@ -0,0 +1,264 @@
+{-# LANGUAGE CPP #-}
+
+-- | Dynamic linker
+module GHC.Linker.Dynamic
+ ( linkDynLib
+ -- * Platform-specifics
+ , libmLinkOpts
+ )
+where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+import GHC.Platform
+import GHC.Platform.Ways
+
+import GHC.Driver.Session
+
+import GHC.Unit.Types
+import GHC.Unit.State
+import GHC.Utils.Outputable
+import GHC.Linker.MacOS
+import GHC.Linker.Unit
+import GHC.SysTools.Tasks
+
+import qualified Data.Set as Set
+import System.FilePath
+
+linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()
+linkDynLib dflags0 o_files dep_packages
+ = do
+ let platform = targetPlatform dflags0
+ os = platformOS platform
+
+ -- This is a rather ugly hack to fix dynamically linked
+ -- GHC on Windows. If GHC is linked with -threaded, then
+ -- it links against libHSrts_thr. But if base is linked
+ -- against libHSrts, then both end up getting loaded,
+ -- and things go wrong. We therefore link the libraries
+ -- with the same RTS flags that we link GHC with.
+ dflags | OSMinGW32 <- os
+ , hostWays `hasWay` WayDyn
+ = dflags0 { ways = hostWays }
+ | otherwise
+ = dflags0
+
+ verbFlags = getVerbFlags dflags
+ o_file = outputFile dflags
+
+ pkgs_with_rts <- getPreloadUnitsAnd
+ (initSDocContext dflags defaultUserStyle)
+ (unitState dflags)
+ (mkHomeUnitFromFlags dflags)
+ dep_packages
+
+ let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs_with_rts
+ let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
+ get_pkg_lib_path_opts l
+ | ( osElfTarget (platformOS (targetPlatform dflags)) ||
+ osMachOTarget (platformOS (targetPlatform dflags)) ) &&
+ dynLibLoader dflags == SystemDependent &&
+ -- Only if we want dynamic libraries
+ WayDyn `Set.member` ways dflags &&
+ -- Only use RPath if we explicitly asked for it
+ gopt Opt_RPath dflags
+ = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
+ -- See Note [-Xlinker -rpath vs -Wl,-rpath]
+ | otherwise = ["-L" ++ l]
+
+ let lib_paths = libraryPaths dflags
+ let lib_path_opts = map ("-L"++) lib_paths
+
+ -- In general we don't want to link our dynamic libs against the RTS
+ -- package, because the RTS lib comes in several flavours and we want to be
+ -- able to pick the flavour when a binary is linked.
+ --
+ -- But:
+ -- * on Windows we need to link the RTS import lib as Windows does not
+ -- allow undefined symbols.
+ --
+ -- * the RTS library path is still added to the library search path above
+ -- in case the RTS is being explicitly linked in (see #3807).
+ --
+ -- * if -flink-rts is used, we link with the rts.
+ --
+ let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts
+ pkgs
+ | OSMinGW32 <- os = pkgs_with_rts
+ | gopt Opt_LinkRts dflags = pkgs_with_rts
+ | otherwise = pkgs_without_rts
+ pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags
+ where (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs
+
+ -- probably _stub.o files
+ -- and last temporary shared object file
+ let extra_ld_inputs = ldInputs dflags
+
+ -- frameworks
+ pkg_framework_opts <- getUnitFrameworkOpts dflags platform
+ (map unitId pkgs)
+ let framework_opts = getFrameworkOpts dflags platform
+
+ case os of
+ OSMinGW32 -> do
+ -------------------------------------------------------------
+ -- Making a DLL
+ -------------------------------------------------------------
+ let output_fn = case o_file of
+ Just s -> s
+ Nothing -> "HSdll.dll"
+
+ runLink dflags (
+ map Option verbFlags
+ ++ [ Option "-o"
+ , FileOption "" output_fn
+ , Option "-shared"
+ ] ++
+ [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
+ | gopt Opt_SharedImplib dflags
+ ]
+ ++ map (FileOption "") o_files
+
+ -- Permit the linker to auto link _symbol to _imp_symbol
+ -- This lets us link against DLLs without needing an "import library"
+ ++ [Option "-Wl,--enable-auto-import"]
+
+ ++ extra_ld_inputs
+ ++ map Option (
+ lib_path_opts
+ ++ pkg_lib_path_opts
+ ++ pkg_link_opts
+ ))
+ _ | os == OSDarwin -> do
+ -------------------------------------------------------------------
+ -- Making a darwin dylib
+ -------------------------------------------------------------------
+ -- About the options used for Darwin:
+ -- -dynamiclib
+ -- Apple's way of saying -shared
+ -- -undefined dynamic_lookup:
+ -- Without these options, we'd have to specify the correct
+ -- dependencies for each of the dylibs. Note that we could
+ -- (and should) do without this for all libraries except
+ -- the RTS; all we need to do is to pass the correct
+ -- HSfoo_dyn.dylib files to the link command.
+ -- This feature requires Mac OS X 10.3 or later; there is
+ -- a similar feature, -flat_namespace -undefined suppress,
+ -- which works on earlier versions, but it has other
+ -- disadvantages.
+ -- -single_module
+ -- Build the dynamic library as a single "module", i.e. no
+ -- dynamic binding nonsense when referring to symbols from
+ -- within the library. The NCG assumes that this option is
+ -- specified (on i386, at least).
+ -- -install_name
+ -- Mac OS/X stores the path where a dynamic library is (to
+ -- be) installed in the library itself. It's called the
+ -- "install name" of the library. Then any library or
+ -- executable that links against it before it's installed
+ -- will search for it in its ultimate install location.
+ -- By default we set the install name to the absolute path
+ -- at build time, but it can be overridden by the
+ -- -dylib-install-name option passed to ghc. Cabal does
+ -- this.
+ -------------------------------------------------------------------
+
+ let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
+
+ instName <- case dylibInstallName dflags of
+ Just n -> return n
+ Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
+ runLink dflags (
+ map Option verbFlags
+ ++ [ Option "-dynamiclib"
+ , Option "-o"
+ , FileOption "" output_fn
+ ]
+ ++ map Option o_files
+ ++ [ Option "-undefined",
+ Option "dynamic_lookup",
+ Option "-single_module" ]
+ ++ (if platformArch platform == ArchX86_64
+ then [ ]
+ else [ Option "-Wl,-read_only_relocs,suppress" ])
+ ++ [ Option "-install_name", Option instName ]
+ ++ map Option lib_path_opts
+ ++ extra_ld_inputs
+ ++ map Option framework_opts
+ ++ map Option pkg_lib_path_opts
+ ++ map Option pkg_link_opts
+ ++ map Option pkg_framework_opts
+ -- dead_strip_dylibs, will remove unused dylibs, and thus save
+ -- space in the load commands. The -headerpad is necessary so
+ -- that we can inject more @rpath's later for the leftover
+ -- libraries in the runInjectRpaths phase below.
+ --
+ -- See Note [Dynamic linking on macOS]
+ ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ]
+ )
+ runInjectRPaths dflags pkg_lib_paths output_fn
+ _ -> do
+ -------------------------------------------------------------------
+ -- Making a DSO
+ -------------------------------------------------------------------
+
+ let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
+ unregisterised = platformUnregisterised (targetPlatform dflags)
+ let bsymbolicFlag = -- we need symbolic linking to resolve
+ -- non-PIC intra-package-relocations for
+ -- performance (where symbolic linking works)
+ -- See Note [-Bsymbolic assumptions by GHC]
+ ["-Wl,-Bsymbolic" | not unregisterised]
+
+ runLink dflags (
+ map Option verbFlags
+ ++ libmLinkOpts
+ ++ [ Option "-o"
+ , FileOption "" output_fn
+ ]
+ ++ map Option o_files
+ ++ [ Option "-shared" ]
+ ++ map Option bsymbolicFlag
+ -- Set the library soname. We use -h rather than -soname as
+ -- Solaris 10 doesn't support the latter:
+ ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
+ ++ extra_ld_inputs
+ ++ map Option lib_path_opts
+ ++ map Option pkg_lib_path_opts
+ ++ map Option pkg_link_opts
+ )
+
+-- | Some platforms require that we explicitly link against @libm@ if any
+-- math-y things are used (which we assume to include all programs). See #14022.
+libmLinkOpts :: [Option]
+libmLinkOpts =
+#if defined(HAVE_LIBM)
+ [Option "-lm"]
+#else
+ []
+#endif
+
+{-
+Note [-Bsymbolic assumptions by GHC]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GHC has a few assumptions about interaction of relocations in NCG and linker:
+
+1. -Bsymbolic resolves internal references when the shared library is linked,
+ which is important for performance.
+2. When there is a reference to data in a shared library from the main program,
+ the runtime linker relocates the data object into the main program using an
+ R_*_COPY relocation.
+3. If we used -Bsymbolic, then this results in multiple copies of the data
+ object, because some references have already been resolved to point to the
+ original instance. This is bad!
+
+We work around [3.] for native compiled code by avoiding the generation of
+R_*_COPY relocations.
+
+Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable
+-Bsymbolic linking there.
+
+See related tickets: #4210, #15338
+-}
diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs
index 1b728fb067..c130c93ca4 100644
--- a/compiler/GHC/SysTools/ExtraObj.hs
+++ b/compiler/GHC/Linker/ExtraObj.hs
@@ -6,12 +6,19 @@
--
-----------------------------------------------------------------------------
-module GHC.SysTools.ExtraObj (
- mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,
- checkLinkInfo, getLinkInfo, getCompilerInfo,
- ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts,
- haveRtsOptsFlags
-) where
+module GHC.Linker.ExtraObj
+ ( mkExtraObj
+ , mkExtraObjToLinkIntoBinary
+ , mkNoteObjsToLinkIntoBinary
+ , checkLinkInfo
+ , getLinkInfo
+ , getCompilerInfo
+ , ghcLinkInfoSectionName
+ , ghcLinkInfoNoteName
+ , platformSupportsSavingLinkOpts
+ , haveRtsOptsFlags
+ )
+where
import GHC.Utils.Asm
import GHC.Utils.Error
@@ -35,6 +42,8 @@ import Control.Monad.IO.Class
import GHC.SysTools.FileCleanup
import GHC.SysTools.Tasks
import GHC.SysTools.Info
+import GHC.Linker.Unit
+import GHC.Linker.MacOS
mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
mkExtraObj dflags extn xs
diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Linker/Loader.hs
index dd3c29caa5..d040fe71e5 100644
--- a/compiler/GHC/Runtime/Linker.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -1,29 +1,33 @@
-{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
+{-# LANGUAGE CPP, TupleSections, RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
--
-- (c) The University of Glasgow 2002-2006
+
+-- | The loader
--
--- | The dynamic linker for GHCi.
---
--- This module deals with the top-level issues of dynamic linking,
--- calling the object-code linker and the byte-code linker where
--- necessary.
-module GHC.Runtime.Linker
- ( getHValue
- , showLinkerState
- , linkExpr
- , linkDecls
+-- This module deals with the top-level issues of dynamic linking (loading),
+-- calling the object-code linker and the byte-code linker where necessary.
+module GHC.Linker.Loader
+ ( Loader (..)
+ , LoaderState (..)
+ , initLoaderState
+ , uninitializedLoader
+ , showLoaderState
+ -- * Load & Unload
+ , loadExpr
+ , loadDecls
+ , loadPackages
+ , loadModule
+ , loadCmdLineLibs
+ , loadName
, unload
- , withExtendedLinkEnv
- , extendLinkEnv
- , deleteFromLinkEnv
+ -- * LoadedEnv
+ , withExtendedLoadedEnv
+ , extendLoadedEnv
+ , deleteFromLoadedEnv
+ -- * Misc
, extendLoadedPkgs
- , linkPackages
- , initDynLinker
- , linkModule
- , linkCmdLineLibs
- , uninitializedLinker
)
where
@@ -43,7 +47,6 @@ import GHC.Tc.Utils.Monad
import GHC.Runtime.Interpreter
import GHC.Runtime.Interpreter.Types
-import GHC.Runtime.Linker.Types
import GHCi.RemoteTypes
import GHC.Iface.Load
@@ -79,6 +82,10 @@ import qualified GHC.Data.Maybe as Maybes
import GHC.Data.FastString
import GHC.Data.List.SetOps
+import GHC.Linker.MacOS
+import GHC.Linker.Dynamic
+import GHC.Linker.Types
+
-- Standard libraries
import Control.Monad
@@ -102,51 +109,28 @@ import System.Win32.Info (getSystemDirectory)
import GHC.Utils.Exception
-{- **********************************************************************
-
- The Linker's state
-
- ********************************************************************* -}
-
-{-
-The persistent linker state *must* match the actual state of the
-C dynamic linker at all times.
-
-The MVar used to hold the PersistentLinkerState contains a Maybe
-PersistentLinkerState. The MVar serves to ensure mutual exclusion between
-multiple loaded copies of the GHC library. The Maybe may be Nothing to
-indicate that the linker has not yet been initialised.
-
-The PersistentLinkerState maps Names to actual closures (for
-interpreted code only), for use during linking.
--}
-
-uninitializedLinker :: IO DynLinker
-uninitializedLinker =
- newMVar Nothing >>= (pure . DynLinker)
-
uninitialised :: a
-uninitialised = panic "Dynamic linker not initialised"
+uninitialised = panic "Loader not initialised"
-modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
-modifyPLS_ dl f =
- modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised)
+modifyLS_ :: Loader -> (LoaderState -> IO LoaderState) -> IO ()
+modifyLS_ dl f =
+ modifyMVar_ (loader_state dl) (fmap pure . f . fromMaybe uninitialised)
-modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
-modifyPLS dl f =
- modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised)
+modifyLS :: Loader -> (LoaderState -> IO (LoaderState, a)) -> IO a
+modifyLS dl f =
+ modifyMVar (loader_state dl) (fmapFst pure . f . fromMaybe uninitialised)
where fmapFst f = fmap (\(x, y) -> (f x, y))
-readPLS :: DynLinker -> IO PersistentLinkerState
-readPLS dl =
- (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl)
+readLS :: Loader -> IO LoaderState
+readLS dl =
+ (fmap (fromMaybe uninitialised) . readMVar) (loader_state dl)
-modifyMbPLS_
- :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
-modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f
+modifyMbLS_
+ :: Loader -> (Maybe LoaderState -> IO (Maybe LoaderState)) -> IO ()
+modifyMbLS_ dl f = modifyMVar_ (loader_state dl) f
-emptyPLS :: PersistentLinkerState
-emptyPLS = PersistentLinkerState
+emptyLS :: LoaderState
+emptyLS = LoaderState
{ closure_env = emptyNameEnv
, itbl_env = emptyNameEnv
, pkgs_loaded = init_pkgs
@@ -161,58 +145,58 @@ emptyPLS = PersistentLinkerState
-- explicit list. See rts/Linker.c for details.
where init_pkgs = [rtsUnitId]
-extendLoadedPkgs :: DynLinker -> [UnitId] -> IO ()
+extendLoadedPkgs :: Loader -> [UnitId] -> IO ()
extendLoadedPkgs dl pkgs =
- modifyPLS_ dl $ \s ->
+ modifyLS_ dl $ \s ->
return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
-extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO ()
-extendLinkEnv dl new_bindings =
- modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do
+extendLoadedEnv :: Loader -> [(Name,ForeignHValue)] -> IO ()
+extendLoadedEnv dl new_bindings =
+ modifyLS_ dl $ \pls@LoaderState{..} -> do
let new_ce = extendClosureEnv closure_env new_bindings
return $! pls{ closure_env = new_ce }
-- strictness is important for not retaining old copies of the pls
-deleteFromLinkEnv :: DynLinker -> [Name] -> IO ()
-deleteFromLinkEnv dl to_remove =
- modifyPLS_ dl $ \pls -> do
+deleteFromLoadedEnv :: Loader -> [Name] -> IO ()
+deleteFromLoadedEnv dl to_remove =
+ modifyLS_ dl $ \pls -> do
let ce = closure_env pls
let new_ce = delListFromNameEnv ce to_remove
return pls{ closure_env = new_ce }
--- | Get the 'HValue' associated with the given name.
---
--- May cause loading the module that contains the name.
+-- | Load the module containing the given Name and get its associated 'HValue'.
--
-- Throws a 'ProgramError' if loading fails or the name cannot be found.
-getHValue :: HscEnv -> Name -> IO ForeignHValue
-getHValue hsc_env name = do
- let dl = hsc_dynLinker hsc_env
- initDynLinker hsc_env
- pls <- modifyPLS dl $ \pls -> do
- if (isExternalName name) then do
- (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
- [nameModule name]
- if (failed ok) then throwGhcExceptionIO (ProgramError "")
- else return (pls', pls')
- else
- return (pls, pls)
- case lookupNameEnv (closure_env pls) name of
- Just (_,aa) -> return aa
- Nothing
- -> ASSERT2(isExternalName name, ppr name)
- do let sym_to_find = nameToCLabel name "closure"
- m <- lookupClosure hsc_env (unpackFS sym_to_find)
- case m of
- Just hvref -> mkFinalizedHValue hsc_env hvref
- Nothing -> linkFail "GHC.Runtime.Linker.getHValue"
- (unpackFS sym_to_find)
-
-linkDependencies :: HscEnv -> PersistentLinkerState
+loadName :: HscEnv -> Name -> IO ForeignHValue
+loadName hsc_env name = do
+ let dl = hsc_loader hsc_env
+ initLoaderState hsc_env
+ modifyLS dl $ \pls0 -> do
+ pls <- if not (isExternalName name)
+ then return pls0
+ else do
+ (pls', ok) <- loadDependencies hsc_env pls0 noSrcSpan
+ [nameModule name]
+ if failed ok
+ then throwGhcExceptionIO (ProgramError "")
+ else return pls'
+
+ case lookupNameEnv (closure_env pls) name of
+ Just (_,aa) -> return (pls,aa)
+ Nothing -> ASSERT2(isExternalName name, ppr name)
+ do let sym_to_find = nameToCLabel name "closure"
+ m <- lookupClosure hsc_env (unpackFS sym_to_find)
+ r <- case m of
+ Just hvref -> mkFinalizedHValue hsc_env hvref
+ Nothing -> linkFail "GHC.Linker.Loader.loadName"
+ (unpackFS sym_to_find)
+ return (pls,r)
+
+loadDependencies :: HscEnv -> LoaderState
-> SrcSpan -> [Module]
- -> IO (PersistentLinkerState, SuccessFlag)
-linkDependencies hsc_env pls span needed_mods = do
--- initDynLinker (hsc_dflags hsc_env) dl
+ -> IO (LoaderState, SuccessFlag)
+loadDependencies hsc_env pls span needed_mods = do
+-- initLoaderState (hsc_dflags hsc_env) dl
let hpt = hsc_HPT hsc_env
-- The interpreter and dynamic linker can only handle object code built
-- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
@@ -225,16 +209,16 @@ linkDependencies hsc_env pls span needed_mods = do
maybe_normal_osuf span needed_mods
-- Link the packages and modules required
- pls1 <- linkPackages' hsc_env pkgs pls
- linkModules hsc_env pls1 lnks
+ pls1 <- loadPackages' hsc_env pkgs pls
+ loadModules hsc_env pls1 lnks
--- | Temporarily extend the linker state.
+-- | Temporarily extend the loaded env.
-withExtendedLinkEnv :: (ExceptionMonad m) =>
- DynLinker -> [(Name,ForeignHValue)] -> m a -> m a
-withExtendedLinkEnv dl new_env action
- = MC.bracket (liftIO $ extendLinkEnv dl new_env)
+withExtendedLoadedEnv :: (ExceptionMonad m) =>
+ Loader -> [(Name,ForeignHValue)] -> m a -> m a
+withExtendedLoadedEnv dl new_env action
+ = MC.bracket (liftIO $ extendLoadedEnv dl new_env)
(\_ -> reset_old_env)
(\_ -> action)
where
@@ -244,18 +228,18 @@ withExtendedLinkEnv dl new_env action
-- package), so the reset action only removes the names we
-- added earlier.
reset_old_env = liftIO $
- modifyPLS_ dl $ \pls ->
+ modifyLS_ dl $ \pls ->
let cur = closure_env pls
new = delListFromNameEnv cur (map fst new_env)
in return pls{ closure_env = new }
-- | Display the persistent linker state.
-showLinkerState :: DynLinker -> IO SDoc
-showLinkerState dl
- = do pls <- readPLS dl
+showLoaderState :: Loader -> IO SDoc
+showLoaderState dl
+ = do pls <- readLS dl
return $ withPprStyle defaultDumpStyle
- (vcat [text "----- Linker state -----",
+ (vcat [text "----- Loader state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
text "BCOs:" <+> ppr (bcos_loaded pls)])
@@ -285,39 +269,39 @@ showLinkerState dl
-- nothing. This is useful in Template Haskell, where we call it before
-- trying to link.
--
-initDynLinker :: HscEnv -> IO ()
-initDynLinker hsc_env = do
- let dl = hsc_dynLinker hsc_env
- modifyMbPLS_ dl $ \pls -> do
+initLoaderState :: HscEnv -> IO ()
+initLoaderState hsc_env = do
+ let dl = hsc_loader hsc_env
+ modifyMbLS_ dl $ \pls -> do
case pls of
Just _ -> return pls
- Nothing -> Just <$> reallyInitDynLinker hsc_env
+ Nothing -> Just <$> reallyInitLoaderState hsc_env
-reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
-reallyInitDynLinker hsc_env = do
+reallyInitLoaderState :: HscEnv -> IO LoaderState
+reallyInitLoaderState hsc_env = do
-- Initialise the linker state
let dflags = hsc_dflags hsc_env
- pls0 = emptyPLS
+ pls0 = emptyLS
-- (a) initialise the C dynamic linker
initObjLinker hsc_env
-- (b) Load packages from the command-line (Note [preload packages])
- pls <- linkPackages' hsc_env (preloadUnits (unitState dflags)) pls0
+ pls <- loadPackages' hsc_env (preloadUnits (unitState dflags)) pls0
-- steps (c), (d) and (e)
- linkCmdLineLibs' hsc_env pls
+ loadCmdLineLibs' hsc_env pls
-linkCmdLineLibs :: HscEnv -> IO ()
-linkCmdLineLibs hsc_env = do
- let dl = hsc_dynLinker hsc_env
- initDynLinker hsc_env
- modifyPLS_ dl $ \pls ->
- linkCmdLineLibs' hsc_env pls
+loadCmdLineLibs :: HscEnv -> IO ()
+loadCmdLineLibs hsc_env = do
+ let dl = hsc_loader hsc_env
+ initLoaderState hsc_env
+ modifyLS_ dl $ \pls ->
+ loadCmdLineLibs' hsc_env pls
-linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
-linkCmdLineLibs' hsc_env pls =
+loadCmdLineLibs' :: HscEnv -> LoaderState -> IO LoaderState
+loadCmdLineLibs' hsc_env pls =
do
let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
, libraryPaths = lib_paths_base})
@@ -364,34 +348,34 @@ linkCmdLineLibs' hsc_env pls =
let cmdline_lib_specs = catMaybes classified_ld_inputs
++ libspecs
++ map Framework frameworks
- if null cmdline_lib_specs then return pls
- else do
-
- -- Add directories to library search paths, this only has an effect
- -- on Windows. On Unix OSes this function is a NOP.
- let all_paths = let paths = takeDirectory (pgm_c dflags)
- : framework_paths
- ++ lib_paths_base
- ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
- in nub $ map normalise paths
- let lib_paths = nub $ lib_paths_base ++ gcc_paths
- all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
- pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
-
- let merged_specs = mergeStaticObjects cmdline_lib_specs
- pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
- merged_specs
-
- maybePutStr dflags "final link ... "
- ok <- resolveObjs hsc_env
-
- -- DLLs are loaded, reset the search paths
- mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
-
- if succeeded ok then maybePutStrLn dflags "done"
- else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
-
- return pls1
+ if null cmdline_lib_specs
+ then return pls
+ else do
+ -- Add directories to library search paths, this only has an effect
+ -- on Windows. On Unix OSes this function is a NOP.
+ let all_paths = let paths = takeDirectory (pgm_c dflags)
+ : framework_paths
+ ++ lib_paths_base
+ ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
+ in nub $ map normalise paths
+ let lib_paths = nub $ lib_paths_base ++ gcc_paths
+ all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+ pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
+
+ let merged_specs = mergeStaticObjects cmdline_lib_specs
+ pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
+ merged_specs
+
+ maybePutStr dflags "final link ... "
+ ok <- resolveObjs hsc_env
+
+ -- DLLs are loaded, reset the search paths
+ mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
+
+ if succeeded ok then maybePutStrLn dflags "done"
+ else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
+
+ return pls1
-- | Merge runs of consecutive of 'Objects'. This allows for resolution of
-- cyclic symbol references when dynamically linking. Specifically, we link
@@ -443,8 +427,8 @@ classifyLdInput dflags f
where platform = targetPlatform dflags
preloadLib
- :: HscEnv -> [String] -> [String] -> PersistentLinkerState
- -> LibrarySpec -> IO PersistentLinkerState
+ :: HscEnv -> [String] -> [String] -> LoaderState
+ -> LibrarySpec -> IO LoaderState
preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
case lib_spec of
@@ -540,35 +524,35 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
********************************************************************* -}
--- | Link a single expression, /including/ first linking packages and
+-- | Load a single expression, /including/ first loading packages and
-- modules that this expression depends on.
--
-- Raises an IO exception ('ProgramError') if it can't find a compiled
--- version of the dependents to link.
+-- version of the dependents to load.
--
-linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
-linkExpr hsc_env span root_ul_bco
+loadExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
+loadExpr hsc_env span root_ul_bco
= do {
-- Initialise the linker (if it's not been done already)
- ; initDynLinker hsc_env
+ ; initLoaderState hsc_env
- -- Extract the DynLinker value for passing into required places
- ; let dl = hsc_dynLinker hsc_env
+ -- Extract the Loader value for passing into required places
+ ; let dl = hsc_loader hsc_env
-- Take lock for the actual work.
- ; modifyPLS dl $ \pls0 -> do {
+ ; modifyLS dl $ \pls0 -> do {
- -- Link the packages and modules required
- ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
+ -- Load the packages and modules required
+ ; (pls, ok) <- loadDependencies hsc_env pls0 span needed_mods
; if failed ok then
throwGhcExceptionIO (ProgramError "")
else do {
- -- Link the expression itself
+ -- Load the expression itself
let ie = itbl_env pls
ce = closure_env pls
- -- Link the necessary packages and linkables
+ -- Load the necessary packages and linkables
; let nobreakarray = error "no break array"
bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
@@ -638,7 +622,7 @@ failNonStd dflags srcspan = dieWith dflags srcspan $
| otherwise = text "the normal way"
getLinkDeps :: HscEnv -> HomePackageTable
- -> PersistentLinkerState
+ -> LoaderState
-> Maybe FilePath -- replace object suffices?
-> SrcSpan -- for error messages
-> [Module] -- If you need these
@@ -782,33 +766,31 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
********************************************************************* -}
-linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
-linkDecls hsc_env span cbc@CompiledByteCode{..} = do
+loadDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
+loadDecls hsc_env span cbc@CompiledByteCode{..} = do
-- Initialise the linker (if it's not been done already)
- initDynLinker hsc_env
+ initLoaderState hsc_env
- -- Extract the DynLinker for passing into required places
- let dl = hsc_dynLinker hsc_env
+ -- Extract the Loader for passing into required places
+ let dl = hsc_loader hsc_env
-- Take lock for the actual work.
- modifyPLS dl $ \pls0 -> do
-
- -- Link the packages and modules required
- (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
- if failed ok
- then throwGhcExceptionIO (ProgramError "")
- else do
-
- -- Link the expression itself
- let ie = plusNameEnv (itbl_env pls) bc_itbls
- ce = closure_env pls
-
- -- Link the necessary packages and linkables
- new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
- nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
- let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
- , itbl_env = ie }
- return (pls2, ())
+ modifyLS_ dl $ \pls0 -> do
+ -- Link the packages and modules required
+ (pls, ok) <- loadDependencies hsc_env pls0 span needed_mods
+ if failed ok
+ then throwGhcExceptionIO (ProgramError "")
+ else do
+ -- Link the expression itself
+ let ie = plusNameEnv (itbl_env pls) bc_itbls
+ ce = closure_env pls
+
+ -- Link the necessary packages and linkables
+ new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
+ nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
+ let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
+ , itbl_env = ie }
+ return pls2
where
free_names = uniqDSetToList $
foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
@@ -829,13 +811,14 @@ linkDecls hsc_env span cbc@CompiledByteCode{..} = do
********************************************************************* -}
-linkModule :: HscEnv -> Module -> IO ()
-linkModule hsc_env mod = do
- initDynLinker hsc_env
- let dl = hsc_dynLinker hsc_env
- modifyPLS_ dl $ \pls -> do
- (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
- if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
+loadModule :: HscEnv -> Module -> IO ()
+loadModule hsc_env mod = do
+ initLoaderState hsc_env
+ let dl = hsc_loader hsc_env
+ modifyLS_ dl $ \pls -> do
+ (pls', ok) <- loadDependencies hsc_env pls noSrcSpan [mod]
+ if failed ok
+ then throwGhcExceptionIO (ProgramError "could not load module")
else return pls'
{- **********************************************************************
@@ -846,16 +829,15 @@ linkModule hsc_env mod = do
********************************************************************* -}
-linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
- -> IO (PersistentLinkerState, SuccessFlag)
-linkModules hsc_env pls linkables
+loadModules :: HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)
+loadModules hsc_env pls linkables
= mask_ $ do -- don't want to be interrupted by ^C in here
let (objs, bcos) = partition isObjectLinkable
(concatMap partitionLinkable linkables)
-- Load objects first; they can't depend on BCOs
- (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
+ (pls1, ok_flag) <- loadObjects hsc_env pls objs
if failed ok_flag then
return (pls1, Failed)
@@ -896,10 +878,13 @@ linkableInSet l objs_loaded =
********************************************************************* -}
-dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]
- -> IO (PersistentLinkerState, SuccessFlag)
-dynLinkObjs hsc_env pls objs = do
- -- Load the object files and link them
+-- | Load the object files and link them
+--
+-- If the interpreter uses dynamic-linking, build a shared library and load it.
+-- Otherwise, use the RTS linker.
+loadObjects :: HscEnv -> LoaderState -> [Linkable]
+ -> IO (LoaderState, SuccessFlag)
+loadObjects hsc_env pls objs = do
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
unlinkeds = concatMap linkableUnlinked new_objs
@@ -922,10 +907,10 @@ dynLinkObjs hsc_env pls objs = do
return (pls2, Failed)
-dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
- -> IO PersistentLinkerState
+-- | Create a shared library containing the given object files and load it.
+dynLoadObjs :: HscEnv -> LoaderState -> [FilePath] -> IO LoaderState
dynLoadObjs _ pls [] = return pls
-dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do
+dynLoadObjs hsc_env pls@LoaderState{..} objs = do
let dflags = hsc_dflags hsc_env
let platform = targetPlatform dflags
let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
@@ -986,7 +971,7 @@ dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do
Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
Just err -> linkFail msg err
where
- msg = "GHC.Runtime.Linker.dynLoadObjs: Loading temp shared object failed"
+ msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
rmDupLinkables :: [Linkable] -- Already loaded
-> [Linkable] -- New linkables
@@ -1007,8 +992,7 @@ rmDupLinkables already ls
********************************************************************* -}
-dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable]
- -> IO PersistentLinkerState
+dynLinkBCOs :: HscEnv -> LoaderState -> [Linkable] -> IO LoaderState
dynLinkBCOs hsc_env pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
@@ -1098,13 +1082,13 @@ unload hsc_env linkables
= mask_ $ do -- mask, so we're safe from Ctrl-C in here
-- Initialise the linker (if it's not been done already)
- initDynLinker hsc_env
+ initLoaderState hsc_env
- -- Extract DynLinker for passing into required places
- let dl = hsc_dynLinker hsc_env
+ -- Extract Loader for passing into required places
+ let dl = hsc_loader hsc_env
new_pls
- <- modifyPLS dl $ \pls -> do
+ <- modifyLS dl $ \pls -> do
pls1 <- unload_wkr hsc_env linkables pls
return (pls1, pls1)
@@ -1117,13 +1101,13 @@ unload hsc_env linkables
unload_wkr :: HscEnv
-> [Linkable] -- stable linkables
- -> PersistentLinkerState
- -> IO PersistentLinkerState
+ -> LoaderState
+ -> IO LoaderState
-- Does the core unload business
--- (the wrapper blocks exceptions and deals with the PLS get and put)
+-- (the wrapper blocks exceptions and deals with the LS get and put)
-unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do
- -- NB. careful strictness here to avoid keeping the old PLS when
+unload_wkr hsc_env keep_linkables pls@LoaderState{..} = do
+ -- NB. careful strictness here to avoid keeping the old LS when
-- we're unloading some code. -fghci-leak-check with the tests in
-- testsuite/ghci can detect space leaks here.
@@ -1240,12 +1224,12 @@ showLS (DLL nm) = "(dynamic) " ++ nm
showLS (DLLPath nm) = "(dynamic) " ++ nm
showLS (Framework nm) = "(framework) " ++ nm
--- | Link exactly the specified packages, and their dependents (unless of
--- course they are already linked). The dependents are linked
+-- | Load exactly the specified packages, and their dependents (unless of
+-- course they are already loaded). The dependents are loaded
-- automatically, and it doesn't matter what order you specify the input
-- packages.
--
-linkPackages :: HscEnv -> [UnitId] -> IO ()
+loadPackages :: HscEnv -> [UnitId] -> IO ()
-- NOTE: in fact, since each module tracks all the packages it depends on,
-- we don't really need to use the package-config dependencies.
--
@@ -1254,17 +1238,16 @@ linkPackages :: HscEnv -> [UnitId] -> IO ()
-- perhaps makes the error message a bit more localised if we get a link
-- failure. So the dependency walking code is still here.
-linkPackages hsc_env new_pkgs = do
+loadPackages hsc_env new_pkgs = do
-- It's probably not safe to try to load packages concurrently, so we take
-- a lock.
- initDynLinker hsc_env
- let dl = hsc_dynLinker hsc_env
- modifyPLS_ dl $ \pls ->
- linkPackages' hsc_env new_pkgs pls
-
-linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState
- -> IO PersistentLinkerState
-linkPackages' hsc_env new_pks pls = do
+ initLoaderState hsc_env
+ let dl = hsc_loader hsc_env
+ modifyLS_ dl $ \pls ->
+ loadPackages' hsc_env new_pkgs pls
+
+loadPackages' :: HscEnv -> [UnitId] -> LoaderState -> IO LoaderState
+loadPackages' hsc_env new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
@@ -1283,15 +1266,15 @@ linkPackages' hsc_env new_pks pls = do
= do { -- Link dependents first
pkgs' <- link pkgs (unitDepends pkg_cfg)
-- Now link the package itself
- ; linkPackage hsc_env pkg_cfg
+ ; loadPackage hsc_env pkg_cfg
; return (new_pkg : pkgs') }
| otherwise
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
-linkPackage :: HscEnv -> UnitInfo -> IO ()
-linkPackage hsc_env pkg
+loadPackage :: HscEnv -> UnitInfo -> IO ()
+loadPackage hsc_env pkg
= do
let dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
@@ -1301,7 +1284,7 @@ linkPackage hsc_env pkg
let hs_libs = map ST.unpack $ Packages.unitLibraries pkg
-- The FFI GHCi import lib isn't needed as
- -- GHC.Runtime.Linker + rts/Linker.c link the
+ -- GHC.Linker.Loader + rts/Linker.c link the
-- interpreted references to FFI to the compiled FFI.
-- We therefore filter it out so that we don't get
-- duplicate symbol errors.
@@ -1715,70 +1698,6 @@ addEnvPaths name list
-- ----------------------------------------------------------------------------
-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
-{-
-Note [macOS Big Sur dynamic libraries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-macOS Big Sur makes the following change to how frameworks are shipped
-with the OS:
-
-> New in macOS Big Sur 11 beta, the system ships with a built-in
-> dynamic linker cache of all system-provided libraries. As part of
-> this change, copies of dynamic libraries are no longer present on
-> the filesystem. Code that attempts to check for dynamic library
-> presence by looking for a file at a path or enumerating a directory
-> will fail. Instead, check for library presence by attempting to
-> dlopen() the path, which will correctly check for the library in the
-> cache. (62986286)
-
-(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/)
-
-Therefore, the previous method of checking whether a library exists
-before attempting to load it makes GHC.Runtime.Linker.loadFramework
-fail to find frameworks installed at /System/Library/Frameworks.
-Instead, any attempt to load a framework at runtime, such as by
-passing -framework OpenGL to runghc or running code loading such a
-framework with GHCi, fails with a 'not found' message.
-
-GHC.Runtime.Linker.loadFramework now opportunistically loads the
-framework libraries without checking for their existence first,
-failing only if all attempts to load a given framework from any of the
-various possible locations fail. See also #18446, which this change
-addresses.
--}
-
--- Darwin / MacOS X only: load a framework
--- a framework is a dynamic library packaged inside a directory of the same
--- name. They are searched for in different paths than normal libraries.
-loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
-loadFramework hsc_env extraPaths rootname
- = do { either_dir <- tryIO getHomeDirectory
- ; let homeFrameworkPath = case either_dir of
- Left _ -> []
- Right dir -> [dir </> "Library/Frameworks"]
- ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
- ; errs <- findLoadDLL ps []
- ; return $ fmap (intercalate ", ") errs
- }
- where
- fwk_file = rootname <.> "framework" </> rootname
-
- -- sorry for the hardcoded paths, I hope they won't change anytime soon:
- defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
-
- -- Try to call loadDLL for each candidate path.
- --
- -- See Note [macOS Big Sur dynamic libraries]
- findLoadDLL [] errs =
- -- Tried all our known library paths, but dlopen()
- -- has no built-in paths for frameworks: give up
- return $ Just errs
- findLoadDLL (p:ps) errs =
- do { dll <- loadDLL hsc_env (p </> fwk_file)
- ; case dll of
- Nothing -> return Nothing
- Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)
- }
{- **********************************************************************
diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs
new file mode 100644
index 0000000000..e91ee8c5d1
--- /dev/null
+++ b/compiler/GHC/Linker/MacOS.hs
@@ -0,0 +1,183 @@
+module GHC.Linker.MacOS
+ ( runInjectRPaths
+ , getUnitFrameworks
+ , getUnitFrameworkOpts
+ , getUnitFrameworkPath
+ , getFrameworkOpts
+ , loadFramework
+ )
+where
+
+import GHC.Prelude
+import GHC.Platform
+
+import GHC.Driver.Session
+import GHC.Driver.Env
+
+import GHC.Unit.Types
+import GHC.Unit.State
+import GHC.Unit.Home
+
+import GHC.SysTools.Tasks
+
+import GHC.Runtime.Interpreter (loadDLL)
+
+import GHC.Utils.Outputable
+import GHC.Utils.Exception
+import GHC.Utils.Misc (ordNub )
+
+import qualified GHC.Data.ShortText as ST
+
+import Data.List
+import Control.Monad (join, forM, filterM)
+import System.Directory (doesFileExist, getHomeDirectory)
+import System.FilePath ((</>), (<.>))
+
+-- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused
+-- libraries from the dynamic library. We do this to reduce the number of load
+-- commands that end up in the dylib, and has been limited to 32K (32768) since
+-- macOS Sierra (10.14).
+--
+-- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing
+-- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not
+-- being included in the load commands, however the @-rpath@ entries are all
+-- forced to be included. This can lead to 100s of @-rpath@ entries being
+-- included when only a handful of libraries end up being truely linked.
+--
+-- Thus after building the library, we run a fixup phase where we inject the
+-- @-rpath@ for each found library (in the given library search paths) into the
+-- dynamic library through @-add_rpath@.
+--
+-- See Note [Dynamic linking on macOS]
+runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
+runInjectRPaths dflags lib_paths dylib = do
+ info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib]
+ -- filter the output for only the libraries. And then drop the @rpath prefix.
+ let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
+ -- find any pre-existing LC_PATH items
+ info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib]
+ let paths = concatMap f info
+ where f ("path":p:_) = [p]
+ f _ = []
+ lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
+ -- only find those rpaths, that aren't already in the library.
+ rpaths <- nub . sort . join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')
+ -- inject the rpaths
+ case rpaths of
+ [] -> return ()
+ _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
+
+getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]
+getUnitFrameworkOpts dflags platform dep_packages
+ | platformUsesFrameworks platform = do
+ pkg_framework_path_opts <- do
+ pkg_framework_paths <- getUnitFrameworkPath
+ (initSDocContext dflags defaultUserStyle)
+ (unitState dflags)
+ (mkHomeUnitFromFlags dflags)
+ dep_packages
+ return $ map ("-F" ++) pkg_framework_paths
+
+ pkg_framework_opts <- do
+ pkg_frameworks <- getUnitFrameworks
+ (initSDocContext dflags defaultUserStyle)
+ (unitState dflags)
+ (mkHomeUnitFromFlags dflags)
+ dep_packages
+ return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
+
+ return (pkg_framework_path_opts ++ pkg_framework_opts)
+
+ | otherwise = return []
+
+getFrameworkOpts :: DynFlags -> Platform -> [String]
+getFrameworkOpts dflags platform
+ | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
+ | otherwise = []
+ where
+ framework_paths = frameworkPaths dflags
+ framework_path_opts = map ("-F" ++) framework_paths
+
+ frameworks = cmdlineFrameworks dflags
+ -- reverse because they're added in reverse order from the cmd line:
+ framework_opts = concat [ ["-framework", fw]
+ | fw <- reverse frameworks ]
+
+
+-- | Find all the package framework paths in these and the preload packages
+getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
+getUnitFrameworkPath ctx unit_state home_unit pkgs = do
+ ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs
+ return $ map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps)))
+
+-- | Find all the package frameworks in these and the preload packages
+getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
+getUnitFrameworks ctx unit_state home_unit pkgs = do
+ ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs
+ return $ map ST.unpack (concatMap unitExtDepFrameworks ps)
+
+
+{-
+Note [macOS Big Sur dynamic libraries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+macOS Big Sur makes the following change to how frameworks are shipped
+with the OS:
+
+> New in macOS Big Sur 11 beta, the system ships with a built-in
+> dynamic linker cache of all system-provided libraries. As part of
+> this change, copies of dynamic libraries are no longer present on
+> the filesystem. Code that attempts to check for dynamic library
+> presence by looking for a file at a path or enumerating a directory
+> will fail. Instead, check for library presence by attempting to
+> dlopen() the path, which will correctly check for the library in the
+> cache. (62986286)
+
+(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/)
+
+Therefore, the previous method of checking whether a library exists
+before attempting to load it makes GHC.Linker.MacOS.loadFramework
+fail to find frameworks installed at /System/Library/Frameworks.
+Instead, any attempt to load a framework at runtime, such as by
+passing -framework OpenGL to runghc or running code loading such a
+framework with GHCi, fails with a 'not found' message.
+
+GHC.Linker.MacOS.loadFramework now opportunistically loads the
+framework libraries without checking for their existence first,
+failing only if all attempts to load a given framework from any of the
+various possible locations fail. See also #18446, which this change
+addresses.
+-}
+
+-- Darwin / MacOS X only: load a framework
+-- a framework is a dynamic library packaged inside a directory of the same
+-- name. They are searched for in different paths than normal libraries.
+loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
+loadFramework hsc_env extraPaths rootname
+ = do { either_dir <- tryIO getHomeDirectory
+ ; let homeFrameworkPath = case either_dir of
+ Left _ -> []
+ Right dir -> [dir </> "Library/Frameworks"]
+ ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
+ ; errs <- findLoadDLL ps []
+ ; return $ fmap (intercalate ", ") errs
+ }
+ where
+ fwk_file = rootname <.> "framework" </> rootname
+
+ -- sorry for the hardcoded paths, I hope they won't change anytime soon:
+ defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
+
+ -- Try to call loadDLL for each candidate path.
+ --
+ -- See Note [macOS Big Sur dynamic libraries]
+ findLoadDLL [] errs =
+ -- Tried all our known library paths, but dlopen()
+ -- has no built-in paths for frameworks: give up
+ return $ Just errs
+ findLoadDLL (p:ps) errs =
+ do { dll <- loadDLL hsc_env (p </> fwk_file)
+ ; case dll of
+ Nothing -> return Nothing
+ Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)
+ }
diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs
new file mode 100644
index 0000000000..3074c28864
--- /dev/null
+++ b/compiler/GHC/Linker/Static.hs
@@ -0,0 +1,342 @@
+module GHC.Linker.Static
+ ( linkBinary
+ , linkBinary'
+ , linkStaticLib
+ , exeFileName
+ )
+where
+
+import GHC.Prelude
+import GHC.Platform
+import GHC.Platform.Ways
+import GHC.Settings
+
+import GHC.SysTools
+import GHC.SysTools.Ar
+import GHC.SysTools.FileCleanup
+
+import GHC.Unit.Types
+import GHC.Unit.Info
+import GHC.Unit.State
+
+import GHC.Utils.Monad
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+
+import GHC.Linker.MacOS
+import GHC.Linker.Unit
+import GHC.Linker.Dynamic
+import GHC.Linker.ExtraObj
+import GHC.Linker.Windows
+
+import GHC.Driver.Session
+
+import System.FilePath
+import System.Directory
+import Control.Monad
+
+-----------------------------------------------------------------------------
+-- Static linking, of .o files
+
+-- The list of packages passed to link is the list of packages on
+-- which this program depends, as discovered by the compilation
+-- manager. It is combined with the list of packages that the user
+-- specifies on the command line with -package flags.
+--
+-- In one-shot linking mode, we can't discover the package
+-- dependencies (because we haven't actually done any compilation or
+-- read any interface files), so the user must explicitly specify all
+-- the packages.
+
+{-
+Note [-Xlinker -rpath vs -Wl,-rpath]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-Wl takes a comma-separated list of options which in the case of
+-Wl,-rpath -Wl,some,path,with,commas parses the path with commas
+as separate options.
+Buck, the build system, produces paths with commas in them.
+
+-Xlinker doesn't have this disadvantage and as far as I can tell
+it is supported by both gcc and clang. Anecdotally nvcc supports
+-Xlinker, but not -Wl.
+-}
+
+linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
+linkBinary = linkBinary' False
+
+linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
+linkBinary' staticLink dflags o_files dep_units = do
+ let platform = targetPlatform dflags
+ toolSettings' = toolSettings dflags
+ verbFlags = getVerbFlags dflags
+ output_fn = exeFileName platform staticLink (outputFile dflags)
+ home_unit = mkHomeUnitFromFlags dflags
+
+ -- get the full list of packages to link with, by combining the
+ -- explicit packages with the auto packages and all of their
+ -- dependencies, and eliminating duplicates.
+
+ full_output_fn <- if isAbsolute output_fn
+ then return output_fn
+ else do d <- getCurrentDirectory
+ return $ normalise (d </> output_fn)
+ pkg_lib_paths <- getUnitLibraryPath
+ (initSDocContext dflags defaultUserStyle)
+ (unitState dflags)
+ home_unit
+ (ways dflags)
+ dep_units
+ let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
+ get_pkg_lib_path_opts l
+ | osElfTarget (platformOS platform) &&
+ dynLibLoader dflags == SystemDependent &&
+ WayDyn `elem` ways dflags
+ = let libpath = if gopt Opt_RelativeDynlibPaths dflags
+ then "$ORIGIN" </>
+ (l `makeRelativeTo` full_output_fn)
+ else l
+ -- See Note [-Xlinker -rpath vs -Wl,-rpath]
+ rpath = if gopt Opt_RPath dflags
+ then ["-Xlinker", "-rpath", "-Xlinker", libpath]
+ else []
+ -- Solaris 11's linker does not support -rpath-link option. It silently
+ -- ignores it and then complains about next option which is -l<some
+ -- dir> as being a directory and not expected object file, E.g
+ -- ld: elf error: file
+ -- /tmp/ghc-src/libraries/base/dist-install/build:
+ -- elf_begin: I/O error: region read: Is a directory
+ rpathlink = if (platformOS platform) == OSSolaris2
+ then []
+ else ["-Xlinker", "-rpath-link", "-Xlinker", l]
+ in ["-L" ++ l] ++ rpathlink ++ rpath
+ | osMachOTarget (platformOS platform) &&
+ dynLibLoader dflags == SystemDependent &&
+ WayDyn `elem` ways dflags &&
+ gopt Opt_RPath dflags
+ = let libpath = if gopt Opt_RelativeDynlibPaths dflags
+ then "@loader_path" </>
+ (l `makeRelativeTo` full_output_fn)
+ else l
+ in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
+ | otherwise = ["-L" ++ l]
+
+ pkg_lib_path_opts <-
+ if gopt Opt_SingleLibFolder dflags
+ then do
+ libs <- getLibs dflags dep_units
+ tmpDir <- newTempDir dflags
+ sequence_ [ copyFile lib (tmpDir </> basename)
+ | (lib, basename) <- libs]
+ return [ "-L" ++ tmpDir ]
+ else pure pkg_lib_path_opts
+
+ let
+ dead_strip
+ | gopt Opt_WholeArchiveHsLibs dflags = []
+ | otherwise = if osSubsectionsViaSymbols (platformOS platform)
+ then ["-Wl,-dead_strip"]
+ else []
+ let lib_paths = libraryPaths dflags
+ let lib_path_opts = map ("-L"++) lib_paths
+
+ extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
+ noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units
+
+ let
+ (pre_hs_libs, post_hs_libs)
+ | gopt Opt_WholeArchiveHsLibs dflags
+ = if platformOS platform == OSDarwin
+ then (["-Wl,-all_load"], [])
+ -- OS X does not have a flag to turn off -all_load
+ else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
+ | otherwise
+ = ([],[])
+
+ pkg_link_opts <- do
+ (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units
+ return $ if staticLink
+ then package_hs_libs -- If building an executable really means making a static
+ -- library (e.g. iOS), then we only keep the -l options for
+ -- HS packages, because libtool doesn't accept other options.
+ -- In the case of iOS these need to be added by hand to the
+ -- final link in Xcode.
+ else other_flags ++ dead_strip
+ ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
+ ++ extra_libs
+ -- -Wl,-u,<sym> contained in other_flags
+ -- needs to be put before -l<package>,
+ -- otherwise Solaris linker fails linking
+ -- a binary with unresolved symbols in RTS
+ -- which are defined in base package
+ -- the reason for this is a note in ld(1) about
+ -- '-u' option: "The placement of this option
+ -- on the command line is significant.
+ -- This option must be placed before the library
+ -- that defines the symbol."
+
+ -- frameworks
+ pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units
+ let framework_opts = getFrameworkOpts dflags platform
+
+ -- probably _stub.o files
+ let extra_ld_inputs = ldInputs dflags
+
+ rc_objs <- case platformOS platform of
+ OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest dflags output_fn
+ _ -> return []
+
+ let link dflags args | staticLink = GHC.SysTools.runLibtool dflags args
+ | platformOS platform == OSDarwin
+ = do
+ GHC.SysTools.runLink dflags args
+ GHC.Linker.MacOS.runInjectRPaths dflags pkg_lib_paths output_fn
+ | otherwise
+ = GHC.SysTools.runLink dflags args
+
+ link dflags (
+ map GHC.SysTools.Option verbFlags
+ ++ [ GHC.SysTools.Option "-o"
+ , GHC.SysTools.FileOption "" output_fn
+ ]
+ ++ libmLinkOpts
+ ++ map GHC.SysTools.Option (
+ []
+
+ -- See Note [No PIE when linking]
+ ++ picCCOpts dflags
+
+ -- Permit the linker to auto link _symbol to _imp_symbol.
+ -- This lets us link against DLLs without needing an "import library".
+ ++ (if platformOS platform == OSMinGW32
+ then ["-Wl,--enable-auto-import"]
+ else [])
+
+ -- '-no_compact_unwind'
+ -- C++/Objective-C exceptions cannot use optimised
+ -- stack unwinding code. The optimised form is the
+ -- default in Xcode 4 on at least x86_64, and
+ -- without this flag we're also seeing warnings
+ -- like
+ -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
+ -- on x86.
+ ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' &&
+ not staticLink &&
+ (platformOS platform == OSDarwin) &&
+ case platformArch platform of
+ ArchX86 -> True
+ ArchX86_64 -> True
+ ArchARM {} -> True
+ ArchARM64 -> True
+ _ -> False
+ then ["-Wl,-no_compact_unwind"]
+ else [])
+
+ -- '-Wl,-read_only_relocs,suppress'
+ -- ld gives loads of warnings like:
+ -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
+ -- when linking any program. We're not sure
+ -- whether this is something we ought to fix, but
+ -- for now this flags silences them.
+ ++ (if platformOS platform == OSDarwin &&
+ platformArch platform == ArchX86 &&
+ not staticLink
+ then ["-Wl,-read_only_relocs,suppress"]
+ else [])
+
+ ++ (if toolSettings_ldIsGnuLd toolSettings' &&
+ not (gopt Opt_WholeArchiveHsLibs dflags)
+ then ["-Wl,--gc-sections"]
+ else [])
+
+ ++ o_files
+ ++ lib_path_opts)
+ ++ extra_ld_inputs
+ ++ map GHC.SysTools.Option (
+ rc_objs
+ ++ framework_opts
+ ++ pkg_lib_path_opts
+ ++ extraLinkObj:noteLinkObjs
+ ++ pkg_link_opts
+ ++ pkg_framework_opts
+ ++ (if platformOS platform == OSDarwin
+ -- dead_strip_dylibs, will remove unused dylibs, and thus save
+ -- space in the load commands. The -headerpad is necessary so
+ -- that we can inject more @rpath's later for the left over
+ -- libraries during runInjectRpaths phase.
+ --
+ -- See Note [Dynamic linking on macOS].
+ then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ]
+ else [])
+ ))
+
+-- | Linking a static lib will not really link anything. It will merely produce
+-- a static archive of all dependent static libraries. The resulting library
+-- will still need to be linked with any remaining link flags.
+linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO ()
+linkStaticLib dflags o_files dep_units = do
+ let platform = targetPlatform dflags
+ extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
+ modules = o_files ++ extra_ld_inputs
+ output_fn = exeFileName platform True (outputFile dflags)
+ home_unit = mkHomeUnitFromFlags dflags
+
+ full_output_fn <- if isAbsolute output_fn
+ then return output_fn
+ else do d <- getCurrentDirectory
+ return $ normalise (d </> output_fn)
+ output_exists <- doesFileExist full_output_fn
+ (when output_exists) $ removeFile full_output_fn
+
+ pkg_cfgs_init <- getPreloadUnitsAnd
+ (initSDocContext dflags defaultUserStyle)
+ (unitState dflags)
+ home_unit
+ dep_units
+
+ let pkg_cfgs
+ | gopt Opt_LinkRts dflags
+ = pkg_cfgs_init
+ | otherwise
+ = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init
+
+ archives <- concatMapM (collectArchives dflags) pkg_cfgs
+
+ ar <- foldl mappend
+ <$> (Archive <$> mapM loadObj modules)
+ <*> mapM loadAr archives
+
+ if toolSettings_ldIsGnuLd (toolSettings dflags)
+ then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
+ else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
+
+ -- run ranlib over the archive. write*Ar does *not* create the symbol index.
+ runRanlib dflags [GHC.SysTools.FileOption "" output_fn]
+
+
+
+-- | Compute the output file name of a program.
+--
+-- StaticLink boolean is used to indicate if the program is actually a static library
+-- (e.g., on iOS).
+--
+-- Use the provided filename (if any), otherwise use "main.exe" (Windows),
+-- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the
+-- extension if it is missing.
+exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath
+exeFileName platform staticLink output_fn
+ | Just s <- output_fn =
+ case platformOS platform of
+ OSMinGW32 -> s <?.> "exe"
+ _ -> if staticLink
+ then s <?.> "a"
+ else s
+ | otherwise =
+ if platformOS platform == OSMinGW32
+ then "main.exe"
+ else if staticLink
+ then "liba.a"
+ else "a.out"
+ where s <?.> ext | null (takeExtension s) = s <.> ext
+ | otherwise = s
+
diff --git a/compiler/GHC/Runtime/Linker/Types.hs b/compiler/GHC/Linker/Types.hs
index e40de2b55e..728d6a3b06 100644
--- a/compiler/GHC/Runtime/Linker/Types.hs
+++ b/compiler/GHC/Linker/Types.hs
@@ -1,14 +1,15 @@
-----------------------------------------------------------------------------
--
--- Types for the Dynamic Linker
+-- Types for the linkers and the loader
--
-- (c) The University of Glasgow 2019
--
-----------------------------------------------------------------------------
-module GHC.Runtime.Linker.Types
- ( DynLinker(..)
- , PersistentLinkerState(..)
+module GHC.Linker.Types
+ ( Loader (..)
+ , LoaderState (..)
+ , uninitializedLoader
, Linkable(..)
, Unlinked(..)
, SptEntry(..)
@@ -22,8 +23,6 @@ module GHC.Runtime.Linker.Types
where
import GHC.Prelude
-import Data.Time ( UTCTime )
-import Control.Concurrent.MVar ( MVar )
import GHC.Unit ( UnitId, Module )
import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode )
import GHC.Fingerprint.Type ( Fingerprint )
@@ -36,38 +35,62 @@ import GHC.Types.Name ( Name )
import GHC.Utils.Outputable
import GHC.Utils.Panic
-type ClosureEnv = NameEnv (Name, ForeignHValue)
+import Control.Concurrent.MVar
+import Data.Time ( UTCTime )
+
+
+{- **********************************************************************
+
+ The Loader's state
-newtype DynLinker =
- DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) }
+ ********************************************************************* -}
-data PersistentLinkerState
- = PersistentLinkerState {
+{-
+The loader state *must* match the actual state of the C dynamic linker at all
+times.
- -- Current global mapping from Names to their true values
- closure_env :: ClosureEnv,
+The MVar used to hold the LoaderState contains a Maybe LoaderState. The MVar
+serves to ensure mutual exclusion between multiple loaded copies of the GHC
+library. The Maybe may be Nothing to indicate that the linker has not yet been
+initialised.
- -- The current global mapping from RdrNames of DataCons to
- -- info table addresses.
- -- When a new Unlinked is linked into the running image, or an existing
- -- module in the image is replaced, the itbl_env must be updated
- -- appropriately.
- itbl_env :: !ItblEnv,
+The LoaderState maps Names to actual closures (for interpreted code only), for
+use during linking.
+-}
- -- The currently loaded interpreted modules (home package)
- bcos_loaded :: ![Linkable],
+newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }
- -- And the currently-loaded compiled modules (home package)
- objs_loaded :: ![Linkable],
+data LoaderState = LoaderState
+ { closure_env :: ClosureEnv
+ -- ^ Current global mapping from Names to their true values
- -- The currently-loaded packages; always object code
- -- Held, as usual, in dependency order; though I am not sure if
- -- that is really important
- pkgs_loaded :: ![UnitId],
+ , itbl_env :: !ItblEnv
+ -- ^ The current global mapping from RdrNames of DataCons to
+ -- info table addresses.
+ -- When a new Unlinked is linked into the running image, or an existing
+ -- module in the image is replaced, the itbl_env must be updated
+ -- appropriately.
- -- we need to remember the name of previous temporary DLL/.so
- -- libraries so we can link them (see #10322)
- temp_sos :: ![(FilePath, String)] }
+ , bcos_loaded :: ![Linkable]
+ -- ^ The currently loaded interpreted modules (home package)
+
+ , objs_loaded :: ![Linkable]
+ -- ^ And the currently-loaded compiled modules (home package)
+
+ , pkgs_loaded :: ![UnitId]
+ -- ^ The currently-loaded packages; always object code
+ -- Held, as usual, in dependency order; though I am not sure if
+ -- that is really important
+
+ , temp_sos :: ![(FilePath, String)]
+ -- ^ We need to remember the name of previous temporary DLL/.so
+ -- libraries so we can link them (see #10322)
+ }
+
+uninitializedLoader :: IO Loader
+uninitializedLoader = Loader <$> newMVar Nothing
+
+type ClosureEnv = NameEnv (Name, ForeignHValue)
-- | Information we can use to dynamically link modules into the compiler
data Linkable = LM {
diff --git a/compiler/GHC/Linker/Unit.hs b/compiler/GHC/Linker/Unit.hs
new file mode 100644
index 0000000000..90326859f4
--- /dev/null
+++ b/compiler/GHC/Linker/Unit.hs
@@ -0,0 +1,134 @@
+
+-- | Linking Haskell units
+module GHC.Linker.Unit
+ ( collectLinkOpts
+ , collectArchives
+ , collectLibraryPaths
+ , getUnitLinkOpts
+ , getUnitLibraryPath
+ , getLibs
+ , packageHsLibs
+ )
+where
+
+import GHC.Prelude
+import GHC.Platform.Ways
+import GHC.Unit.Types
+import GHC.Unit.Info
+import GHC.Unit.State
+import GHC.Unit.Home
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Misc
+
+import qualified GHC.Data.ShortText as ST
+
+import GHC.Driver.Session
+
+import qualified Data.Set as Set
+import Data.List (isPrefixOf, stripPrefix)
+import Control.Monad
+import System.Directory
+import System.FilePath
+
+-- | Find all the link options in these and the preload packages,
+-- returning (package hs lib options, extra library options, other flags)
+getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
+getUnitLinkOpts dflags pkgs =
+ collectLinkOpts dflags `fmap` getPreloadUnitsAnd
+ (initSDocContext dflags defaultUserStyle)
+ (unitState dflags)
+ (mkHomeUnitFromFlags dflags)
+ pkgs
+
+collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])
+collectLinkOpts dflags ps =
+ (
+ concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
+ concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,
+ concatMap (map ST.unpack . unitLinkerOptions) ps
+ )
+
+collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]
+collectArchives dflags pc =
+ filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")
+ | searchPath <- searchPaths
+ , lib <- libs ]
+ where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc
+ libs = packageHsLibs dflags pc ++ map ST.unpack (unitExtDepLibsSys pc)
+
+collectLibraryPaths :: Ways -> [UnitInfo] -> [FilePath]
+collectLibraryPaths ws = ordNub . filter notNull
+ . concatMap (libraryDirsForWay ws)
+
+-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.
+libraryDirsForWay :: Ways -> UnitInfo -> [String]
+libraryDirsForWay ws
+ | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs
+ | otherwise = map ST.unpack . unitLibraryDirs
+
+getLibs :: DynFlags -> [UnitId] -> IO [(String,String)]
+getLibs dflags pkgs = do
+ ps <- getPreloadUnitsAnd
+ (initSDocContext dflags defaultUserStyle)
+ (unitState dflags)
+ (mkHomeUnitFromFlags dflags)
+ pkgs
+ fmap concat . forM ps $ \p -> do
+ let candidates = [ (l </> f, f) | l <- collectLibraryPaths (ways dflags) [p]
+ , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ]
+ filterM (doesFileExist . fst) candidates
+
+-- | Find all the library paths in these and the preload packages
+getUnitLibraryPath :: SDocContext -> UnitState -> HomeUnit -> Ways -> [UnitId] -> IO [String]
+getUnitLibraryPath ctx unit_state home_unit ws pkgs =
+ collectLibraryPaths ws `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs
+
+packageHsLibs :: DynFlags -> UnitInfo -> [String]
+packageHsLibs dflags p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p)
+ where
+ ways0 = ways dflags
+
+ ways1 = Set.filter (/= WayDyn) ways0
+ -- the name of a shared library is libHSfoo-ghc<version>.so
+ -- we leave out the _dyn, because it is superfluous
+
+ -- debug and profiled RTSs include support for -eventlog
+ ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1
+ = Set.filter (/= WayTracing) ways1
+ | otherwise
+ = ways1
+
+ tag = waysTag (fullWays ways2)
+ rts_tag = waysTag ways2
+
+ mkDynName x
+ | not (ways dflags `hasWay` WayDyn) = x
+ | "HS" `isPrefixOf` x =
+ x ++ '-':programName dflags ++ projectVersion dflags
+ -- For non-Haskell libraries, we use the name "Cfoo". The .a
+ -- file is libCfoo.a, and the .so is libfoo.so. That way the
+ -- linker knows what we mean for the vanilla (-lCfoo) and dyn
+ -- (-lfoo) ways. We therefore need to strip the 'C' off here.
+ | Just x' <- stripPrefix "C" x = x'
+ | otherwise
+ = panic ("Don't understand library name " ++ x)
+
+ -- Add _thr and other rts suffixes to packages named
+ -- `rts` or `rts-1.0`. Why both? Traditionally the rts
+ -- package is called `rts` only. However the tooling
+ -- usually expects a package name to have a version.
+ -- As such we will gradually move towards the `rts-1.0`
+ -- package name, at which point the `rts` package name
+ -- will eventually be unused.
+ --
+ -- This change elevates the need to add custom hooks
+ -- and handling specifically for the `rts` package for
+ -- example in ghc-cabal.
+ addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
+ addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag)
+ addSuffix other_lib = other_lib ++ (expandTag tag)
+
+ expandTag t | null t = ""
+ | otherwise = '_':t
+
diff --git a/compiler/GHC/Linker/Windows.hs b/compiler/GHC/Linker/Windows.hs
new file mode 100644
index 0000000000..3bbe83f10e
--- /dev/null
+++ b/compiler/GHC/Linker/Windows.hs
@@ -0,0 +1,64 @@
+module GHC.Linker.Windows
+ ( maybeCreateManifest
+ )
+where
+
+import GHC.Prelude
+import GHC.SysTools
+import GHC.Driver.Session
+import GHC.SysTools.FileCleanup
+
+import System.FilePath
+import System.Directory
+
+maybeCreateManifest
+ :: DynFlags
+ -> FilePath -- ^ filename of executable
+ -> IO [FilePath] -- ^ extra objects to embed, maybe
+maybeCreateManifest dflags exe_filename = do
+ let manifest_filename = exe_filename <.> "manifest"
+ manifest =
+ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\
+ \ <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n\
+ \ <assemblyIdentity version=\"1.0.0.0\"\n\
+ \ processorArchitecture=\"X86\"\n\
+ \ name=\"" ++ dropExtension exe_filename ++ "\"\n\
+ \ type=\"win32\"/>\n\n\
+ \ <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\
+ \ <security>\n\
+ \ <requestedPrivileges>\n\
+ \ <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n\
+ \ </requestedPrivileges>\n\
+ \ </security>\n\
+ \ </trustInfo>\n\
+ \</assembly>\n"
+
+ writeFile manifest_filename manifest
+
+ -- Windows will find the manifest file if it is named
+ -- foo.exe.manifest. However, for extra robustness, and so that
+ -- we can move the binary around, we can embed the manifest in
+ -- the binary itself using windres:
+ if not (gopt Opt_EmbedManifest dflags)
+ then return []
+ else do
+ rc_filename <- newTempName dflags TFL_CurrentModule "rc"
+ rc_obj_filename <-
+ newTempName dflags TFL_GhcSession (objectSuf dflags)
+
+ writeFile rc_filename $
+ "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
+ -- magic numbers :-)
+ -- show is a bit hackish above, but we need to escape the
+ -- backslashes in the path.
+
+ runWindres dflags $ map GHC.SysTools.Option $
+ ["--input="++rc_filename,
+ "--output="++rc_obj_filename,
+ "--output-format=coff"]
+ -- no FileOptions here: windres doesn't like seeing
+ -- backslashes, apparently
+
+ removeFile manifest_filename
+
+ return [rc_obj_filename]
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
index e86357a0ea..f49bd358c1 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ b/compiler/GHC/Runtime/Debugger.hs
@@ -21,7 +21,8 @@ import GHC.Driver.Ppr
import GHC.Driver.Monad
import GHC.Driver.Env
-import GHC.Runtime.Linker
+import GHC.Linker.Loader
+
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Interpreter
import GHC.Runtime.Context
@@ -131,8 +132,8 @@ bindSuspensions t = do
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContextWithIds ictxt ids
- dl = hsc_dynLinker hsc_env
- liftIO $ extendLinkEnv dl (zip names fhvs)
+ dl = hsc_loader hsc_env
+ liftIO $ extendLoadedEnv dl (zip names fhvs)
setSession hsc_env {hsc_IC = new_ic }
return t'
where
@@ -186,9 +187,9 @@ showTerm term = do
expr = "Prelude.return (Prelude.show " ++
showPpr dflags bname ++
") :: Prelude.IO Prelude.String"
- dl = hsc_dynLinker hsc_env
+ dl = hsc_loader hsc_env
GHC.setSessionDynFlags dflags{log_action=noop_log}
- txt_ <- withExtendedLinkEnv dl
+ txt_ <- withExtendedLoadedEnv dl
[(bname, fhv)]
(GHC.compileExprRemote expr)
let myprec = 10 -- application precedence. TODO Infix constructors
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index db0c9928ce..b66f959889 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -59,14 +59,15 @@ import GHC.Driver.Ppr
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter as GHCi
import GHC.Runtime.Interpreter.Types
-import GHC.Runtime.Linker as Linker
-import GHC.Runtime.Linker.Types
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Context
import GHCi.Message
import GHCi.RemoteTypes
import GHC.ByteCode.Types
+import GHC.Linker.Types
+import GHC.Linker.Loader as Loader
+
import GHC.Hs
import GHC.Core.Predicate
@@ -388,8 +389,8 @@ handleRunStatus step expr bindings final_ids status history
= do hsc_env <- getSession
let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
final_names = map getName final_ids
- dl = hsc_dynLinker hsc_env
- liftIO $ Linker.extendLinkEnv dl (zip final_names hvals)
+ dl = hsc_loader hsc_env
+ liftIO $ Loader.extendLoadedEnv dl (zip final_names hvals)
hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
setSession hsc_env'
return (ExecComplete (Right final_names) allocs)
@@ -430,8 +431,8 @@ resumeExec canLogSpan step
new_names = [ n | thing <- ic_tythings ic
, let n = getName thing
, not (n `elem` old_names) ]
- dl = hsc_dynLinker hsc_env
- liftIO $ Linker.deleteFromLinkEnv dl new_names
+ dl = hsc_loader hsc_env
+ liftIO $ Loader.deleteFromLoadedEnv dl new_names
case r of
Resume { resumeStmt = expr, resumeContext = fhv
@@ -525,9 +526,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
- dl = hsc_dynLinker hsc_env
+ dl = hsc_loader hsc_env
--
- Linker.extendLinkEnv dl [(exn_name, apStack)]
+ Loader.extendLoadedEnv dl [(exn_name, apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
-- Just case: we stopped at a breakpoint, we have information about the location
@@ -582,11 +583,11 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
names = map idName new_ids
- dl = hsc_dynLinker hsc_env
+ dl = hsc_loader hsc_env
let fhvs = catMaybes mb_hValues
- Linker.extendLinkEnv dl (zip names fhvs)
- when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)]
+ Loader.extendLoadedEnv dl (zip names fhvs)
+ when result_ok $ Loader.extendLoadedEnv dl [(result_name, apStack_fhv)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
return (hsc_env1, if result_ok then result_name:names else names, span, decl)
where
@@ -1298,13 +1299,13 @@ obtainTermFromVal hsc_env _bound _force _ty _x = withInterp hsc_env $ \case
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
- hv <- Linker.getHValue hsc_env (varName id)
+ hv <- Loader.loadName hsc_env (varName id)
cvObtainTerm hsc_env bound force (idType id) hv
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
- hv <- Linker.getHValue hsc_env (varName id)
+ hv <- Loader.loadName hsc_env (varName id)
cvReconstructType hsc_env bound (idType id) hv
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index 5213b02a4f..9658941ea5 100644
--- a/compiler/GHC/Runtime/Interpreter.hs
+++ b/compiler/GHC/Runtime/Interpreter.hs
@@ -65,9 +65,10 @@ import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray (BreakArray)
import GHC.Runtime.Eval.Types(BreakInfo(..))
-import GHC.Runtime.Linker.Types
import GHC.ByteCode.Types
+import GHC.Linker.Types
+
import GHC.Data.Maybe
import GHC.Data.FastString
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 3b487e7b1a..93b3967525 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -27,7 +27,7 @@ import GHC.Driver.Ppr
import GHC.Driver.Hooks
import GHC.Driver.Plugins
-import GHC.Runtime.Linker ( linkModule, getHValue )
+import GHC.Linker.Loader ( loadModule, loadName )
import GHC.Runtime.Interpreter ( wormhole, withInterp )
import GHC.Runtime.Interpreter.Types
@@ -209,11 +209,11 @@ getHValueSafely hsc_env val_name expected_type = do
then do
-- Link in the module that contains the value, if it has such a module
case nameModule_maybe val_name of
- Just mod -> do linkModule hsc_env mod
+ Just mod -> do loadModule hsc_env mod
return ()
Nothing -> return ()
-- Find the value that we just linked in and cast it given that we have proved it's type
- hval <- withInterp hsc_env $ \interp -> getHValue hsc_env val_name >>= wormhole interp
+ hval <- withInterp hsc_env $ \interp -> loadName hsc_env val_name >>= wormhole interp
return (Just hval)
else return Nothing
Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs
index ee1940c332..9e707c3bc4 100644
--- a/compiler/GHC/SysTools.hs
+++ b/compiler/GHC/SysTools.hs
@@ -20,21 +20,12 @@ module GHC.SysTools (
module GHC.SysTools.Tasks,
module GHC.SysTools.Info,
- linkDynLib,
-
copy,
copyWithHeader,
-- * General utilities
Option(..),
expandTopDir,
-
- -- * Platform-specifics
- libmLinkOpts,
-
- -- * Mac OS X frameworks
- getUnitFrameworkOpts,
- getFrameworkOpts
) where
#include "HsVersions.h"
@@ -43,25 +34,19 @@ import GHC.Prelude
import GHC.Settings.Utils
-import GHC.Unit
-import GHC.Unit.State
import GHC.Utils.Error
import GHC.Utils.Panic
-import GHC.Utils.Outputable
-import GHC.Platform
import GHC.Driver.Session
-import GHC.Platform.Ways
import Control.Monad.Trans.Except (runExceptT)
import System.FilePath
import System.IO
import System.IO.Unsafe (unsafeInterleaveIO)
-import GHC.SysTools.ExtraObj
+import GHC.Linker.ExtraObj
import GHC.SysTools.Info
import GHC.SysTools.Tasks
import GHC.SysTools.BaseDir
import GHC.Settings.IO
-import qualified Data.Set as Set
{-
Note [How GHC finds toolchain utilities]
@@ -223,284 +208,3 @@ copyWithHeader dflags purpose maybe_header from to = do
hSetEncoding h utf8
hPutStr h str
hSetBinaryMode h True
-
-{-
-************************************************************************
-* *
-\subsection{Support code}
-* *
-************************************************************************
--}
-
-linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()
-linkDynLib dflags0 o_files dep_packages
- = do
- let platform = targetPlatform dflags0
- os = platformOS platform
-
- -- This is a rather ugly hack to fix dynamically linked
- -- GHC on Windows. If GHC is linked with -threaded, then
- -- it links against libHSrts_thr. But if base is linked
- -- against libHSrts, then both end up getting loaded,
- -- and things go wrong. We therefore link the libraries
- -- with the same RTS flags that we link GHC with.
- dflags | OSMinGW32 <- os
- , hostWays `hasWay` WayDyn
- = dflags0 { ways = hostWays }
- | otherwise
- = dflags0
-
- verbFlags = getVerbFlags dflags
- o_file = outputFile dflags
-
- pkgs_with_rts <- getPreloadUnitsAnd
- (initSDocContext dflags defaultUserStyle)
- (unitState dflags)
- (mkHomeUnitFromFlags dflags)
- dep_packages
-
- let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs_with_rts
- let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
- get_pkg_lib_path_opts l
- | ( osElfTarget (platformOS (targetPlatform dflags)) ||
- osMachOTarget (platformOS (targetPlatform dflags)) ) &&
- dynLibLoader dflags == SystemDependent &&
- -- Only if we want dynamic libraries
- WayDyn `Set.member` ways dflags &&
- -- Only use RPath if we explicitly asked for it
- gopt Opt_RPath dflags
- = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
- -- See Note [-Xlinker -rpath vs -Wl,-rpath]
- | otherwise = ["-L" ++ l]
-
- let lib_paths = libraryPaths dflags
- let lib_path_opts = map ("-L"++) lib_paths
-
- -- In general we don't want to link our dynamic libs against the RTS
- -- package, because the RTS lib comes in several flavours and we want to be
- -- able to pick the flavour when a binary is linked.
- --
- -- But:
- -- * on Windows we need to link the RTS import lib as Windows does not
- -- allow undefined symbols.
- --
- -- * the RTS library path is still added to the library search path above
- -- in case the RTS is being explicitly linked in (see #3807).
- --
- -- * if -flink-rts is used, we link with the rts.
- --
- let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts
- pkgs
- | OSMinGW32 <- os = pkgs_with_rts
- | gopt Opt_LinkRts dflags = pkgs_with_rts
- | otherwise = pkgs_without_rts
- pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags
- where (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs
-
- -- probably _stub.o files
- -- and last temporary shared object file
- let extra_ld_inputs = ldInputs dflags
-
- -- frameworks
- pkg_framework_opts <- getUnitFrameworkOpts dflags platform
- (map unitId pkgs)
- let framework_opts = getFrameworkOpts dflags platform
-
- case os of
- OSMinGW32 -> do
- -------------------------------------------------------------
- -- Making a DLL
- -------------------------------------------------------------
- let output_fn = case o_file of
- Just s -> s
- Nothing -> "HSdll.dll"
-
- runLink dflags (
- map Option verbFlags
- ++ [ Option "-o"
- , FileOption "" output_fn
- , Option "-shared"
- ] ++
- [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
- | gopt Opt_SharedImplib dflags
- ]
- ++ map (FileOption "") o_files
-
- -- Permit the linker to auto link _symbol to _imp_symbol
- -- This lets us link against DLLs without needing an "import library"
- ++ [Option "-Wl,--enable-auto-import"]
-
- ++ extra_ld_inputs
- ++ map Option (
- lib_path_opts
- ++ pkg_lib_path_opts
- ++ pkg_link_opts
- ))
- _ | os == OSDarwin -> do
- -------------------------------------------------------------------
- -- Making a darwin dylib
- -------------------------------------------------------------------
- -- About the options used for Darwin:
- -- -dynamiclib
- -- Apple's way of saying -shared
- -- -undefined dynamic_lookup:
- -- Without these options, we'd have to specify the correct
- -- dependencies for each of the dylibs. Note that we could
- -- (and should) do without this for all libraries except
- -- the RTS; all we need to do is to pass the correct
- -- HSfoo_dyn.dylib files to the link command.
- -- This feature requires Mac OS X 10.3 or later; there is
- -- a similar feature, -flat_namespace -undefined suppress,
- -- which works on earlier versions, but it has other
- -- disadvantages.
- -- -single_module
- -- Build the dynamic library as a single "module", i.e. no
- -- dynamic binding nonsense when referring to symbols from
- -- within the library. The NCG assumes that this option is
- -- specified (on i386, at least).
- -- -install_name
- -- Mac OS/X stores the path where a dynamic library is (to
- -- be) installed in the library itself. It's called the
- -- "install name" of the library. Then any library or
- -- executable that links against it before it's installed
- -- will search for it in its ultimate install location.
- -- By default we set the install name to the absolute path
- -- at build time, but it can be overridden by the
- -- -dylib-install-name option passed to ghc. Cabal does
- -- this.
- -------------------------------------------------------------------
-
- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
-
- instName <- case dylibInstallName dflags of
- Just n -> return n
- Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
- runLink dflags (
- map Option verbFlags
- ++ [ Option "-dynamiclib"
- , Option "-o"
- , FileOption "" output_fn
- ]
- ++ map Option o_files
- ++ [ Option "-undefined",
- Option "dynamic_lookup",
- Option "-single_module" ]
- ++ (if platformArch platform == ArchX86_64
- then [ ]
- else [ Option "-Wl,-read_only_relocs,suppress" ])
- ++ [ Option "-install_name", Option instName ]
- ++ map Option lib_path_opts
- ++ extra_ld_inputs
- ++ map Option framework_opts
- ++ map Option pkg_lib_path_opts
- ++ map Option pkg_link_opts
- ++ map Option pkg_framework_opts
- -- dead_strip_dylibs, will remove unused dylibs, and thus save
- -- space in the load commands. The -headerpad is necessary so
- -- that we can inject more @rpath's later for the leftover
- -- libraries in the runInjectRpaths phase below.
- --
- -- See Note [Dynamic linking on macOS]
- ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ]
- )
- runInjectRPaths dflags pkg_lib_paths output_fn
- _ -> do
- -------------------------------------------------------------------
- -- Making a DSO
- -------------------------------------------------------------------
-
- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
- unregisterised = platformUnregisterised (targetPlatform dflags)
- let bsymbolicFlag = -- we need symbolic linking to resolve
- -- non-PIC intra-package-relocations for
- -- performance (where symbolic linking works)
- -- See Note [-Bsymbolic assumptions by GHC]
- ["-Wl,-Bsymbolic" | not unregisterised]
-
- runLink dflags (
- map Option verbFlags
- ++ libmLinkOpts
- ++ [ Option "-o"
- , FileOption "" output_fn
- ]
- ++ map Option o_files
- ++ [ Option "-shared" ]
- ++ map Option bsymbolicFlag
- -- Set the library soname. We use -h rather than -soname as
- -- Solaris 10 doesn't support the latter:
- ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
- ++ extra_ld_inputs
- ++ map Option lib_path_opts
- ++ map Option pkg_lib_path_opts
- ++ map Option pkg_link_opts
- )
-
--- | Some platforms require that we explicitly link against @libm@ if any
--- math-y things are used (which we assume to include all programs). See #14022.
-libmLinkOpts :: [Option]
-libmLinkOpts =
-#if defined(HAVE_LIBM)
- [Option "-lm"]
-#else
- []
-#endif
-
-getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]
-getUnitFrameworkOpts dflags platform dep_packages
- | platformUsesFrameworks platform = do
- pkg_framework_path_opts <- do
- pkg_framework_paths <- getUnitFrameworkPath
- (initSDocContext dflags defaultUserStyle)
- (unitState dflags)
- (mkHomeUnitFromFlags dflags)
- dep_packages
- return $ map ("-F" ++) pkg_framework_paths
-
- pkg_framework_opts <- do
- pkg_frameworks <- getUnitFrameworks
- (initSDocContext dflags defaultUserStyle)
- (unitState dflags)
- (mkHomeUnitFromFlags dflags)
- dep_packages
- return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
-
- return (pkg_framework_path_opts ++ pkg_framework_opts)
-
- | otherwise = return []
-
-getFrameworkOpts :: DynFlags -> Platform -> [String]
-getFrameworkOpts dflags platform
- | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
- | otherwise = []
- where
- framework_paths = frameworkPaths dflags
- framework_path_opts = map ("-F" ++) framework_paths
-
- frameworks = cmdlineFrameworks dflags
- -- reverse because they're added in reverse order from the cmd line:
- framework_opts = concat [ ["-framework", fw]
- | fw <- reverse frameworks ]
-
-{-
-Note [-Bsymbolic assumptions by GHC]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-GHC has a few assumptions about interaction of relocations in NCG and linker:
-
-1. -Bsymbolic resolves internal references when the shared library is linked,
- which is important for performance.
-2. When there is a reference to data in a shared library from the main program,
- the runtime linker relocates the data object into the main program using an
- R_*_COPY relocation.
-3. If we used -Bsymbolic, then this results in multiple copies of the data
- object, because some references have already been resolved to point to the
- original instance. This is bad!
-
-We work around [3.] for native compiled code by avoiding the generation of
-R_*_COPY relocations.
-
-Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable
--Bsymbolic linking there.
-
-See related tickets: #4210, #15338
--}
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
index 8b6bd70bbd..50e25e025a 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ b/compiler/GHC/SysTools/Tasks.hs
@@ -26,11 +26,8 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc
import Data.List
-import Control.Monad (join, forM, filterM)
import System.IO
import System.Process
-import System.Directory (doesFileExist)
-import System.FilePath ((</>))
{-
************************************************************************
@@ -240,40 +237,6 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do
return Nothing)
--- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused
--- libraries from the dynamic library. We do this to reduce the number of load
--- commands that end up in the dylib, and has been limited to 32K (32768) since
--- macOS Sierra (10.14).
---
--- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing
--- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not
--- being included in the load commands, however the @-rpath@ entries are all
--- forced to be included. This can lead to 100s of @-rpath@ entries being
--- included when only a handful of libraries end up being truely linked.
---
--- Thus after building the library, we run a fixup phase where we inject the
--- @-rpath@ for each found library (in the given library search paths) into the
--- dynamic library through @-add_rpath@.
---
--- See Note [Dynamic linking on macOS]
-runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
-runInjectRPaths dflags lib_paths dylib = do
- info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib]
- -- filter the output for only the libraries. And then drop the @rpath prefix.
- let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
- -- find any pre-existing LC_PATH items
- info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib]
- let paths = concatMap f info
- where f ("path":p:_) = [p]
- f _ = []
- lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
- -- only find those rpaths, that aren't already in the library.
- rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')
- -- inject the rpaths
- case rpaths of
- [] -> return ()
- _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
-
runLink :: DynFlags -> [Option] -> IO ()
runLink dflags args = traceToolCommand dflags "linker" $ do
diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs
index 5f038f5d83..36193fce94 100644
--- a/compiler/GHC/Unit/Finder.hs
+++ b/compiler/GHC/Unit/Finder.hs
@@ -59,7 +59,7 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Runtime.Linker.Types
+import GHC.Linker.Types
import Data.IORef ( IORef, readIORef, atomicModifyIORef' )
import System.Directory
diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs
index 9732955521..fd97689972 100644
--- a/compiler/GHC/Unit/Home/ModInfo.hs
+++ b/compiler/GHC/Unit/Home/ModInfo.hs
@@ -24,7 +24,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module
-import GHC.Runtime.Linker.Types ( Linkable(..) )
+import GHC.Linker.Types ( Linkable(..) )
import GHC.Types.Unique
import GHC.Types.Unique.DFM
diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs
index 4b75dff099..640c258273 100644
--- a/compiler/GHC/Unit/Module/ModGuts.hs
+++ b/compiler/GHC/Unit/Module/ModGuts.hs
@@ -21,7 +21,7 @@ import GHC.Core ( CoreProgram, CoreRule )
import GHC.Core.TyCon
import GHC.Core.PatSyn
-import GHC.Runtime.Linker.Types ( SptEntry(..) )
+import GHC.Linker.Types ( SptEntry(..) )
import GHC.Types.Annotations ( Annotation )
import GHC.Types.Avail
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 1d770de9f1..74ba55a702 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -41,16 +41,10 @@ module GHC.Unit.State (
-- * Inspecting the set of packages in scope
getUnitIncludePath,
- getUnitLibraryPath,
- getUnitLinkOpts,
getUnitExtraCcOpts,
- getUnitFrameworkPath,
- getUnitFrameworks,
getPreloadUnitsAnd,
- collectArchives,
- collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
- packageHsLibs, getLibs,
+ collectIncludeDirs,
-- * Module hole substitution
ShHoleSubst,
@@ -1800,124 +1794,12 @@ getUnitIncludePath ctx unit_state home_unit pkgs =
collectIncludeDirs :: [UnitInfo] -> [FilePath]
collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps))
--- | Find all the library paths in these and the preload packages
-getUnitLibraryPath :: SDocContext -> UnitState -> HomeUnit -> Ways -> [UnitId] -> IO [String]
-getUnitLibraryPath ctx unit_state home_unit ws pkgs =
- collectLibraryPaths ws `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs
-
-collectLibraryPaths :: Ways -> [UnitInfo] -> [FilePath]
-collectLibraryPaths ws = ordNub . filter notNull
- . concatMap (libraryDirsForWay ws)
-
--- | Find all the link options in these and the preload packages,
--- returning (package hs lib options, extra library options, other flags)
-getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
-getUnitLinkOpts dflags pkgs =
- collectLinkOpts dflags `fmap` getPreloadUnitsAnd
- (initSDocContext dflags defaultUserStyle)
- (unitState dflags)
- (mkHomeUnitFromFlags dflags)
- pkgs
-
-collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])
-collectLinkOpts dflags ps =
- (
- concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
- concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,
- concatMap (map ST.unpack . unitLinkerOptions) ps
- )
-collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]
-collectArchives dflags pc =
- filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")
- | searchPath <- searchPaths
- , lib <- libs ]
- where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc
- libs = packageHsLibs dflags pc ++ (map ST.unpack $ unitExtDepLibsSys pc)
-
-getLibs :: DynFlags -> [UnitId] -> IO [(String,String)]
-getLibs dflags pkgs = do
- ps <- getPreloadUnitsAnd
- (initSDocContext dflags defaultUserStyle)
- (unitState dflags)
- (mkHomeUnitFromFlags dflags)
- pkgs
- fmap concat . forM ps $ \p -> do
- let candidates = [ (l </> f, f) | l <- collectLibraryPaths (ways dflags) [p]
- , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ]
- filterM (doesFileExist . fst) candidates
-
-packageHsLibs :: DynFlags -> UnitInfo -> [String]
-packageHsLibs dflags p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p)
- where
- ways0 = ways dflags
-
- ways1 = Set.filter (/= WayDyn) ways0
- -- the name of a shared library is libHSfoo-ghc<version>.so
- -- we leave out the _dyn, because it is superfluous
-
- -- debug and profiled RTSs include support for -eventlog
- ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1
- = Set.filter (/= WayTracing) ways1
- | otherwise
- = ways1
-
- tag = waysTag (fullWays ways2)
- rts_tag = waysTag ways2
-
- mkDynName x
- | WayDyn `Set.notMember` ways dflags = x
- | "HS" `isPrefixOf` x =
- x ++ '-':programName dflags ++ projectVersion dflags
- -- For non-Haskell libraries, we use the name "Cfoo". The .a
- -- file is libCfoo.a, and the .so is libfoo.so. That way the
- -- linker knows what we mean for the vanilla (-lCfoo) and dyn
- -- (-lfoo) ways. We therefore need to strip the 'C' off here.
- | Just x' <- stripPrefix "C" x = x'
- | otherwise
- = panic ("Don't understand library name " ++ x)
-
- -- Add _thr and other rts suffixes to packages named
- -- `rts` or `rts-1.0`. Why both? Traditionally the rts
- -- package is called `rts` only. However the tooling
- -- usually expects a package name to have a version.
- -- As such we will gradually move towards the `rts-1.0`
- -- package name, at which point the `rts` package name
- -- will eventually be unused.
- --
- -- This change elevates the need to add custom hooks
- -- and handling specifically for the `rts` package for
- -- example in ghc-cabal.
- addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
- addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag)
- addSuffix other_lib = other_lib ++ (expandTag tag)
-
- expandTag t | null t = ""
- | otherwise = '_':t
-
--- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.
-libraryDirsForWay :: Ways -> UnitInfo -> [String]
-libraryDirsForWay ws ui
- | WayDyn `elem` ws = map ST.unpack $ unitLibraryDynDirs ui
- | otherwise = map ST.unpack $ unitLibraryDirs ui
-
-- | Find all the C-compiler options in these and the preload packages
getUnitExtraCcOpts :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
getUnitExtraCcOpts ctx unit_state home_unit pkgs = do
ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs
return $ map ST.unpack (concatMap unitCcOptions ps)
--- | Find all the package framework paths in these and the preload packages
-getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
-getUnitFrameworkPath ctx unit_state home_unit pkgs = do
- ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs
- return $ map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps)))
-
--- | Find all the package frameworks in these and the preload packages
-getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
-getUnitFrameworks ctx unit_state home_unit pkgs = do
- ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs
- return $ map ST.unpack (concatMap unitExtDepFrameworks ps)
-
-- -----------------------------------------------------------------------------
-- Package Utils
View Lorry Controller Status