diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-10-12 12:43:38 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-11-03 17:40:34 -0500 |
| commit | 14ce454f7294381225b4211dc191a167a386e380 (patch) | |
| tree | 00dde0d9eeaee019842352560bc42f7147e4abaa | |
| parent | 78f2767d4db5e69a142ac6a408a217b11c35949d (diff) | |
| download | haskell-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
33 files changed, 1400 insertions, 1210 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index d9ebd356f2..f3204c8bc2 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -621,12 +621,6 @@ checkBrokenTablesNextToCode' dflags -- read), and prepares the compilers knowledge about packages. It can -- be called again to load new packages: just add new package flags to -- (packageFlags dflags). --- --- Returns a list of new packages that may need to be linked in using --- the dynamic linker (see 'linkPackages') as a result of new package --- flags. If you are not doing linking or doing static linking, you --- can ignore the list of packages returned. --- setSessionDynFlags :: GhcMonad m => DynFlags -> m () setSessionDynFlags dflags0 = do dflags1 <- checkNewDynFlags dflags0 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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 78f23a4b8b..98335da373 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -452,6 +452,15 @@ Library GHC.IfaceToCore GHC.Iface.Type GHC.Iface.UpdateIdInfos + GHC.Linker + GHC.Linker.Dynamic + GHC.Linker.ExtraObj + GHC.Linker.Loader + GHC.Linker.MacOS + GHC.Linker.Static + GHC.Linker.Types + GHC.Linker.Unit + GHC.Linker.Windows GHC.Llvm GHC.Llvm.MetaData GHC.Llvm.Ppr @@ -503,8 +512,6 @@ Library GHC.Runtime.Heap.Layout GHC.Runtime.Interpreter GHC.Runtime.Interpreter.Types - GHC.Runtime.Linker - GHC.Runtime.Linker.Types GHC.Runtime.Loader GHC.Settings GHC.Settings.Config @@ -545,7 +552,6 @@ Library GHC.SysTools.Ar GHC.SysTools.BaseDir GHC.SysTools.Elf - GHC.SysTools.ExtraObj GHC.SysTools.FileCleanup GHC.SysTools.Info GHC.SysTools.Process diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs index 99f49fddb9..e973390e3e 100644 --- a/ghc/GHCi/Leak.hs +++ b/ghc/GHCi/Leak.hs @@ -17,7 +17,7 @@ import GHC.Utils.Outputable import GHC.Unit.Module.ModDetails import GHC.Unit.Home.ModInfo import GHC.Platform (target32Bit) -import GHC.Runtime.Linker.Types +import GHC.Linker.Types import Prelude import System.Mem import System.Mem.Weak diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index d41f46a4a2..2c2b9fc3bb 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -89,7 +89,7 @@ import GHC.Settings.Config import GHC.Data.Graph.Directed import GHC.Utils.Encoding import GHC.Data.FastString -import GHC.Runtime.Linker +import qualified GHC.Linker.Loader as Loader import GHC.Data.Maybe ( orElse, expectJust ) import GHC.Types.Name.Set import GHC.Utils.Panic hiding ( showException, try ) @@ -2965,7 +2965,7 @@ newDynFlags interactive_only minus_opts = do clearAllTargets when must_reload $ do let units = preloadUnits (unitState dflags2) - liftIO $ linkPackages hsc_env units + liftIO $ Loader.loadPackages hsc_env units -- package flags changed, we can't re-use any of the old context setContextAfterLoad False [] -- and copy the package state to the interactive DynFlags @@ -2986,7 +2986,7 @@ newDynFlags interactive_only minus_opts = do , cmdlineFrameworks = newCLFrameworks } } when (not (null newLdInputs && null newCLFrameworks)) $ - liftIO $ linkCmdLineLibs hsc_env' + liftIO $ Loader.loadCmdLineLibs hsc_env' return () @@ -3088,7 +3088,7 @@ showCmd str = do , action "modules" $ showModules , action "bindings" $ showBindings , action "linker" $ do - msg <- liftIO $ showLinkerState (hsc_dynLinker hsc_env) + msg <- liftIO $ Loader.showLoaderState (hsc_loader hsc_env) dflags <- getDynFlags liftIO $ putLogMsg dflags NoReason SevDump noSrcSpan msg , action "breaks" $ showBkptTable diff --git a/testsuite/tests/ghc-api/T4891/T4891.hs b/testsuite/tests/ghc-api/T4891/T4891.hs index 89a8403b94..4ae055daa4 100644 --- a/testsuite/tests/ghc-api/T4891/T4891.hs +++ b/testsuite/tests/ghc-api/T4891/T4891.hs @@ -8,7 +8,7 @@ import GHC.Core.DataCon import GHC import GHC.Exts.Heap import GHC.Driver.Ppr -import GHC.Runtime.Linker +import GHC.Linker.Loader import GHC.Runtime.Heap.Inspect import GHC.Tc.Utils.Env import GHC.Core.Type diff --git a/testsuite/tests/ghci/linking/T11531.stderr b/testsuite/tests/ghci/linking/T11531.stderr index 98b9219530..b6527a3268 100644 --- a/testsuite/tests/ghci/linking/T11531.stderr +++ b/testsuite/tests/ghci/linking/T11531.stderr @@ -1,5 +1,5 @@ -GHC.Runtime.Linker.dynLoadObjs: Loading temp shared object failed +GHC.Linker.Runtime.dynLoadObjs: Loading temp shared object failed During interactive linking, GHCi couldn't find the following symbol: This may be due to you not asking GHCi to load extra object files, archives or DLLs needed by your current session. Restart GHCi, specifying diff --git a/testsuite/tests/rts/linker/LinkerUnload.hs b/testsuite/tests/rts/linker/LinkerUnload.hs index 9c1d08249c..9bdc92fdc2 100644 --- a/testsuite/tests/rts/linker/LinkerUnload.hs +++ b/testsuite/tests/rts/linker/LinkerUnload.hs @@ -4,7 +4,7 @@ import GHC import GHC.Unit.State import GHC.Driver.Session import GHC.Driver.Backend -import GHC.Runtime.Linker as Linker +import qualified GHC.Linker.Loader as Loader import System.Environment import GHC.Utils.Monad ( MonadIO(..) ) @@ -19,4 +19,4 @@ loadPackages = do , ghcLink = LinkInMemory } setSessionDynFlags dflags' hsc_env <- getSession - liftIO $ Linker.linkPackages hsc_env (preloadUnits (unitState dflags')) + liftIO $ Loader.loadPackages hsc_env (preloadUnits (unitState dflags')) |