summaryrefslogtreecommitdiff
path: root/compiler/GHC/Linker
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Linker')
-rw-r--r--compiler/GHC/Linker/Dynamic.hs32
-rw-r--r--compiler/GHC/Linker/ExtraObj.hs124
-rw-r--r--compiler/GHC/Linker/Loader.hs20
-rw-r--r--compiler/GHC/Linker/MacOS.hs50
-rw-r--r--compiler/GHC/Linker/Static.hs43
-rw-r--r--compiler/GHC/Linker/Unit.hs95
6 files changed, 124 insertions, 240 deletions
diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs
index 497f51ec41..0a186bfcd6 100644
--- a/compiler/GHC/Linker/Dynamic.hs
+++ b/compiler/GHC/Linker/Dynamic.hs
@@ -16,9 +16,9 @@ import GHC.Platform.Ways
import GHC.Driver.Session
+import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.State
-import GHC.Utils.Outputable
import GHC.Linker.MacOS
import GHC.Linker.Unit
import GHC.SysTools.Tasks
@@ -26,11 +26,11 @@ import GHC.SysTools.Tasks
import qualified Data.Set as Set
import System.FilePath
-linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()
-linkDynLib dflags0 o_files dep_packages
+linkDynLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
+linkDynLib dflags0 unit_env o_files dep_packages
= do
- let platform = targetPlatform dflags0
- os = platformOS platform
+ let platform = ue_platform unit_env
+ os = platformOS platform
-- This is a rather ugly hack to fix dynamically linked
-- GHC on Windows. If GHC is linked with -threaded, then
@@ -47,22 +47,17 @@ linkDynLib dflags0 o_files dep_packages
verbFlags = getVerbFlags dflags
o_file = outputFile dflags
- pkgs_with_rts <- getPreloadUnitsAnd
- (initSDocContext dflags defaultUserStyle)
- (unitState dflags)
- (mkHomeUnitFromFlags dflags)
- dep_packages
+ pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
- let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs_with_rts
+ let pkg_lib_paths = collectLibraryDirs (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 &&
+ | osElfTarget os || osMachOTarget os
+ , 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
+ , gopt Opt_RPath dflags
= ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
-- See Note [-Xlinker -rpath vs -Wl,-rpath]
| otherwise = ["-L" ++ l]
@@ -96,8 +91,7 @@ linkDynLib dflags0 o_files dep_packages
let extra_ld_inputs = ldInputs dflags
-- frameworks
- pkg_framework_opts <- getUnitFrameworkOpts dflags platform
- (map unitId pkgs)
+ pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs)
let framework_opts = getFrameworkOpts dflags platform
case os of
diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs
index c130c93ca4..455cb3c2a4 100644
--- a/compiler/GHC/Linker/ExtraObj.hs
+++ b/compiler/GHC/Linker/ExtraObj.hs
@@ -20,33 +20,36 @@ module GHC.Linker.ExtraObj
)
where
+import GHC.Prelude
+import GHC.Platform
+
+import GHC.Unit
+import GHC.Unit.Env
+import GHC.Unit.State
+
import GHC.Utils.Asm
import GHC.Utils.Error
+import GHC.Utils.Misc
+import GHC.Utils.Outputable as Outputable
+
import GHC.Driver.Session
import GHC.Driver.Ppr
-import GHC.Unit.State
-import GHC.Platform
-import GHC.Utils.Outputable as Outputable
+
import GHC.Types.SrcLoc ( noSrcSpan )
-import GHC.Unit
-import GHC.SysTools.Elf
-import GHC.Utils.Misc
-import GHC.Prelude
import qualified GHC.Data.ShortText as ST
-import Control.Monad
-import Data.Maybe
-
-import Control.Monad.IO.Class
-
+import GHC.SysTools.Elf
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
+import Control.Monad.IO.Class
+import Control.Monad
+import Data.Maybe
+
+mkExtraObj :: DynFlags -> UnitState -> Suffix -> String -> IO FilePath
+mkExtraObj dflags unit_state extn xs
= do cFile <- newTempName dflags TFL_CurrentModule extn
oFile <- newTempName dflags TFL_GhcSession "o"
writeFile cFile xs
@@ -61,14 +64,12 @@ mkExtraObj dflags extn xs
else asmOpts ccInfo)
return oFile
where
- pkgs = unitState dflags
-
-- Pass a different set of options to the C compiler depending one whether
-- we're compiling C or assembler. When compiling C, we pass the usual
-- set of include directories and PIC flags.
cOpts = map Option (picCCOpts dflags)
++ map (FileOption "-I" . ST.unpack)
- (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit)
+ (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit)
-- When compiling assembler code, we drop the usual C options, and if the
-- compiler is Clang, we add an extra argument to tell Clang to ignore
@@ -86,15 +87,15 @@ mkExtraObj dflags extn xs
--
-- On Windows, when making a shared library we also may need a DllMain.
--
-mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
-mkExtraObjToLinkIntoBinary dflags = do
+mkExtraObjToLinkIntoBinary :: DynFlags -> UnitState -> IO FilePath
+mkExtraObjToLinkIntoBinary dflags unit_state = do
when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $
putLogMsg dflags NoReason SevInfo noSrcSpan
$ withPprStyle defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
text " Call hs_init_ghc() from your main() function to set these options.")
- mkExtraObj dflags "c" (showSDoc dflags main)
+ mkExtraObj dflags unit_state "c" (showSDoc dflags main)
where
main
| gopt Opt_NoHsMain dflags = Outputable.empty
@@ -152,53 +153,52 @@ mkExtraObjToLinkIntoBinary dflags = do
-- this was included as inline assembly in the main.c file but this
-- is pretty fragile. gas gets upset trying to calculate relative offsets
-- that span the .note section (notably .text) when debug info is present
-mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath]
-mkNoteObjsToLinkIntoBinary dflags dep_packages = do
- link_info <- getLinkInfo dflags dep_packages
+mkNoteObjsToLinkIntoBinary :: DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]
+mkNoteObjsToLinkIntoBinary dflags unit_env dep_packages = do
+ link_info <- getLinkInfo dflags unit_env dep_packages
if (platformSupportsSavingLinkOpts (platformOS platform ))
- then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
+ then fmap (:[]) $ mkExtraObj dflags unit_state "s" (showSDoc dflags (link_opts link_info))
else return []
where
- platform = targetPlatform dflags
- link_opts info = hcat [
- -- "link info" section (see Note [LinkInfo section])
- makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,
+ unit_state = ue_units unit_env
+ platform = ue_platform unit_env
+ link_opts info = hcat
+ [ -- "link info" section (see Note [LinkInfo section])
+ makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info
- -- ALL generated assembly must have this section to disable
- -- executable stacks. See also
- -- "GHC.CmmToAsm" for another instance
- -- where we need to do this.
- if platformHasGnuNonexecStack platform
- then text ".section .note.GNU-stack,\"\","
- <> sectionType platform "progbits" <> char '\n'
- else Outputable.empty
- ]
+ -- ALL generated assembly must have this section to disable
+ -- executable stacks. See also
+ -- "GHC.CmmToAsm" for another instance
+ -- where we need to do this.
+ , if platformHasGnuNonexecStack platform
+ then text ".section .note.GNU-stack,\"\","
+ <> sectionType platform "progbits" <> char '\n'
+ else Outputable.empty
+ ]
-- | Return the "link info" string
--
-- See Note [LinkInfo section]
-getLinkInfo :: DynFlags -> [UnitId] -> IO String
-getLinkInfo dflags dep_packages = do
- package_link_opts <- getUnitLinkOpts dflags dep_packages
- let unit_state = unitState dflags
- home_unit = mkHomeUnitFromFlags dflags
- ctx = initSDocContext dflags defaultUserStyle
- pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
- then getUnitFrameworks ctx unit_state home_unit dep_packages
- else return []
- let extra_ld_inputs = ldInputs dflags
- let
- link_info = (package_link_opts,
- pkg_frameworks,
- rtsOpts dflags,
- rtsOptsEnabled dflags,
- gopt Opt_NoHsMain dflags,
- map showOpt extra_ld_inputs,
- getOpts dflags opt_l)
- --
- return (show link_info)
+getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String
+getLinkInfo dflags unit_env dep_packages = do
+ package_link_opts <- getUnitLinkOpts dflags unit_env dep_packages
+ pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env))
+ then return []
+ else do
+ ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
+ return (collectFrameworks ps)
+ let link_info =
+ ( package_link_opts
+ , pkg_frameworks
+ , rtsOpts dflags
+ , rtsOptsEnabled dflags
+ , gopt Opt_NoHsMain dflags
+ , map showOpt (ldInputs dflags)
+ , getOpts dflags opt_l
+ )
+ return (show link_info)
platformSupportsSavingLinkOpts :: OS -> Bool
platformSupportsSavingLinkOpts os
@@ -216,9 +216,9 @@ ghcLinkInfoNoteName = "GHC link info"
-- Returns 'False' if it was, and we can avoid linking, because the
-- previous binary was linked with "the same options".
-checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool
-checkLinkInfo dflags pkg_deps exe_file
- | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
+checkLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool
+checkLinkInfo dflags unit_env pkg_deps exe_file
+ | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env)))
-- ToDo: Windows and OS X do not use the ELF binary format, so
-- readelf does not work there. We need to find another way to do
-- this.
@@ -227,7 +227,7 @@ checkLinkInfo dflags pkg_deps exe_file
-- time so we leave it as-is.
| otherwise
= do
- link_info <- getLinkInfo dflags pkg_deps
+ link_info <- getLinkInfo dflags unit_env pkg_deps
debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)
m_exe_link_info <- readElfNoteAsString dflags exe_file
ghcLinkInfoSectionName ghcLinkInfoNoteName
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index a23a1f735d..a316af61db 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -35,6 +35,8 @@ where
import GHC.Prelude
+import GHC.Settings
+
import GHC.Platform
import GHC.Platform.Ways
@@ -69,6 +71,7 @@ import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Error
+import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
@@ -280,14 +283,13 @@ initLoaderState hsc_env = do
reallyInitLoaderState :: HscEnv -> IO LoaderState
reallyInitLoaderState hsc_env = do
-- Initialise the linker state
- let dflags = hsc_dflags hsc_env
- pls0 = emptyLS
+ let pls0 = emptyLS
-- (a) initialise the C dynamic linker
initObjLinker hsc_env
-- (b) Load packages from the command-line (Note [preload packages])
- pls <- loadPackages' hsc_env (preloadUnits (unitState dflags)) pls0
+ pls <- loadPackages' hsc_env (preloadUnits (hsc_units hsc_env)) pls0
-- steps (c), (d) and (e)
loadCmdLineLibs' hsc_env pls
@@ -911,8 +913,9 @@ loadObjects hsc_env pls objs = do
dynLoadObjs :: HscEnv -> LoaderState -> [FilePath] -> IO LoaderState
dynLoadObjs _ pls [] = return pls
dynLoadObjs hsc_env pls@LoaderState{..} objs = do
+ let unit_env = hsc_unit_env hsc_env
let dflags = hsc_dflags hsc_env
- let platform = targetPlatform dflags
+ let platform = ue_platform unit_env
let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
(soFile, libPath , libName) <-
@@ -962,7 +965,7 @@ dynLoadObjs hsc_env pls@LoaderState{..} objs = do
-- link all "loaded packages" so symbols in those can be resolved
-- Note: We are loading packages with local scope, so to see the
-- symbols in this link we must link all loaded packages again.
- linkDynLib dflags2 objs pkgs_loaded
+ linkDynLib dflags2 unit_env objs pkgs_loaded
-- if we got this far, extend the lifetime of the library file
changeTempFilesLifetime dflags TFL_GhcSession [soFile]
@@ -1250,9 +1253,6 @@ loadPackages' hsc_env new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
- dflags = hsc_dflags hsc_env
- pkgstate = unitState dflags
-
link :: [UnitId] -> [UnitId] -> IO [UnitId]
link pkgs new_pkgs =
foldM link_one pkgs new_pkgs
@@ -1261,7 +1261,7 @@ loadPackages' hsc_env new_pks pls = do
| new_pkg `elem` pkgs -- Already linked
= return pkgs
- | Just pkg_cfg <- lookupUnitId pkgstate new_pkg
+ | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg
= do { -- Link dependents first
pkgs' <- link pkgs (unitDepends pkg_cfg)
-- Now link the package itself
@@ -1522,7 +1522,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib
, "lib" ++ lib <.> "dll.a", lib <.> "dll.a"
]
- hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
+ hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags)
hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name
so_name = platformSOName platform lib
diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs
index e91ee8c5d1..09204575c1 100644
--- a/compiler/GHC/Linker/MacOS.hs
+++ b/compiler/GHC/Linker/MacOS.hs
@@ -1,8 +1,6 @@
module GHC.Linker.MacOS
( runInjectRPaths
- , getUnitFrameworks
, getUnitFrameworkOpts
- , getUnitFrameworkPath
, getFrameworkOpts
, loadFramework
)
@@ -16,17 +14,13 @@ import GHC.Driver.Env
import GHC.Unit.Types
import GHC.Unit.State
-import GHC.Unit.Home
+import GHC.Unit.Env
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)
@@ -67,26 +61,15 @@ runInjectRPaths dflags lib_paths dylib = do
[] -> 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)
+getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String]
+getUnitFrameworkOpts unit_env dep_packages
+ | platformUsesFrameworks (ue_platform unit_env) = do
+ ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
+ let pkg_framework_path_opts = map ("-F" ++) (collectFrameworksDirs ps)
+ pkg_framework_opts = concat [ ["-framework", fw]
+ | fw <- collectFrameworks ps
+ ]
+ return (pkg_framework_path_opts ++ pkg_framework_opts)
| otherwise = return []
@@ -104,19 +87,6 @@ getFrameworkOpts dflags platform
| 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs
index 9d0862e3f3..4fa69c00e4 100644
--- a/compiler/GHC/Linker/Static.hs
+++ b/compiler/GHC/Linker/Static.hs
@@ -15,13 +15,13 @@ import GHC.SysTools
import GHC.SysTools.Ar
import GHC.SysTools.FileCleanup
+import GHC.Unit.Env
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
@@ -62,16 +62,16 @@ it is supported by both gcc and clang. Anecdotally nvcc supports
-Xlinker, but not -Wl.
-}
-linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
+linkBinary :: DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkBinary = linkBinary' False
-linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
-linkBinary' staticLink dflags o_files dep_units = do
- let platform = targetPlatform dflags
+linkBinary' :: Bool -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
+linkBinary' staticLink dflags unit_env o_files dep_units = do
+ let platform = ue_platform unit_env
+ unit_state = ue_units unit_env
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
@@ -81,12 +81,8 @@ linkBinary' staticLink dflags o_files dep_units = do
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
+ pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)
+ let pkg_lib_paths = collectLibraryDirs (ways dflags) pkgs
let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
get_pkg_lib_path_opts l
| osElfTarget (platformOS platform) &&
@@ -124,7 +120,7 @@ linkBinary' staticLink dflags o_files dep_units = do
pkg_lib_path_opts <-
if gopt Opt_SingleLibFolder dflags
then do
- libs <- getLibs dflags dep_units
+ libs <- getLibs dflags unit_env dep_units
tmpDir <- newTempDir dflags
sequence_ [ copyFile lib (tmpDir </> basename)
| (lib, basename) <- libs]
@@ -140,8 +136,8 @@ linkBinary' staticLink dflags o_files dep_units = do
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
- extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
- noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units
+ extraLinkObj <- mkExtraObjToLinkIntoBinary dflags unit_state
+ noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags unit_env dep_units
let
(pre_hs_libs, post_hs_libs)
@@ -154,7 +150,7 @@ linkBinary' staticLink dflags o_files dep_units = do
= ([],[])
pkg_link_opts <- do
- (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units
+ (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags unit_env 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
@@ -176,7 +172,7 @@ linkBinary' staticLink dflags o_files dep_units = do
-- that defines the symbol."
-- frameworks
- pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units
+ pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units
let framework_opts = getFrameworkOpts dflags platform
-- probably _stub.o files
@@ -273,13 +269,12 @@ linkBinary' staticLink dflags o_files dep_units = do
-- | 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
+linkStaticLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
+linkStaticLib dflags unit_env o_files dep_units = do
+ let platform = ue_platform unit_env
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
@@ -288,11 +283,7 @@ linkStaticLib dflags o_files dep_units = do
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
+ pkg_cfgs_init <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)
let pkg_cfgs
| gopt Opt_LinkRts dflags
diff --git a/compiler/GHC/Linker/Unit.hs b/compiler/GHC/Linker/Unit.hs
index 90326859f4..7aec5263e3 100644
--- a/compiler/GHC/Linker/Unit.hs
+++ b/compiler/GHC/Linker/Unit.hs
@@ -3,11 +3,8 @@
module GHC.Linker.Unit
( collectLinkOpts
, collectArchives
- , collectLibraryPaths
, getUnitLinkOpts
- , getUnitLibraryPath
, getLibs
- , packageHsLibs
)
where
@@ -16,35 +13,28 @@ 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.Unit.Env
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
+getUnitLinkOpts :: DynFlags -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])
+getUnitLinkOpts dflags unit_env pkgs = do
+ ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs
+ return (collectLinkOpts dflags ps)
collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])
collectLinkOpts dflags ps =
(
- concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
+ concatMap (map ("-l" ++) . unitHsLibs (ghcNameVersion dflags) (ways dflags)) ps,
concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,
concatMap (map ST.unpack . unitLinkerOptions) ps
)
@@ -55,11 +45,7 @@ collectArchives dflags pc =
| 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)
+ libs = unitHsLibs (ghcNameVersion dflags) (ways dflags) pc ++ map ST.unpack (unitExtDepLibsSys pc)
-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.
libraryDirsForWay :: Ways -> UnitInfo -> [String]
@@ -67,68 +53,11 @@ 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
+getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)]
+getLibs dflags unit_env pkgs = do
+ ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env 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 ]
+ let candidates = [ (l </> f, f) | l <- collectLibraryDirs (ways dflags) [p]
+ , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs (ghcNameVersion dflags) (ways 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
-
View Lorry Controller Status