From 14ce454f7294381225b4211dc191a167a386e380 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 12 Oct 2020 12:43:38 +0200 Subject: 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 --- compiler/GHC.hs | 6 - compiler/GHC/Driver/Backpack.hs | 2 +- compiler/GHC/Driver/Env.hs | 6 +- compiler/GHC/Driver/Main.hs | 17 +- compiler/GHC/Driver/Make.hs | 11 +- compiler/GHC/Driver/Pipeline.hs | 375 +----- compiler/GHC/HsToCore/Usage.hs | 2 + compiler/GHC/Iface/Tidy/StaticPtrTable.hs | 3 +- compiler/GHC/Linker.hs | 36 + compiler/GHC/Linker/Dynamic.hs | 264 ++++ compiler/GHC/Linker/ExtraObj.hs | 260 ++++ compiler/GHC/Linker/Loader.hs | 1721 ++++++++++++++++++++++++++ compiler/GHC/Linker/MacOS.hs | 183 +++ compiler/GHC/Linker/Static.hs | 342 ++++++ compiler/GHC/Linker/Types.hs | 176 +++ compiler/GHC/Linker/Unit.hs | 134 +++ compiler/GHC/Linker/Windows.hs | 64 + compiler/GHC/Runtime/Debugger.hs | 11 +- compiler/GHC/Runtime/Eval.hs | 27 +- compiler/GHC/Runtime/Interpreter.hs | 3 +- compiler/GHC/Runtime/Linker.hs | 1802 ---------------------------- compiler/GHC/Runtime/Linker/Types.hs | 153 --- compiler/GHC/Runtime/Loader.hs | 6 +- compiler/GHC/SysTools.hs | 298 +---- compiler/GHC/SysTools/ExtraObj.hs | 251 ---- compiler/GHC/SysTools/Tasks.hs | 37 - compiler/GHC/Unit/Finder.hs | 2 +- compiler/GHC/Unit/Home/ModInfo.hs | 2 +- compiler/GHC/Unit/Module/ModGuts.hs | 2 +- compiler/GHC/Unit/State.hs | 120 +- compiler/ghc.cabal.in | 12 +- ghc/GHCi/Leak.hs | 2 +- ghc/GHCi/UI.hs | 8 +- testsuite/tests/ghc-api/T4891/T4891.hs | 2 +- testsuite/tests/ghci/linking/T11531.stderr | 2 +- testsuite/tests/rts/linker/LinkerUnload.hs | 4 +- 36 files changed, 3268 insertions(+), 3078 deletions(-) create mode 100644 compiler/GHC/Linker.hs create mode 100644 compiler/GHC/Linker/Dynamic.hs create mode 100644 compiler/GHC/Linker/ExtraObj.hs create mode 100644 compiler/GHC/Linker/Loader.hs create mode 100644 compiler/GHC/Linker/MacOS.hs create mode 100644 compiler/GHC/Linker/Static.hs create mode 100644 compiler/GHC/Linker/Types.hs create mode 100644 compiler/GHC/Linker/Unit.hs create mode 100644 compiler/GHC/Linker/Windows.hs delete mode 100644 compiler/GHC/Runtime/Linker.hs delete mode 100644 compiler/GHC/Runtime/Linker/Types.hs delete mode 100644 compiler/GHC/SysTools/ExtraObj.hs 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 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, contained in other_flags - -- needs to be put before -l, - -- 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 $ - "\n"++ - " \n"++ - " \n\n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - "\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/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs new file mode 100644 index 0000000000..c130c93ca4 --- /dev/null +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -0,0 +1,260 @@ +----------------------------------------------------------------------------- +-- +-- GHC Extra object linking code +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- + +module GHC.Linker.ExtraObj + ( mkExtraObj + , mkExtraObjToLinkIntoBinary + , mkNoteObjsToLinkIntoBinary + , checkLinkInfo + , getLinkInfo + , getCompilerInfo + , ghcLinkInfoSectionName + , ghcLinkInfoNoteName + , platformSupportsSavingLinkOpts + , haveRtsOptsFlags + ) +where + +import GHC.Utils.Asm +import GHC.Utils.Error +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Unit.State +import GHC.Platform +import GHC.Utils.Outputable as Outputable +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Unit +import GHC.SysTools.Elf +import GHC.Utils.Misc +import GHC.Prelude +import qualified GHC.Data.ShortText as ST + +import Control.Monad +import Data.Maybe + +import Control.Monad.IO.Class + +import GHC.SysTools.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 + = do cFile <- newTempName dflags TFL_CurrentModule extn + oFile <- newTempName dflags TFL_GhcSession "o" + writeFile cFile xs + ccInfo <- liftIO $ getCompilerInfo dflags + runCc Nothing dflags + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ if extn /= "s" + then cOpts + else asmOpts ccInfo) + return oFile + where + pkgs = unitState dflags + + -- Pass a different set of options to the C compiler depending one whether + -- we're compiling C or assembler. When compiling C, we pass the usual + -- set of include directories and PIC flags. + cOpts = map Option (picCCOpts dflags) + ++ map (FileOption "-I" . ST.unpack) + (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit) + + -- When compiling assembler code, we drop the usual C options, and if the + -- compiler is Clang, we add an extra argument to tell Clang to ignore + -- unused command line options. See trac #11684. + asmOpts ccInfo = + if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [Option "-Qunused-arguments"] + else [] + +-- When linking a binary, we need to create a C main() function that +-- starts everything off. This used to be compiled statically as part +-- of the RTS, but that made it hard to change the -rtsopts setting, +-- so now we generate and compile a main() stub as part of every +-- binary and pass the -rtsopts setting directly to the RTS (#5373) +-- +-- On Windows, when making a shared library we also may need a DllMain. +-- +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do + when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ + putLogMsg dflags NoReason SevInfo noSrcSpan + $ withPprStyle defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + mkExtraObj dflags "c" (showSDoc dflags main) + where + main + | gopt Opt_NoHsMain dflags = Outputable.empty + | otherwise + = case ghcLink dflags of + LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32 + then dllMain + else Outputable.empty + _ -> exeMain + + exeMain = vcat [ + text "#include ", + text "extern StgClosure ZCMain_main_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (rtsOptsEnabled dflags)) <> semi, + text " __conf.rts_opts_suggestions = " + <> text (if rtsOptsSuggestions dflags + then "true" + else "false") <> semi, + text "__conf.keep_cafs = " + <> text (if gopt Opt_KeepCAFs dflags + then "true" + else "false") <> semi, + case rtsOpts dflags of + Nothing -> Outputable.empty + Just opts -> text " __conf.rts_opts= " <> + text (show opts) <> semi, + text " __conf.rts_hs_main = true;", + text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", + char '}', + char '\n' -- final newline, to keep gcc happy + ] + + dllMain = vcat [ + text "#include ", + text "#include ", + text "#include ", + char '\n', + text "bool", + text "WINAPI", + text "DllMain ( HINSTANCE hInstance STG_UNUSED", + text " , DWORD reason STG_UNUSED", + text " , LPVOID reserved STG_UNUSED", + text " )", + text "{", + text " return true;", + text "}", + char '\n' -- final newline, to keep gcc happy + ] + +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + + if (platformSupportsSavingLinkOpts (platformOS platform )) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) + else return [] + + where + platform = targetPlatform dflags + link_opts info = hcat [ + -- "link info" section (see Note [LinkInfo section]) + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- "GHC.CmmToAsm" for another instance + -- where we need to do this. + if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\"," + <> sectionType platform "progbits" <> char '\n' + else Outputable.empty + ] + +-- | Return the "link info" string +-- +-- See Note [LinkInfo section] +getLinkInfo :: DynFlags -> [UnitId] -> IO String +getLinkInfo dflags dep_packages = do + package_link_opts <- getUnitLinkOpts dflags dep_packages + let unit_state = unitState dflags + home_unit = mkHomeUnitFromFlags dflags + ctx = initSDocContext dflags defaultUserStyle + pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) + then getUnitFrameworks ctx unit_state home_unit dep_packages + else return [] + let extra_ld_inputs = ldInputs dflags + let + link_info = (package_link_opts, + pkg_frameworks, + rtsOpts dflags, + rtsOptsEnabled dflags, + gopt Opt_NoHsMain dflags, + map showOpt extra_ld_inputs, + getOpts dflags opt_l) + -- + return (show link_info) + +platformSupportsSavingLinkOpts :: OS -> Bool +platformSupportsSavingLinkOpts os + | os == OSSolaris2 = False -- see #5382 + | otherwise = osElfTarget os + +-- See Note [LinkInfo section] +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default + +-- Identifier for the note (see Note [LinkInfo section]) +ghcLinkInfoNoteName :: String +ghcLinkInfoNoteName = "GHC link info" + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo dflags pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags pkg_deps + debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString dflags exe_file + ghcLinkInfoSectionName ghcLinkInfoNoteName + let sameLinkInfo = (Just link_info == m_exe_link_info) + debugTraceMsg dflags 3 $ case m_exe_link_info of + Nothing -> text "Exe link info: Not found" + Just s + | sameLinkInfo -> text ("Exe link info is the same") + | otherwise -> text ("Exe link info is different: " ++ s) + return (not sameLinkInfo) + +{- Note [LinkInfo section] + ~~~~~~~~~~~~~~~~~~~~~~~ + +The "link info" is a string representing the parameters of the link. We save +this information in the binary, and the next time we link, if nothing else has +changed, we use the link info stored in the existing binary to decide whether +to re-link or not. + +The "link info" string is stored in a ELF section called ".debug-ghc-link-info" +(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to +not follow the specified record-based format (see #11022). + +-} + +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs new file mode 100644 index 0000000000..d040fe71e5 --- /dev/null +++ b/compiler/GHC/Linker/Loader.hs @@ -0,0 +1,1721 @@ +{-# LANGUAGE CPP, TupleSections, RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} + +-- +-- (c) The University of Glasgow 2002-2006 + +-- | The loader +-- +-- 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 + -- * LoadedEnv + , withExtendedLoadedEnv + , extendLoadedEnv + , deleteFromLoadedEnv + -- * Misc + , extendLoadedPkgs + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Driver.Phases +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr + +import GHC.Tc.Utils.Monad + +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types +import GHCi.RemoteTypes + +import GHC.Iface.Load + +import GHC.ByteCode.Linker +import GHC.ByteCode.Asm +import GHC.ByteCode.Types + +import GHC.SysTools +import GHC.SysTools.FileCleanup + +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.Unique.DSet + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Error + +import GHC.Unit.Finder +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps +import GHC.Unit.Home +import GHC.Unit.Home.ModInfo +import GHC.Unit.State as Packages + +import qualified GHC.Data.ShortText as ST +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 + +import qualified Data.Set as Set +import Data.Char (isSpace) +import Data.Function ((&)) +import Data.IORef +import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) +import Data.Maybe +import Control.Concurrent.MVar +import qualified Control.Monad.Catch as MC + +import System.FilePath +import System.Directory +import System.IO.Unsafe +import System.Environment (lookupEnv) + +#if defined(mingw32_HOST_OS) +import System.Win32.Info (getSystemDirectory) +#endif + +import GHC.Utils.Exception + +uninitialised :: a +uninitialised = panic "Loader not initialised" + +modifyLS_ :: Loader -> (LoaderState -> IO LoaderState) -> IO () +modifyLS_ dl f = + modifyMVar_ (loader_state dl) (fmap 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)) + +readLS :: Loader -> IO LoaderState +readLS dl = + (fmap (fromMaybe uninitialised) . readMVar) (loader_state dl) + +modifyMbLS_ + :: Loader -> (Maybe LoaderState -> IO (Maybe LoaderState)) -> IO () +modifyMbLS_ dl f = modifyMVar_ (loader_state dl) f + +emptyLS :: LoaderState +emptyLS = LoaderState + { closure_env = emptyNameEnv + , itbl_env = emptyNameEnv + , pkgs_loaded = init_pkgs + , bcos_loaded = [] + , objs_loaded = [] + , temp_sos = [] + } + -- Packages that don't need loading, because the compiler + -- shares them with the interpreted program. + -- + -- The linker's symbol table is populated with RTS symbols using an + -- explicit list. See rts/Linker.c for details. + where init_pkgs = [rtsUnitId] + +extendLoadedPkgs :: Loader -> [UnitId] -> IO () +extendLoadedPkgs dl pkgs = + modifyLS_ dl $ \s -> + return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } + +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 + +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 } + +-- | Load the module containing the given Name and get its associated 'HValue'. +-- +-- Throws a 'ProgramError' if loading fails or the name cannot be found. +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 (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. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay hsc_env span + + -- Find what packages and linkables are required + (lnks, pkgs) <- getLinkDeps hsc_env hpt pls + maybe_normal_osuf span needed_mods + + -- Link the packages and modules required + pls1 <- loadPackages' hsc_env pkgs pls + loadModules hsc_env pls1 lnks + + +-- | Temporarily extend the loaded 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 + -- Remember that the linker state might be side-effected + -- during the execution of the IO action, and we don't want to + -- lose those changes (we might have linked a new module or + -- package), so the reset action only removes the names we + -- added earlier. + reset_old_env = liftIO $ + 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. +showLoaderState :: Loader -> IO SDoc +showLoaderState dl + = do pls <- readLS dl + return $ withPprStyle defaultDumpStyle + (vcat [text "----- Loader state -----", + text "Pkgs:" <+> ppr (pkgs_loaded pls), + text "Objs:" <+> ppr (objs_loaded pls), + text "BCOs:" <+> ppr (bcos_loaded pls)]) + + +{- ********************************************************************** + + Initialisation + + ********************************************************************* -} + +-- | Initialise the dynamic linker. This entails +-- +-- a) Calling the C initialisation procedure, +-- +-- b) Loading any packages specified on the command line, +-- +-- c) Loading any packages specified on the command line, now held in the +-- @-l@ options in @v_Opt_l@, +-- +-- d) Loading any @.o\/.dll@ files specified on the command line, now held +-- in @ldInputs@, +-- +-- e) Loading any MacOS frameworks. +-- +-- NOTE: This function is idempotent; if called more than once, it does +-- nothing. This is useful in Template Haskell, where we call it before +-- trying to link. +-- +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 <$> reallyInitLoaderState hsc_env + +reallyInitLoaderState :: HscEnv -> IO LoaderState +reallyInitLoaderState hsc_env = do + -- Initialise the linker state + let dflags = hsc_dflags hsc_env + pls0 = emptyLS + + -- (a) initialise the C dynamic linker + initObjLinker hsc_env + + -- (b) Load packages from the command-line (Note [preload packages]) + pls <- loadPackages' hsc_env (preloadUnits (unitState dflags)) pls0 + + -- steps (c), (d) and (e) + loadCmdLineLibs' 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 + +loadCmdLineLibs' :: HscEnv -> LoaderState -> IO LoaderState +loadCmdLineLibs' hsc_env pls = + do + let dflags@(DynFlags { ldInputs = cmdline_ld_inputs + , libraryPaths = lib_paths_base}) + = hsc_dflags hsc_env + + -- (c) Link libraries from the command-line + let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] + + -- On Windows we want to add libpthread by default just as GCC would. + -- However because we don't know the actual name of pthread's dll we + -- need to defer this to the locateLib call so we can't initialize it + -- inside of the rts. Instead we do it here to be able to find the + -- import library for pthreads. See #13210. + let platform = targetPlatform dflags + os = platformOS platform + minus_ls = case os of + OSMinGW32 -> "pthread" : minus_ls_1 + _ -> minus_ls_1 + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths dflags os + + lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base + + maybePutStrLn dflags "Search directories (user):" + maybePutStr dflags (unlines $ map (" "++) lib_paths_env) + maybePutStrLn dflags "Search directories (gcc):" + maybePutStr dflags (unlines $ map (" "++) gcc_paths) + + libspecs + <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls + + -- (d) Link .o files from the command-line + classified_ld_inputs <- mapM (classifyLdInput dflags) + [ f | FileOption _ f <- cmdline_ld_inputs ] + + -- (e) Link any MacOS frameworks + let platform = targetPlatform dflags + let (framework_paths, frameworks) = + if platformUsesFrameworks platform + then (frameworkPaths dflags, cmdlineFrameworks dflags) + else ([],[]) + + -- Finally do (c),(d),(e) + 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 + +-- | Merge runs of consecutive of 'Objects'. This allows for resolution of +-- cyclic symbol references when dynamically linking. Specifically, we link +-- together all of the static objects into a single shared object, avoiding +-- the issue we saw in #13786. +mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec] +mergeStaticObjects specs = go [] specs + where + go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec] + go accum (Objects objs : rest) = go (objs ++ accum) rest + go accum@(_:_) rest = Objects (reverse accum) : go [] rest + go [] (spec:rest) = spec : go [] rest + go [] [] = [] + +{- Note [preload packages] + +Why do we need to preload packages from the command line? This is an +explanation copied from #2437: + +I tried to implement the suggestion from #3560, thinking it would be +easy, but there are two reasons we link in packages eagerly when they +are mentioned on the command line: + + * So that you can link in extra object files or libraries that + depend on the packages. e.g. ghc -package foo -lbar where bar is a + C library that depends on something in foo. So we could link in + foo eagerly if and only if there are extra C libs or objects to + link in, but.... + + * Haskell code can depend on a C function exported by a package, and + the normal dependency tracking that TH uses can't know about these + dependencies. The test ghcilink004 relies on this, for example. + +I conclude that we need two -package flags: one that says "this is a +package I want to make available", and one that says "this is a +package I want to link in eagerly". Would that be too complicated for +users? +-} + +classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput dflags f + | isObjectFilename platform f = return (Just (Objects [f])) + | isDynLibFilename platform f = return (Just (DLLPath f)) + | otherwise = do + putLogMsg dflags NoReason SevInfo noSrcSpan + $ withPprStyle defaultUserStyle + (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) + return Nothing + where platform = targetPlatform dflags + +preloadLib + :: 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 + Objects static_ishs -> do + (b, pls1) <- preload_statics lib_paths static_ishs + maybePutStrLn dflags (if b then "done" else "not found") + return pls1 + + Archive static_ish -> do + b <- preload_static_archive lib_paths static_ish + maybePutStrLn dflags (if b then "done" else "not found") + return pls + + DLL dll_unadorned -> do + maybe_errstr <- loadDLL hsc_env (platformSOName platform dll_unadorned) + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm | platformOS platform /= OSDarwin -> + preloadFailed mm lib_paths lib_spec + Just mm | otherwise -> do + -- As a backup, on Darwin, try to also load a .so file + -- since (apparently) some things install that way - see + -- ticket #8770. + let libfile = ("lib" ++ dll_unadorned) <.> "so" + err2 <- loadDLL hsc_env libfile + case err2 of + Nothing -> maybePutStrLn dflags "done" + Just _ -> preloadFailed mm lib_paths lib_spec + return pls + + DLLPath dll_path -> do + do maybe_errstr <- loadDLL hsc_env dll_path + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm lib_paths lib_spec + return pls + + Framework framework -> + if platformUsesFrameworks (targetPlatform dflags) + then do maybe_errstr <- loadFramework hsc_env framework_paths framework + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm framework_paths lib_spec + return pls + else throwGhcExceptionIO (ProgramError "preloadLib Framework") + + where + dflags = hsc_dflags hsc_env + + platform = targetPlatform dflags + + preloadFailed :: String -> [String] -> LibrarySpec -> IO () + preloadFailed sys_errmsg paths spec + = do maybePutStr dflags "failed.\n" + throwGhcExceptionIO $ + CmdLineError ( + "user specified .o/.so/.DLL could not be loaded (" + ++ sys_errmsg ++ ")\nWhilst trying to load: " + ++ showLS spec ++ "\nAdditional directories searched:" + ++ (if null paths then " (none)" else + intercalate "\n" (map (" "++) paths))) + + -- Not interested in the paths in the static case. + preload_statics _paths names + = do b <- or <$> mapM doesFileExist names + if not b then return (False, pls) + else if hostIsDynamic + then do pls1 <- dynLoadObjs hsc_env pls names + return (True, pls1) + else do mapM_ (loadObj hsc_env) names + return (True, pls) + + preload_static_archive _paths name + = do b <- doesFileExist name + if not b then return False + else do if hostIsDynamic + then throwGhcExceptionIO $ + CmdLineError dynamic_msg + else loadArchive hsc_env name + return True + where + dynamic_msg = unlines + [ "User-specified static library could not be loaded (" + ++ name ++ ")" + , "Loading static libraries is not supported in this configuration." + , "Try using a dynamic library instead." + ] + + +{- ********************************************************************** + + Link a byte-code expression + + ********************************************************************* -} + +-- | 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 load. +-- +loadExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue +loadExpr hsc_env span root_ul_bco + = do { + -- Initialise the linker (if it's not been done already) + ; initLoaderState hsc_env + + -- Extract the Loader value for passing into required places + ; let dl = hsc_loader hsc_env + + -- Take lock for the actual work. + ; modifyLS dl $ \pls0 -> do { + + -- Load the packages and modules required + ; (pls, ok) <- loadDependencies hsc_env pls0 span needed_mods + ; if failed ok then + throwGhcExceptionIO (ProgramError "") + else do { + + -- Load the expression itself + let ie = itbl_env pls + ce = closure_env pls + + -- Load the necessary packages and linkables + + ; let nobreakarray = error "no break array" + bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] + ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco + ; [root_hvref] <- createBCOs hsc_env [resolved] + ; fhv <- mkFinalizedHValue hsc_env root_hvref + ; return (pls, fhv) + }}} + where + free_names = uniqDSetToList (bcoFreeNames root_ul_bco) + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + +dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a +dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) + + +checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath) +checkNonStdWay hsc_env srcspan + | Just (ExternalInterp {}) <- hsc_interp hsc_env = return Nothing + -- with -fexternal-interpreter we load the .o files, whatever way + -- they were built. If they were built for a non-std way, then + -- we will use the appropriate variant of the iserv binary to load them. + + | hostFullWays == targetFullWays = return Nothing + -- Only if we are compiling with the same ways as GHC is built + -- with, can we dynamically load those object files. (see #3604) + + | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null targetFullWays) + = failNonStd (hsc_dflags hsc_env) srcspan + + | otherwise = return (Just (hostWayTag ++ "o")) + where + targetFullWays = fullWays (ways (hsc_dflags hsc_env)) + hostWayTag = case waysTag hostFullWays of + "" -> "" + tag -> tag ++ "_" + +normalObjectSuffix :: String +normalObjectSuffix = phaseInputExt StopLn + +failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) +failNonStd dflags srcspan = dieWith dflags srcspan $ + text "Cannot load" <+> compWay <+> + text "objects when GHC is built" <+> ghciWay $$ + text "To fix this, either:" $$ + text " (1) Use -fexternal-interpreter, or" $$ + text " (2) Build the program twice: once" <+> + ghciWay <> text ", and then" $$ + text " with" <+> compWay <+> + text "using -osuf to set a different object file suffix." + where compWay + | WayDyn `elem` ways dflags = text "-dynamic" + | WayProf `elem` ways dflags = text "-prof" + | otherwise = text "normal" + ghciWay + | hostIsDynamic = text "with -dynamic" + | hostIsProfiled = text "with -prof" + | otherwise = text "the normal way" + +getLinkDeps :: HscEnv -> HomePackageTable + -> LoaderState + -> Maybe FilePath -- replace object suffices? + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO ([Linkable], [UnitId]) -- ... then link these first +-- Fails with an IO exception if it can't find enough files + +getLinkDeps hsc_env hpt pls replace_osuf span mods +-- Find all the packages and linkables that a set of modules depends on + = do { + -- 1. Find the dependent home-pkg-modules/packages from each iface + -- (omitting modules from the interactive package, which is already linked) + ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) + emptyUniqDSet emptyUniqDSet; + + ; let { + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + mods_needed = mods_s `minusList` linked_mods ; + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; + + linked_mods = map (moduleName.linkableModule) + (objs_loaded pls ++ bcos_loaded pls) } + + -- 3. For each dependent module, find its linkable + -- This will either be in the HPT or (in the case of one-shot + -- compilation) we may need to use maybe_getFileLinkable + ; let { osuf = objectSuf dflags } + ; lnks_needed <- mapM (get_linkable osuf) mods_needed + + ; return (lnks_needed, pkgs_needed) } + where + dflags = hsc_dflags hsc_env + + -- The ModIface contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. + follow_deps :: [Module] -- modules to follow + -> UniqDSet ModuleName -- accum. module dependencies + -> UniqDSet UnitId -- accum. package dependencies + -> IO ([ModuleName], [UnitId]) -- result + follow_deps [] acc_mods acc_pkgs + = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) + follow_deps (mod:mods) acc_mods acc_pkgs + = do + mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $ + loadInterface msg mod (ImportByUser NotBoot) + iface <- case mb_iface of + Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Maybes.Succeeded iface -> return iface + + when (mi_boot iface == IsBoot) $ link_boot_mod_error mod + + let + pkg = moduleUnit mod + deps = mi_deps iface + home_unit = hsc_home_unit hsc_env + + pkg_deps = dep_pkgs deps + (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $ + \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) -> + m & case is_boot of + IsBoot -> Left + NotBoot -> Right + + boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps + acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps + -- + if not (isHomeUnit home_unit pkg) + then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) + else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods) + acc_mods' acc_pkgs' + where + msg = text "need to link module" <+> ppr mod <+> + text "due to use of Template Haskell" + + + link_boot_mod_error mod = + throwGhcExceptionIO (ProgramError (showSDoc dflags ( + text "module" <+> ppr mod <+> + text "cannot be linked; it is only available as a boot module"))) + + no_obj :: Outputable a => a -> IO b + no_obj mod = dieWith dflags span $ + text "cannot find object file for module " <> + quotes (ppr mod) $$ + while_linking_expr + + while_linking_expr = text "while linking an interpreted expression" + + -- This one is a build-system bug + + get_linkable osuf mod_name -- A home-package module + | Just mod_info <- lookupHpt hpt mod_name + = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) + | otherwise + = do -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + mb_stuff <- findHomeModule hsc_env mod_name + case mb_stuff of + Found loc mod -> found loc mod + _ -> no_obj mod_name + where + found loc mod = do { + -- ...and then find the linkable for it + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> no_obj mod ; + Just lnk -> adjust_linkable lnk + }} + + adjust_linkable lnk + | Just new_osuf <- replace_osuf = do + new_uls <- mapM (adjust_ul new_osuf) + (linkableUnlinked lnk) + return lnk{ linkableUnlinked=new_uls } + | otherwise = + return lnk + + adjust_ul new_osuf (DotO file) = do + MASSERT(osuf `isSuffixOf` file) + let file_base = fromJust (stripExtension osuf file) + new_file = file_base <.> new_osuf + ok <- doesFileExist new_file + if (not ok) + then dieWith dflags span $ + text "cannot find object file " + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file) + adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) + adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) + adjust_ul _ l@(BCOs {}) = return l + + + +{- ********************************************************************** + + Loading a Decls statement + + ********************************************************************* -} + +loadDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () +loadDecls hsc_env span cbc@CompiledByteCode{..} = do + -- Initialise the linker (if it's not been done already) + initLoaderState hsc_env + + -- Extract the Loader for passing into required places + let dl = hsc_loader hsc_env + + -- Take lock for the actual work. + 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 + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + +{- ********************************************************************** + + Loading a single 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' + +{- ********************************************************************** + + Link some linkables + The linkables may consist of a mixture of + byte-code modules and object modules + + ********************************************************************* -} + +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) <- loadObjects hsc_env pls objs + + if failed ok_flag then + return (pls1, Failed) + else do + pls2 <- dynLinkBCOs hsc_env pls1 bcos + return (pls2, Succeeded) + + +-- HACK to support f-x-dynamic in the interpreter; no other purpose +partitionLinkable :: Linkable -> [Linkable] +partitionLinkable li + = let li_uls = linkableUnlinked li + li_uls_obj = filter isObject li_uls + li_uls_bco = filter isInterpretable li_uls + in + case (li_uls_obj, li_uls_bco) of + (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, + li {linkableUnlinked=li_uls_bco}] + _ -> [li] + +findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable +findModuleLinkable_maybe lis mod + = case [LM time nm us | LM time nm us <- lis, nm == mod] of + [] -> Nothing + [li] -> Just li + _ -> pprPanic "findModuleLinkable" (ppr mod) + +linkableInSet :: Linkable -> [Linkable] -> Bool +linkableInSet l objs_loaded = + case findModuleLinkable_maybe objs_loaded (linkableModule l) of + Nothing -> False + Just m -> linkableTime l == linkableTime m + + +{- ********************************************************************** + + The object-code linker + + ********************************************************************* -} + +-- | 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 + wanted_objs = map nameOfObject unlinkeds + + if interpreterDynamic (hscInterp hsc_env) + then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs + return (pls2, Succeeded) + else do mapM_ (loadObj hsc_env) wanted_objs + + -- Link them all together + ok <- resolveObjs hsc_env + + -- If resolving failed, unload all our + -- object modules and carry on + if succeeded ok then + return (pls1, Succeeded) + else do + pls2 <- unload_wkr hsc_env [] pls1 + return (pls2, Failed) + + +-- | 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@LoaderState{..} objs = do + let dflags = hsc_dflags hsc_env + let platform = targetPlatform dflags + let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] + let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] + (soFile, libPath , libName) <- + newTempLibName dflags TFL_CurrentModule (platformSOExt platform) + let + dflags2 = dflags { + -- We don't want the original ldInputs in + -- (they're already linked in), but we do want + -- to link against previous dynLoadObjs + -- libraries if there were any, so that the linker + -- can resolve dependencies when it loads this + -- library. + ldInputs = + concatMap (\l -> [ Option ("-l" ++ l) ]) + (nub $ snd <$> temp_sos) + ++ concatMap (\lp -> Option ("-L" ++ lp) + : if gopt Opt_RPath dflags + then [ Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp ] + else []) + (nub $ fst <$> temp_sos) + ++ concatMap + (\lp -> Option ("-L" ++ lp) + : if gopt Opt_RPath dflags + then [ Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp ] + else []) + minus_big_ls + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + ++ map (\l -> Option ("-l" ++ l)) minus_ls, + -- Add -l options and -L options from dflags. + -- + -- When running TH for a non-dynamic way, we still + -- need to make -l flags to link against the dynamic + -- libraries, so we need to add WayDyn to ways. + -- + -- Even if we're e.g. profiling, we still want + -- the vanilla dynamic libraries, so we set the + -- ways / build tag to be just WayDyn. + ways = Set.singleton WayDyn, + outputFile = Just soFile + } + -- link all "loaded packages" so symbols in those can be resolved + -- Note: We are loading packages with local scope, so to see the + -- symbols in this link we must link all loaded packages again. + linkDynLib dflags2 objs pkgs_loaded + + -- if we got this far, extend the lifetime of the library file + changeTempFilesLifetime dflags TFL_GhcSession [soFile] + m <- loadDLL hsc_env soFile + case m of + Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } + Just err -> linkFail msg err + where + msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" + +rmDupLinkables :: [Linkable] -- Already loaded + -> [Linkable] -- New linkables + -> ([Linkable], -- New loaded set (including new ones) + [Linkable]) -- New linkables (excluding dups) +rmDupLinkables already ls + = go already [] ls + where + go already extras [] = (already, extras) + go already extras (l:ls) + | linkableInSet l already = go already extras ls + | otherwise = go (l:already) (l:extras) ls + +{- ********************************************************************** + + The byte-code linker + + ********************************************************************* -} + + +dynLinkBCOs :: HscEnv -> LoaderState -> [Linkable] -> IO LoaderState +dynLinkBCOs hsc_env pls bcos = do + + let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + pls1 = pls { bcos_loaded = bcos_loaded' } + unlinkeds :: [Unlinked] + unlinkeds = concatMap linkableUnlinked new_bcos + + cbcs :: [CompiledByteCode] + cbcs = map byteCodeOfObject unlinkeds + + + ies = map bc_itbls cbcs + gce = closure_env pls + final_ie = foldr plusNameEnv (itbl_env pls) ies + + names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs + + -- We only want to add the external ones to the ClosureEnv + let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs + + -- Immediately release any HValueRefs we're not going to add + freeHValueRefs hsc_env (map snd to_drop) + -- Wrap finalizers on the ones we want to keep + new_binds <- makeForeignNamedHValueRefs hsc_env to_add + + return pls1 { closure_env = extendClosureEnv gce new_binds, + itbl_env = final_ie } + +-- Link a bunch of BCOs and return references to their values +linkSomeBCOs :: HscEnv + -> ItblEnv + -> ClosureEnv + -> [CompiledByteCode] + -> IO [(Name,HValueRef)] + -- The returned HValueRefs are associated 1-1 with + -- the incoming unlinked BCOs. Each gives the + -- value of the corresponding unlinked BCO + +linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods [] + where + fun CompiledByteCode{..} inner accum = + case bc_breaks of + Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum) + Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray -> + inner ((breakarray, bc_bcos) : accum) + + do_link [] = return [] + do_link mods = do + let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] + names = map (unlinkedBCOName . snd) flat + bco_ix = mkNameEnv (zip names [0..]) + resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco + | (breakarray, bco) <- flat ] + hvrefs <- createBCOs hsc_env resolved + return (zip names hvrefs) + +-- | Useful to apply to the result of 'linkSomeBCOs' +makeForeignNamedHValueRefs + :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)] +makeForeignNamedHValueRefs hsc_env bindings = + mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings + +{- ********************************************************************** + + Unload some object modules + + ********************************************************************* -} + +-- --------------------------------------------------------------------------- +-- | Unloading old objects ready for a new compilation sweep. +-- +-- The compilation manager provides us with a list of linkables that it +-- considers \"stable\", i.e. won't be recompiled this time around. For +-- each of the modules current linked in memory, +-- +-- * if the linkable is stable (and it's the same one -- the user may have +-- recompiled the module on the side), we keep it, +-- +-- * otherwise, we unload it. +-- +-- * we also implicitly unload all temporary bindings at this point. +-- +unload :: HscEnv + -> [Linkable] -- ^ The linkables to *keep*. + -> IO () +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) + initLoaderState hsc_env + + -- Extract Loader for passing into required places + let dl = hsc_loader hsc_env + + new_pls + <- modifyLS dl $ \pls -> do + pls1 <- unload_wkr hsc_env linkables pls + return (pls1, pls1) + + let dflags = hsc_dflags hsc_env + debugTraceMsg dflags 3 $ + text "unload: retaining objs" <+> ppr (objs_loaded new_pls) + debugTraceMsg dflags 3 $ + text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) + return () + +unload_wkr :: HscEnv + -> [Linkable] -- stable linkables + -> LoaderState + -> IO LoaderState +-- Does the core unload business +-- (the wrapper blocks exceptions and deals with the LS get and put) + +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. + + let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables + + discard keep l = not (linkableInSet l keep) + + (objs_to_unload, remaining_objs_loaded) = + partition (discard objs_to_keep) objs_loaded + (bcos_to_unload, remaining_bcos_loaded) = + partition (discard bcos_to_keep) bcos_loaded + + mapM_ unloadObjs objs_to_unload + mapM_ unloadObjs bcos_to_unload + + -- If we unloaded any object files at all, we need to purge the cache + -- of lookupSymbol results. + when (not (null (objs_to_unload ++ + filter (not . null . linkableObjs) bcos_to_unload))) $ + purgeLookupSymbolCache hsc_env + + let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded + + -- Note that we want to remove all *local* + -- (i.e. non-isExternal) names too (these are the + -- temporary bindings from the command line). + keep_name :: (Name, a) -> Bool + keep_name (n,_) = isExternalName n && + nameModule n `elemModuleSet` bcos_retained + + itbl_env' = filterNameEnv keep_name itbl_env + closure_env' = filterNameEnv keep_name closure_env + + !new_pls = pls { itbl_env = itbl_env', + closure_env = closure_env', + bcos_loaded = remaining_bcos_loaded, + objs_loaded = remaining_objs_loaded } + + return new_pls + where + unloadObjs :: Linkable -> IO () + unloadObjs lnk + | hostIsDynamic = return () + -- We don't do any cleanup when linking objects with the + -- dynamic linker. Doing so introduces extra complexity for + -- not much benefit. + + -- Code unloading currently disabled due to instability. + -- See #16841. + -- id False, so that the pattern-match checker doesn't complain + | id False -- otherwise + = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk] + -- The components of a BCO linkable may contain + -- dot-o files. Which is very confusing. + -- + -- But the BCO parts can be unlinked just by + -- letting go of them (plus of course depopulating + -- the symbol table which is done in the main body) + | otherwise = return () -- see #16841 + +{- ********************************************************************** + + Loading packages + + ********************************************************************* -} + +data LibrarySpec + = Objects [FilePath] -- Full path names of set of .o files, including trailing .o + -- We allow batched loading to ensure that cyclic symbol + -- references can be resolved (see #13786). + -- For dynamic objects only, try to find the object + -- file in all the directories specified in + -- v_Library_paths before giving up. + + | Archive FilePath -- Full path name of a .a file, including trailing .a + + | DLL String -- "Unadorned" name of a .DLL/.so + -- e.g. On unix "qt" denotes "libqt.so" + -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" + -- loadDLL is platform-specific and adds the lib/.so/.DLL + -- suffixes platform-dependently + + | DLLPath FilePath -- Absolute or relative pathname to a dynamic library + -- (ends with .dll or .so). + + | Framework String -- Only used for darwin, but does no harm + +instance Outputable LibrarySpec where + ppr (Objects objs) = text "Objects" <+> ppr objs + ppr (Archive a) = text "Archive" <+> text a + ppr (DLL s) = text "DLL" <+> text s + ppr (DLLPath f) = text "DLLPath" <+> text f + ppr (Framework s) = text "Framework" <+> text s + +-- If this package is already part of the GHCi binary, we'll already +-- have the right DLLs for this package loaded, so don't try to +-- load them again. +-- +-- But on Win32 we must load them 'again'; doing so is a harmless no-op +-- as far as the loader is concerned, but it does initialise the list +-- of DLL handles that rts/Linker.c maintains, and that in turn is +-- used by lookupSymbol. So we must call addDLL for each library +-- just to get the DLL handle into the list. +partOfGHCi :: [PackageName] +partOfGHCi + | isWindowsHost || isDarwinHost = [] + | otherwise = map (PackageName . mkFastString) + ["base", "template-haskell", "editline"] + +showLS :: LibrarySpec -> String +showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" +showLS (Archive nm) = "(static archive) " ++ nm +showLS (DLL nm) = "(dynamic) " ++ nm +showLS (DLLPath nm) = "(dynamic) " ++ nm +showLS (Framework nm) = "(framework) " ++ nm + +-- | 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. +-- +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. +-- +-- However we do need the package-config stuff (to find aux libs etc), +-- and following them lets us load libraries in the right order, which +-- perhaps makes the error message a bit more localised if we get a link +-- failure. So the dependency walking code is still here. + +loadPackages hsc_env new_pkgs = do + -- It's probably not safe to try to load packages concurrently, so we take + -- a lock. + 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 + dflags = hsc_dflags hsc_env + pkgstate = unitState dflags + + link :: [UnitId] -> [UnitId] -> IO [UnitId] + link pkgs new_pkgs = + foldM link_one pkgs new_pkgs + + link_one pkgs new_pkg + | new_pkg `elem` pkgs -- Already linked + = return pkgs + + | Just pkg_cfg <- lookupUnitId pkgstate new_pkg + = do { -- Link dependents first + pkgs' <- link pkgs (unitDepends pkg_cfg) + -- Now link the package itself + ; loadPackage hsc_env pkg_cfg + ; return (new_pkg : pkgs') } + + | otherwise + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) + + +loadPackage :: HscEnv -> UnitInfo -> IO () +loadPackage hsc_env pkg + = do + let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + is_dyn = interpreterDynamic (hscInterp hsc_env) + dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg + | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg + + let hs_libs = map ST.unpack $ Packages.unitLibraries pkg + -- The FFI GHCi import lib isn't needed as + -- 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. + hs_libs' = filter ("HSffi" /=) hs_libs + + -- Because of slight differences between the GHC dynamic linker and + -- the native system linker some packages have to link with a + -- different list of libraries when using GHCi. Examples include: libs + -- that are actually gnu ld scripts, and the possibility that the .a + -- libs do not exactly match the .so/.dll equivalents. So if the + -- package file provides an "extra-ghci-libraries" field then we use + -- that instead of the "extra-libraries" field. + extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg) + then Packages.unitExtDepLibsSys pkg + else Packages.unitExtDepLibsGhc pkg) + linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ] + extra_libs = extdeplibs ++ linkerlibs + + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths dflags (platformOS platform) + dirs_env <- addEnvPaths "LIBRARY_PATH" dirs + + hs_classifieds + <- mapM (locateLib hsc_env True dirs_env gcc_paths) hs_libs' + extra_classifieds + <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs + let classifieds = hs_classifieds ++ extra_classifieds + + -- Complication: all the .so's must be loaded before any of the .o's. + let known_dlls = [ dll | DLLPath dll <- classifieds ] + dlls = [ dll | DLL dll <- classifieds ] + objs = [ obj | Objects objs <- classifieds + , obj <- objs ] + archs = [ arch | Archive arch <- classifieds ] + + -- Add directories to library search paths + let dll_paths = map takeDirectory known_dlls + all_paths = nub $ map normalise $ dll_paths ++ dirs + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env + + maybePutSDoc dflags + (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") + + -- See comments with partOfGHCi +#if defined(CAN_LOAD_DLL) + when (unitPackageName pkg `notElem` partOfGHCi) $ do + loadFrameworks hsc_env platform pkg + -- See Note [Crash early load_dyn and locateLib] + -- Crash early if can't load any of `known_dlls` + mapM_ (load_dyn hsc_env True) known_dlls + -- For remaining `dlls` crash early only when there is surely + -- no package's DLL around ... (not is_dyn) + mapM_ (load_dyn hsc_env (not is_dyn) . platformSOName platform) dlls +#endif + -- After loading all the DLLs, we can load the static objects. + -- Ordering isn't important here, because we do one final link + -- step to resolve everything. + mapM_ (loadObj hsc_env) objs + mapM_ (loadArchive hsc_env) archs + + maybePutStr dflags "linking ... " + ok <- resolveObjs hsc_env + + -- DLLs are loaded, reset the search paths + -- Import libraries will be loaded via loadArchive so only + -- reset the DLL search path after all archives are loaded + -- as well. + mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache + + if succeeded ok + then maybePutStrLn dflags "done." + else let errmsg = text "unable to load unit `" + <> pprUnitInfoForUser pkg <> text "'" + in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) + +{- +Note [Crash early load_dyn and locateLib] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a package is "normal" (exposes it's code from more than zero Haskell +modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then +it has it's code compiled and linked into the DLL, which GHCi linker picks +when loading the package's code (see the big comment in the beginning of +`locateLib`). + +When loading DLLs, GHCi linker simply calls the system's `dlopen` or +`LoadLibrary` APIs. This is quite different from the case when GHCi linker +loads an object file or static library. When loading an object file or static +library GHCi linker parses them and resolves all symbols "manually". +These object file or static library may reference some external symbols +defined in some external DLLs. And GHCi should know which these +external DLLs are. + +But when GHCi loads a DLL, it's the *system* linker who manages all +the necessary dependencies, and it is able to load this DLL not having +any extra info. Thus we don't *have to* crash in this case even if we +are unable to load any supposed dependencies explicitly. + +Suppose during GHCi session a client of the package wants to +`foreign import` a symbol which isn't exposed by the package DLL, but +is exposed by such an external (dependency) DLL. +If the DLL isn't *explicitly* loaded because `load_dyn` failed to do +this, then the client code eventually crashes because the GHCi linker +isn't able to locate this symbol (GHCi linker maintains a list of +explicitly loaded DLLs it looks into when trying to find a symbol). + +This is why we still should try to load all the dependency DLLs +even though we know that the system linker loads them implicitly when +loading the package DLL. + +Why we still keep the `crash_early` opportunity then not allowing such +a permissive behaviour for any DLLs? Well, we, perhaps, improve a user +experience in some cases slightly. + +But if it happens there exist other corner cases where our current +usage of `crash_early` flag is overly restrictive, we may lift the +restriction very easily. +-} + +-- we have already searched the filesystem; the strings passed to load_dyn +-- can be passed directly to loadDLL. They are either fully-qualified +-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, +-- loadDLL is going to search the system paths to find the library. +load_dyn :: HscEnv -> Bool -> FilePath -> IO () +load_dyn hsc_env crash_early dll = do + r <- loadDLL hsc_env dll + case r of + Nothing -> return () + Just err -> + if crash_early + then cmdLineErrorIO err + else let dflags = hsc_dflags hsc_env in + when (wopt Opt_WarnMissedExtraSharedLib dflags) + $ putLogMsg dflags + (Reason Opt_WarnMissedExtraSharedLib) SevWarning + noSrcSpan $ withPprStyle defaultUserStyle (note err) + where + note err = vcat $ map text + [ err + , "It's OK if you don't want to use symbols from it directly." + , "(the package DLL is loaded by the system linker" + , " which manages dependencies by itself)." ] + +loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO () +loadFrameworks hsc_env platform pkg + = when (platformUsesFrameworks platform) $ mapM_ load frameworks + where + fw_dirs = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg + frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg + + load fw = do r <- loadFramework hsc_env fw_dirs fw + case r of + Nothing -> return () + Just err -> cmdLineErrorIO ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" ) + +-- Try to find an object file for a given library in the given paths. +-- If it isn't present, we assume that addDLL in the RTS can find it, +-- which generally means that it should be a dynamic library in the +-- standard system search path. +-- For GHCi we tend to prefer dynamic libraries over static ones as +-- they are easier to load and manage, have less overhead. +locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String + -> IO LibrarySpec +locateLib hsc_env is_hs lib_dirs gcc_dirs lib + | not is_hs + -- For non-Haskell libraries (e.g. gmp, iconv): + -- first look in library-dirs for a dynamic library (on User paths only) + -- (libfoo.so) + -- then try looking for import libraries on Windows (on User paths only) + -- (.dll.a, .lib) + -- first look in library-dirs for a dynamic library (on GCC paths only) + -- (libfoo.so) + -- then check for system dynamic libraries (e.g. kernel32.dll on windows) + -- then try looking for import libraries on Windows (on GCC paths only) + -- (.dll.a, .lib) + -- then look in library-dirs for a static library (libfoo.a) + -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so) + -- then try looking for import libraries on Windows (.dll.a, .lib) + -- then look in library-dirs and inplace GCC for a static library (libfoo.a) + -- then try "gcc --print-file-name" to search gcc's search path + -- for a dynamic library (#5289) + -- otherwise, assume loadDLL can find it + -- + -- The logic is a bit complicated, but the rationale behind it is that + -- loading a shared library for us is O(1) while loading an archive is + -- O(n). Loading an import library is also O(n) so in general we prefer + -- shared libraries because they are simpler and faster. + -- + = +#if defined(CAN_LOAD_DLL) + findDll user `orElse` +#endif + tryImpLib user `orElse` +#if defined(CAN_LOAD_DLL) + findDll gcc `orElse` + findSysDll `orElse` +#endif + tryImpLib gcc `orElse` + findArchive `orElse` + tryGcc `orElse` + assumeDll + + | loading_dynamic_hs_libs -- search for .so libraries first. + = findHSDll `orElse` + findDynObject `orElse` + assumeDll + + | otherwise + -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a + = findObject `orElse` + findArchive `orElse` + assumeDll + + where + dflags = hsc_dflags hsc_env + interp = hscInterp hsc_env + dirs = lib_dirs ++ gcc_dirs + gcc = False + user = True + + obj_file + | is_hs && loading_profiled_hs_libs = lib <.> "p_o" + | otherwise = lib <.> "o" + dyn_obj_file = lib <.> "dyn_o" + arch_files = [ "lib" ++ lib ++ lib_tag <.> "a" + , lib <.> "a" -- native code has no lib_tag + , "lib" ++ lib, lib + ] + lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" + + loading_profiled_hs_libs = interpreterProfiled interp + loading_dynamic_hs_libs = interpreterDynamic interp + + import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib" + , "lib" ++ lib <.> "dll.a", lib <.> "dll.a" + ] + + hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags + hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name + + so_name = platformSOName platform lib + lib_so_name = "lib" ++ so_name + dyn_lib_file = case (arch, os) of + (ArchX86_64, OSSolaris2) -> "64" so_name + _ -> so_name + + findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file + findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file + findArchive = let local name = liftM (fmap Archive) $ findFile dirs name + in apply (map local arch_files) + findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file + findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs + in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file + findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ + findSystemLibrary hsc_env so_name + tryGcc = let search = searchForLibUsingGcc dflags + dllpath = liftM (fmap DLLPath) + short = dllpath $ search so_name lib_dirs + full = dllpath $ search lib_so_name lib_dirs + gcc name = liftM (fmap Archive) $ search name lib_dirs + files = import_libs ++ arch_files + dlls = [short, full] + archives = map gcc files + in apply $ +#if defined(CAN_LOAD_DLL) + dlls ++ +#endif + archives + tryImpLib re = case os of + OSMinGW32 -> + let dirs' = if re == user then lib_dirs else gcc_dirs + implib name = liftM (fmap Archive) $ + findFile dirs' name + in apply (map implib import_libs) + _ -> return Nothing + + -- TH Makes use of the interpreter so this failure is not obvious. + -- So we are nice and warn/inform users why we fail before we do. + -- But only for haskell libraries, as C libraries don't have a + -- profiling/non-profiling distinction to begin with. + assumeDll + | is_hs + , not loading_dynamic_hs_libs + , interpreterProfiled interp + = do + warningMsg dflags + (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ + text " \tTrying dynamic library instead. If this fails try to rebuild" <+> + text "libraries with profiling support.") + return (DLL lib) + | otherwise = return (DLL lib) + infixr `orElse` + f `orElse` g = f >>= maybe g return + + apply :: [IO (Maybe a)] -> IO (Maybe a) + apply [] = return Nothing + apply (x:xs) = do x' <- x + if isJust x' + then return x' + else apply xs + + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + +searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc dflags so dirs = do + -- GCC does not seem to extend the library search path (using -L) when using + -- --print-file-name. So instead pass it a new base location. + str <- askLd dflags (map (FileOption "-B") dirs + ++ [Option "--print-file-name", Option so]) + let file = case lines str of + [] -> "" + l:_ -> l + if (file == so) + then return Nothing + else do b <- doesFileExist file -- file could be a folder (see #16063) + return (if b then Just file else Nothing) + +-- | Retrieve the list of search directory GCC and the System use to find +-- libraries and components. See Note [Fork/Exec Windows]. +getGCCPaths :: DynFlags -> OS -> IO [FilePath] +getGCCPaths dflags os + = case os of + OSMinGW32 -> + do gcc_dirs <- getGccSearchDirectory dflags "libraries" + sys_dirs <- getSystemDirectories + return $ nub $ gcc_dirs ++ sys_dirs + _ -> return [] + +-- | Cache for the GCC search directories as this can't easily change +-- during an invocation of GHC. (Maybe with some env. variable but we'll) +-- deal with that highly unlikely scenario then. +{-# NOINLINE gccSearchDirCache #-} +gccSearchDirCache :: IORef [(String, [String])] +gccSearchDirCache = unsafePerformIO $ newIORef [] + +-- Note [Fork/Exec Windows] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- fork/exec is expensive on Windows, for each time we ask GCC for a library we +-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1. +-- So instead get a list of location that GCC would search and use findDirs +-- which hopefully is written in an optimized mannor to take advantage of +-- caching. At the very least we remove the overhead of the fork/exec and waits +-- which dominate a large percentage of startup time on Windows. +getGccSearchDirectory :: DynFlags -> String -> IO [FilePath] +getGccSearchDirectory dflags key = do + cache <- readIORef gccSearchDirCache + case lookup key cache of + Just x -> return x + Nothing -> do + str <- askLd dflags [Option "--print-search-dirs"] + let line = dropWhile isSpace str + name = key ++ ": =" + if null line + then return [] + else do let val = split $ find name line + dirs <- filterM doesDirectoryExist val + modifyIORef' gccSearchDirCache ((key, dirs):) + return val + where split :: FilePath -> [FilePath] + split r = case break (==';') r of + (s, [] ) -> [s] + (s, (_:xs)) -> s : split xs + + find :: String -> String -> String + find r x = let lst = lines x + val = filter (r `isPrefixOf`) lst + in if null val + then [] + else case break (=='=') (head val) of + (_ , []) -> [] + (_, (_:xs)) -> xs + +-- | Get a list of system search directories, this to alleviate pressure on +-- the findSysDll function. +getSystemDirectories :: IO [FilePath] +#if defined(mingw32_HOST_OS) +getSystemDirectories = fmap (:[]) getSystemDirectory +#else +getSystemDirectories = return [] +#endif + +-- | Merge the given list of paths with those in the environment variable +-- given. If the variable does not exist then just return the identity. +addEnvPaths :: String -> [String] -> IO [String] +addEnvPaths name list + = do -- According to POSIX (chapter 8.3) a zero-length prefix means current + -- working directory. Replace empty strings in the env variable with + -- `working_dir` (see also #14695). + working_dir <- getCurrentDirectory + values <- lookupEnv name + case values of + Nothing -> return list + Just arr -> return $ list ++ splitEnv working_dir arr + where + splitEnv :: FilePath -> String -> [String] + splitEnv working_dir value = + case break (== envListSep) value of + (x, [] ) -> + [if null x then working_dir else x] + (x, (_:xs)) -> + (if null x then working_dir else x) : splitEnv working_dir xs +#if defined(mingw32_HOST_OS) + envListSep = ';' +#else + envListSep = ':' +#endif + +-- ---------------------------------------------------------------------------- +-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) + + +{- ********************************************************************** + + Helper functions + + ********************************************************************* -} + +maybePutSDoc :: DynFlags -> SDoc -> IO () +maybePutSDoc dflags s + = when (verbosity dflags > 1) $ + putLogMsg dflags + NoReason + SevInteractive + noSrcSpan + $ withPprStyle defaultUserStyle s + +maybePutStr :: DynFlags -> String -> IO () +maybePutStr dflags s = maybePutSDoc dflags (text s) + +maybePutStrLn :: DynFlags -> String -> IO () +maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") 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 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, contained in other_flags + -- needs to be put before -l, + -- 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/Linker/Types.hs b/compiler/GHC/Linker/Types.hs new file mode 100644 index 0000000000..728d6a3b06 --- /dev/null +++ b/compiler/GHC/Linker/Types.hs @@ -0,0 +1,176 @@ +----------------------------------------------------------------------------- +-- +-- Types for the linkers and the loader +-- +-- (c) The University of Glasgow 2019 +-- +----------------------------------------------------------------------------- + +module GHC.Linker.Types + ( Loader (..) + , LoaderState (..) + , uninitializedLoader + , Linkable(..) + , Unlinked(..) + , SptEntry(..) + , isObjectLinkable + , linkableObjs + , isObject + , nameOfObject + , isInterpretable + , byteCodeOfObject + ) +where + +import GHC.Prelude +import GHC.Unit ( UnitId, Module ) +import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) +import GHC.Fingerprint.Type ( Fingerprint ) +import GHCi.RemoteTypes ( ForeignHValue ) + +import GHC.Types.Var ( Id ) +import GHC.Types.Name.Env ( NameEnv ) +import GHC.Types.Name ( Name ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Concurrent.MVar +import Data.Time ( UTCTime ) + + +{- ********************************************************************** + + The Loader's state + + ********************************************************************* -} + +{- +The loader state *must* match the actual state of the C dynamic linker at all +times. + +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 LoaderState maps Names to actual closures (for interpreted code only), for +use during linking. +-} + +newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } + +data LoaderState = LoaderState + { closure_env :: ClosureEnv + -- ^ Current global mapping from Names to their true values + + , 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. + + , 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 { + linkableTime :: UTCTime, -- ^ Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + linkableModule :: Module, -- ^ The linkable module itself + linkableUnlinked :: [Unlinked] + -- ^ Those files and chunks of code we have yet to link. + -- + -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. + -- If this list is empty, the Linkable represents a fake linkable, which + -- is generated with no backend is used to avoid recompiling modules. + -- + -- ToDo: Do items get removed from this list when they get linked? + } + +instance Outputable Linkable where + ppr (LM when_made mod unlinkeds) + = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr unlinkeds) + +-- | Objects which have yet to be linked by the compiler +data Unlinked + = DotO FilePath -- ^ An object file (.o) + | DotA FilePath -- ^ Static archive file (.a) + | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) + | BCOs CompiledByteCode + [SptEntry] -- ^ A byte-code object, lives only in memory. Also + -- carries some static pointer table entries which + -- should be loaded along with the BCOs. + -- See Note [Grant plan for static forms] in + -- "GHC.Iface.Tidy.StaticPtrTable". + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt + +-- | An entry to be inserted into a module's static pointer table. +-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +data SptEntry = SptEntry Id Fingerprint + +instance Outputable SptEntry where + ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr + + +isObjectLinkable :: Linkable -> Bool +isObjectLinkable l = not (null unlinked) && all isObject unlinked + where unlinked = linkableUnlinked l + -- A linkable with no Unlinked's is treated as a BCO. We can + -- generate a linkable with no Unlinked's as a result of + -- compiling a module in NoBackend mode, and this choice + -- happens to work well with checkStability in module GHC. + +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + +------------------------------------------- + +-- | Is this an actual file on disk we can link in somehow? +isObject :: Unlinked -> Bool +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +-- | Is this a bytecode linkable with no file on disk? +isInterpretable :: Unlinked -> Bool +isInterpretable = not . isObject + +-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object +nameOfObject :: Unlinked -> FilePath +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn +nameOfObject other = pprPanic "nameOfObject" (ppr other) + +-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable +byteCodeOfObject :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) 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.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 = + "\n\ + \ \n\ + \ \n\n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \\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, "") -- 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/Linker.hs b/compiler/GHC/Runtime/Linker.hs deleted file mode 100644 index dd3c29caa5..0000000000 --- a/compiler/GHC/Runtime/Linker.hs +++ /dev/null @@ -1,1802 +0,0 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} - --- --- (c) The University of Glasgow 2002-2006 --- --- | 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 - , unload - , withExtendedLinkEnv - , extendLinkEnv - , deleteFromLinkEnv - , extendLoadedPkgs - , linkPackages - , initDynLinker - , linkModule - , linkCmdLineLibs - , uninitializedLinker - ) -where - -#include "HsVersions.h" - -import GHC.Prelude - -import GHC.Platform -import GHC.Platform.Ways - -import GHC.Driver.Phases -import GHC.Driver.Env -import GHC.Driver.Session -import GHC.Driver.Ppr - -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 - -import GHC.ByteCode.Linker -import GHC.ByteCode.Asm -import GHC.ByteCode.Types - -import GHC.SysTools -import GHC.SysTools.FileCleanup - -import GHC.Types.Basic -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.SrcLoc -import GHC.Types.Unique.DSet - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Misc -import GHC.Utils.Error - -import GHC.Unit.Finder -import GHC.Unit.Module -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Deps -import GHC.Unit.Home -import GHC.Unit.Home.ModInfo -import GHC.Unit.State as Packages - -import qualified GHC.Data.ShortText as ST -import qualified GHC.Data.Maybe as Maybes -import GHC.Data.FastString -import GHC.Data.List.SetOps - --- Standard libraries -import Control.Monad - -import qualified Data.Set as Set -import Data.Char (isSpace) -import Data.Function ((&)) -import Data.IORef -import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) -import Data.Maybe -import Control.Concurrent.MVar -import qualified Control.Monad.Catch as MC - -import System.FilePath -import System.Directory -import System.IO.Unsafe -import System.Environment (lookupEnv) - -#if defined(mingw32_HOST_OS) -import System.Win32.Info (getSystemDirectory) -#endif - -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" - -modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO () -modifyPLS_ dl f = - modifyMVar_ (dl_mpls 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) - where fmapFst f = fmap (\(x, y) -> (f x, y)) - -readPLS :: DynLinker -> IO PersistentLinkerState -readPLS dl = - (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl) - -modifyMbPLS_ - :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO () -modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f - -emptyPLS :: PersistentLinkerState -emptyPLS = PersistentLinkerState - { closure_env = emptyNameEnv - , itbl_env = emptyNameEnv - , pkgs_loaded = init_pkgs - , bcos_loaded = [] - , objs_loaded = [] - , temp_sos = [] - } - -- Packages that don't need loading, because the compiler - -- shares them with the interpreted program. - -- - -- The linker's symbol table is populated with RTS symbols using an - -- explicit list. See rts/Linker.c for details. - where init_pkgs = [rtsUnitId] - -extendLoadedPkgs :: DynLinker -> [UnitId] -> IO () -extendLoadedPkgs dl pkgs = - modifyPLS_ dl $ \s -> - return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } - -extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO () -extendLinkEnv dl new_bindings = - modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> 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 - 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. --- --- 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 - -> SrcSpan -> [Module] - -> IO (PersistentLinkerState, SuccessFlag) -linkDependencies hsc_env pls span needed_mods = do --- initDynLinker (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. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay hsc_env span - - -- Find what packages and linkables are required - (lnks, pkgs) <- getLinkDeps hsc_env hpt pls - maybe_normal_osuf span needed_mods - - -- Link the packages and modules required - pls1 <- linkPackages' hsc_env pkgs pls - linkModules hsc_env pls1 lnks - - --- | Temporarily extend the linker state. - -withExtendedLinkEnv :: (ExceptionMonad m) => - DynLinker -> [(Name,ForeignHValue)] -> m a -> m a -withExtendedLinkEnv dl new_env action - = MC.bracket (liftIO $ extendLinkEnv dl new_env) - (\_ -> reset_old_env) - (\_ -> action) - where - -- Remember that the linker state might be side-effected - -- during the execution of the IO action, and we don't want to - -- lose those changes (we might have linked a new module or - -- package), so the reset action only removes the names we - -- added earlier. - reset_old_env = liftIO $ - modifyPLS_ 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 - return $ withPprStyle defaultDumpStyle - (vcat [text "----- Linker state -----", - text "Pkgs:" <+> ppr (pkgs_loaded pls), - text "Objs:" <+> ppr (objs_loaded pls), - text "BCOs:" <+> ppr (bcos_loaded pls)]) - - -{- ********************************************************************** - - Initialisation - - ********************************************************************* -} - --- | Initialise the dynamic linker. This entails --- --- a) Calling the C initialisation procedure, --- --- b) Loading any packages specified on the command line, --- --- c) Loading any packages specified on the command line, now held in the --- @-l@ options in @v_Opt_l@, --- --- d) Loading any @.o\/.dll@ files specified on the command line, now held --- in @ldInputs@, --- --- e) Loading any MacOS frameworks. --- --- NOTE: This function is idempotent; if called more than once, it does --- 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 - case pls of - Just _ -> return pls - Nothing -> Just <$> reallyInitDynLinker hsc_env - -reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState -reallyInitDynLinker hsc_env = do - -- Initialise the linker state - let dflags = hsc_dflags hsc_env - pls0 = emptyPLS - - -- (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 - - -- steps (c), (d) and (e) - linkCmdLineLibs' 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 - -linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState -linkCmdLineLibs' hsc_env pls = - do - let dflags@(DynFlags { ldInputs = cmdline_ld_inputs - , libraryPaths = lib_paths_base}) - = hsc_dflags hsc_env - - -- (c) Link libraries from the command-line - let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] - - -- On Windows we want to add libpthread by default just as GCC would. - -- However because we don't know the actual name of pthread's dll we - -- need to defer this to the locateLib call so we can't initialize it - -- inside of the rts. Instead we do it here to be able to find the - -- import library for pthreads. See #13210. - let platform = targetPlatform dflags - os = platformOS platform - minus_ls = case os of - OSMinGW32 -> "pthread" : minus_ls_1 - _ -> minus_ls_1 - -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths dflags os - - lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base - - maybePutStrLn dflags "Search directories (user):" - maybePutStr dflags (unlines $ map (" "++) lib_paths_env) - maybePutStrLn dflags "Search directories (gcc):" - maybePutStr dflags (unlines $ map (" "++) gcc_paths) - - libspecs - <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls - - -- (d) Link .o files from the command-line - classified_ld_inputs <- mapM (classifyLdInput dflags) - [ f | FileOption _ f <- cmdline_ld_inputs ] - - -- (e) Link any MacOS frameworks - let platform = targetPlatform dflags - let (framework_paths, frameworks) = - if platformUsesFrameworks platform - then (frameworkPaths dflags, cmdlineFrameworks dflags) - else ([],[]) - - -- Finally do (c),(d),(e) - 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 - --- | Merge runs of consecutive of 'Objects'. This allows for resolution of --- cyclic symbol references when dynamically linking. Specifically, we link --- together all of the static objects into a single shared object, avoiding --- the issue we saw in #13786. -mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec] -mergeStaticObjects specs = go [] specs - where - go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec] - go accum (Objects objs : rest) = go (objs ++ accum) rest - go accum@(_:_) rest = Objects (reverse accum) : go [] rest - go [] (spec:rest) = spec : go [] rest - go [] [] = [] - -{- Note [preload packages] - -Why do we need to preload packages from the command line? This is an -explanation copied from #2437: - -I tried to implement the suggestion from #3560, thinking it would be -easy, but there are two reasons we link in packages eagerly when they -are mentioned on the command line: - - * So that you can link in extra object files or libraries that - depend on the packages. e.g. ghc -package foo -lbar where bar is a - C library that depends on something in foo. So we could link in - foo eagerly if and only if there are extra C libs or objects to - link in, but.... - - * Haskell code can depend on a C function exported by a package, and - the normal dependency tracking that TH uses can't know about these - dependencies. The test ghcilink004 relies on this, for example. - -I conclude that we need two -package flags: one that says "this is a -package I want to make available", and one that says "this is a -package I want to link in eagerly". Would that be too complicated for -users? --} - -classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) -classifyLdInput dflags f - | isObjectFilename platform f = return (Just (Objects [f])) - | isDynLibFilename platform f = return (Just (DLLPath f)) - | otherwise = do - putLogMsg dflags NoReason SevInfo noSrcSpan - $ withPprStyle defaultUserStyle - (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) - return Nothing - where platform = targetPlatform dflags - -preloadLib - :: HscEnv -> [String] -> [String] -> PersistentLinkerState - -> LibrarySpec -> IO PersistentLinkerState -preloadLib hsc_env lib_paths framework_paths pls lib_spec = do - maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") - case lib_spec of - Objects static_ishs -> do - (b, pls1) <- preload_statics lib_paths static_ishs - maybePutStrLn dflags (if b then "done" else "not found") - return pls1 - - Archive static_ish -> do - b <- preload_static_archive lib_paths static_ish - maybePutStrLn dflags (if b then "done" else "not found") - return pls - - DLL dll_unadorned -> do - maybe_errstr <- loadDLL hsc_env (platformSOName platform dll_unadorned) - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm | platformOS platform /= OSDarwin -> - preloadFailed mm lib_paths lib_spec - Just mm | otherwise -> do - -- As a backup, on Darwin, try to also load a .so file - -- since (apparently) some things install that way - see - -- ticket #8770. - let libfile = ("lib" ++ dll_unadorned) <.> "so" - err2 <- loadDLL hsc_env libfile - case err2 of - Nothing -> maybePutStrLn dflags "done" - Just _ -> preloadFailed mm lib_paths lib_spec - return pls - - DLLPath dll_path -> do - do maybe_errstr <- loadDLL hsc_env dll_path - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm -> preloadFailed mm lib_paths lib_spec - return pls - - Framework framework -> - if platformUsesFrameworks (targetPlatform dflags) - then do maybe_errstr <- loadFramework hsc_env framework_paths framework - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm -> preloadFailed mm framework_paths lib_spec - return pls - else throwGhcExceptionIO (ProgramError "preloadLib Framework") - - where - dflags = hsc_dflags hsc_env - - platform = targetPlatform dflags - - preloadFailed :: String -> [String] -> LibrarySpec -> IO () - preloadFailed sys_errmsg paths spec - = do maybePutStr dflags "failed.\n" - throwGhcExceptionIO $ - CmdLineError ( - "user specified .o/.so/.DLL could not be loaded (" - ++ sys_errmsg ++ ")\nWhilst trying to load: " - ++ showLS spec ++ "\nAdditional directories searched:" - ++ (if null paths then " (none)" else - intercalate "\n" (map (" "++) paths))) - - -- Not interested in the paths in the static case. - preload_statics _paths names - = do b <- or <$> mapM doesFileExist names - if not b then return (False, pls) - else if hostIsDynamic - then do pls1 <- dynLoadObjs hsc_env pls names - return (True, pls1) - else do mapM_ (loadObj hsc_env) names - return (True, pls) - - preload_static_archive _paths name - = do b <- doesFileExist name - if not b then return False - else do if hostIsDynamic - then throwGhcExceptionIO $ - CmdLineError dynamic_msg - else loadArchive hsc_env name - return True - where - dynamic_msg = unlines - [ "User-specified static library could not be loaded (" - ++ name ++ ")" - , "Loading static libraries is not supported in this configuration." - , "Try using a dynamic library instead." - ] - - -{- ********************************************************************** - - Link a byte-code expression - - ********************************************************************* -} - --- | Link a single expression, /including/ first linking 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. --- -linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue -linkExpr hsc_env span root_ul_bco - = do { - -- Initialise the linker (if it's not been done already) - ; initDynLinker hsc_env - - -- Extract the DynLinker value for passing into required places - ; let dl = hsc_dynLinker 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 = itbl_env pls - ce = closure_env pls - - -- Link the necessary packages and linkables - - ; let nobreakarray = error "no break array" - bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] - ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco - ; [root_hvref] <- createBCOs hsc_env [resolved] - ; fhv <- mkFinalizedHValue hsc_env root_hvref - ; return (pls, fhv) - }}} - where - free_names = uniqDSetToList (bcoFreeNames root_ul_bco) - - needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, - isExternalName n, -- Names from other modules - not (isWiredInName n) -- Exclude wired-in names - ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - -dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a -dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) - - -checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath) -checkNonStdWay hsc_env srcspan - | Just (ExternalInterp {}) <- hsc_interp hsc_env = return Nothing - -- with -fexternal-interpreter we load the .o files, whatever way - -- they were built. If they were built for a non-std way, then - -- we will use the appropriate variant of the iserv binary to load them. - - | hostFullWays == targetFullWays = return Nothing - -- Only if we are compiling with the same ways as GHC is built - -- with, can we dynamically load those object files. (see #3604) - - | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null targetFullWays) - = failNonStd (hsc_dflags hsc_env) srcspan - - | otherwise = return (Just (hostWayTag ++ "o")) - where - targetFullWays = fullWays (ways (hsc_dflags hsc_env)) - hostWayTag = case waysTag hostFullWays of - "" -> "" - tag -> tag ++ "_" - -normalObjectSuffix :: String -normalObjectSuffix = phaseInputExt StopLn - -failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) -failNonStd dflags srcspan = dieWith dflags srcspan $ - text "Cannot load" <+> compWay <+> - text "objects when GHC is built" <+> ghciWay $$ - text "To fix this, either:" $$ - text " (1) Use -fexternal-interpreter, or" $$ - text " (2) Build the program twice: once" <+> - ghciWay <> text ", and then" $$ - text " with" <+> compWay <+> - text "using -osuf to set a different object file suffix." - where compWay - | WayDyn `elem` ways dflags = text "-dynamic" - | WayProf `elem` ways dflags = text "-prof" - | otherwise = text "normal" - ghciWay - | hostIsDynamic = text "with -dynamic" - | hostIsProfiled = text "with -prof" - | otherwise = text "the normal way" - -getLinkDeps :: HscEnv -> HomePackageTable - -> PersistentLinkerState - -> Maybe FilePath -- replace object suffices? - -> SrcSpan -- for error messages - -> [Module] -- If you need these - -> IO ([Linkable], [UnitId]) -- ... then link these first --- Fails with an IO exception if it can't find enough files - -getLinkDeps hsc_env hpt pls replace_osuf span mods --- Find all the packages and linkables that a set of modules depends on - = do { - -- 1. Find the dependent home-pkg-modules/packages from each iface - -- (omitting modules from the interactive package, which is already linked) - ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) - emptyUniqDSet emptyUniqDSet; - - ; let { - -- 2. Exclude ones already linked - -- Main reason: avoid findModule calls in get_linkable - mods_needed = mods_s `minusList` linked_mods ; - pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; - - linked_mods = map (moduleName.linkableModule) - (objs_loaded pls ++ bcos_loaded pls) } - - -- 3. For each dependent module, find its linkable - -- This will either be in the HPT or (in the case of one-shot - -- compilation) we may need to use maybe_getFileLinkable - ; let { osuf = objectSuf dflags } - ; lnks_needed <- mapM (get_linkable osuf) mods_needed - - ; return (lnks_needed, pkgs_needed) } - where - dflags = hsc_dflags hsc_env - - -- The ModIface contains the transitive closure of the module dependencies - -- within the current package, *except* for boot modules: if we encounter - -- a boot module, we have to find its real interface and discover the - -- dependencies of that. Hence we need to traverse the dependency - -- tree recursively. See bug #936, testcase ghci/prog007. - follow_deps :: [Module] -- modules to follow - -> UniqDSet ModuleName -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([ModuleName], [UnitId]) -- result - follow_deps [] acc_mods acc_pkgs - = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) - follow_deps (mod:mods) acc_mods acc_pkgs - = do - mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $ - loadInterface msg mod (ImportByUser NotBoot) - iface <- case mb_iface of - Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Maybes.Succeeded iface -> return iface - - when (mi_boot iface == IsBoot) $ link_boot_mod_error mod - - let - pkg = moduleUnit mod - deps = mi_deps iface - home_unit = hsc_home_unit hsc_env - - pkg_deps = dep_pkgs deps - (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $ - \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) -> - m & case is_boot of - IsBoot -> Left - NotBoot -> Right - - boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps - acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps - -- - if not (isHomeUnit home_unit pkg) - then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) - else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods) - acc_mods' acc_pkgs' - where - msg = text "need to link module" <+> ppr mod <+> - text "due to use of Template Haskell" - - - link_boot_mod_error mod = - throwGhcExceptionIO (ProgramError (showSDoc dflags ( - text "module" <+> ppr mod <+> - text "cannot be linked; it is only available as a boot module"))) - - no_obj :: Outputable a => a -> IO b - no_obj mod = dieWith dflags span $ - text "cannot find object file for module " <> - quotes (ppr mod) $$ - while_linking_expr - - while_linking_expr = text "while linking an interpreted expression" - - -- This one is a build-system bug - - get_linkable osuf mod_name -- A home-package module - | Just mod_info <- lookupHpt hpt mod_name - = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) - | otherwise - = do -- It's not in the HPT because we are in one shot mode, - -- so use the Finder to get a ModLocation... - mb_stuff <- findHomeModule hsc_env mod_name - case mb_stuff of - Found loc mod -> found loc mod - _ -> no_obj mod_name - where - found loc mod = do { - -- ...and then find the linkable for it - mb_lnk <- findObjectLinkableMaybe mod loc ; - case mb_lnk of { - Nothing -> no_obj mod ; - Just lnk -> adjust_linkable lnk - }} - - adjust_linkable lnk - | Just new_osuf <- replace_osuf = do - new_uls <- mapM (adjust_ul new_osuf) - (linkableUnlinked lnk) - return lnk{ linkableUnlinked=new_uls } - | otherwise = - return lnk - - adjust_ul new_osuf (DotO file) = do - MASSERT(osuf `isSuffixOf` file) - let file_base = fromJust (stripExtension osuf file) - new_file = file_base <.> new_osuf - ok <- doesFileExist new_file - if (not ok) - then dieWith dflags span $ - text "cannot find object file " - <> quotes (text new_file) $$ while_linking_expr - else return (DotO new_file) - adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) - adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) - adjust_ul _ l@(BCOs {}) = return l - - - -{- ********************************************************************** - - Loading a Decls statement - - ********************************************************************* -} - -linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () -linkDecls hsc_env span cbc@CompiledByteCode{..} = do - -- Initialise the linker (if it's not been done already) - initDynLinker hsc_env - - -- Extract the DynLinker for passing into required places - let dl = hsc_dynLinker 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, ()) - where - free_names = uniqDSetToList $ - foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos - - needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, - isExternalName n, -- Names from other modules - not (isWiredInName n) -- Exclude wired-in names - ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - -{- ********************************************************************** - - Loading a single module - - ********************************************************************* -} - -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") - else return pls' - -{- ********************************************************************** - - Link some linkables - The linkables may consist of a mixture of - byte-code modules and object modules - - ********************************************************************* -} - -linkModules :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO (PersistentLinkerState, SuccessFlag) -linkModules 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 - - if failed ok_flag then - return (pls1, Failed) - else do - pls2 <- dynLinkBCOs hsc_env pls1 bcos - return (pls2, Succeeded) - - --- HACK to support f-x-dynamic in the interpreter; no other purpose -partitionLinkable :: Linkable -> [Linkable] -partitionLinkable li - = let li_uls = linkableUnlinked li - li_uls_obj = filter isObject li_uls - li_uls_bco = filter isInterpretable li_uls - in - case (li_uls_obj, li_uls_bco) of - (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, - li {linkableUnlinked=li_uls_bco}] - _ -> [li] - -findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable -findModuleLinkable_maybe lis mod - = case [LM time nm us | LM time nm us <- lis, nm == mod] of - [] -> Nothing - [li] -> Just li - _ -> pprPanic "findModuleLinkable" (ppr mod) - -linkableInSet :: Linkable -> [Linkable] -> Bool -linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModule l) of - Nothing -> False - Just m -> linkableTime l == linkableTime m - - -{- ********************************************************************** - - The object-code linker - - ********************************************************************* -} - -dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO (PersistentLinkerState, SuccessFlag) -dynLinkObjs hsc_env pls objs = do - -- Load the object files and link them - let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs - pls1 = pls { objs_loaded = objs_loaded' } - unlinkeds = concatMap linkableUnlinked new_objs - wanted_objs = map nameOfObject unlinkeds - - if interpreterDynamic (hscInterp hsc_env) - then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs - return (pls2, Succeeded) - else do mapM_ (loadObj hsc_env) wanted_objs - - -- Link them all together - ok <- resolveObjs hsc_env - - -- If resolving failed, unload all our - -- object modules and carry on - if succeeded ok then - return (pls1, Succeeded) - else do - pls2 <- unload_wkr hsc_env [] pls1 - return (pls2, Failed) - - -dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath] - -> IO PersistentLinkerState -dynLoadObjs _ pls [] = return pls -dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do - let dflags = hsc_dflags hsc_env - let platform = targetPlatform dflags - let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] - let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] - (soFile, libPath , libName) <- - newTempLibName dflags TFL_CurrentModule (platformSOExt platform) - let - dflags2 = dflags { - -- We don't want the original ldInputs in - -- (they're already linked in), but we do want - -- to link against previous dynLoadObjs - -- libraries if there were any, so that the linker - -- can resolve dependencies when it loads this - -- library. - ldInputs = - concatMap (\l -> [ Option ("-l" ++ l) ]) - (nub $ snd <$> temp_sos) - ++ concatMap (\lp -> Option ("-L" ++ lp) - : if gopt Opt_RPath dflags - then [ Option "-Xlinker" - , Option "-rpath" - , Option "-Xlinker" - , Option lp ] - else []) - (nub $ fst <$> temp_sos) - ++ concatMap - (\lp -> Option ("-L" ++ lp) - : if gopt Opt_RPath dflags - then [ Option "-Xlinker" - , Option "-rpath" - , Option "-Xlinker" - , Option lp ] - else []) - minus_big_ls - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - ++ map (\l -> Option ("-l" ++ l)) minus_ls, - -- Add -l options and -L options from dflags. - -- - -- When running TH for a non-dynamic way, we still - -- need to make -l flags to link against the dynamic - -- libraries, so we need to add WayDyn to ways. - -- - -- Even if we're e.g. profiling, we still want - -- the vanilla dynamic libraries, so we set the - -- ways / build tag to be just WayDyn. - ways = Set.singleton WayDyn, - outputFile = Just soFile - } - -- link all "loaded packages" so symbols in those can be resolved - -- Note: We are loading packages with local scope, so to see the - -- symbols in this link we must link all loaded packages again. - linkDynLib dflags2 objs pkgs_loaded - - -- if we got this far, extend the lifetime of the library file - changeTempFilesLifetime dflags TFL_GhcSession [soFile] - m <- loadDLL hsc_env soFile - case m of - 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" - -rmDupLinkables :: [Linkable] -- Already loaded - -> [Linkable] -- New linkables - -> ([Linkable], -- New loaded set (including new ones) - [Linkable]) -- New linkables (excluding dups) -rmDupLinkables already ls - = go already [] ls - where - go already extras [] = (already, extras) - go already extras (l:ls) - | linkableInSet l already = go already extras ls - | otherwise = go (l:already) (l:extras) ls - -{- ********************************************************************** - - The byte-code linker - - ********************************************************************* -} - - -dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable] - -> IO PersistentLinkerState -dynLinkBCOs hsc_env pls bcos = do - - let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos - pls1 = pls { bcos_loaded = bcos_loaded' } - unlinkeds :: [Unlinked] - unlinkeds = concatMap linkableUnlinked new_bcos - - cbcs :: [CompiledByteCode] - cbcs = map byteCodeOfObject unlinkeds - - - ies = map bc_itbls cbcs - gce = closure_env pls - final_ie = foldr plusNameEnv (itbl_env pls) ies - - names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs - - -- We only want to add the external ones to the ClosureEnv - let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs - - -- Immediately release any HValueRefs we're not going to add - freeHValueRefs hsc_env (map snd to_drop) - -- Wrap finalizers on the ones we want to keep - new_binds <- makeForeignNamedHValueRefs hsc_env to_add - - return pls1 { closure_env = extendClosureEnv gce new_binds, - itbl_env = final_ie } - --- Link a bunch of BCOs and return references to their values -linkSomeBCOs :: HscEnv - -> ItblEnv - -> ClosureEnv - -> [CompiledByteCode] - -> IO [(Name,HValueRef)] - -- The returned HValueRefs are associated 1-1 with - -- the incoming unlinked BCOs. Each gives the - -- value of the corresponding unlinked BCO - -linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods [] - where - fun CompiledByteCode{..} inner accum = - case bc_breaks of - Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum) - Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray -> - inner ((breakarray, bc_bcos) : accum) - - do_link [] = return [] - do_link mods = do - let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] - names = map (unlinkedBCOName . snd) flat - bco_ix = mkNameEnv (zip names [0..]) - resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco - | (breakarray, bco) <- flat ] - hvrefs <- createBCOs hsc_env resolved - return (zip names hvrefs) - --- | Useful to apply to the result of 'linkSomeBCOs' -makeForeignNamedHValueRefs - :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)] -makeForeignNamedHValueRefs hsc_env bindings = - mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings - -{- ********************************************************************** - - Unload some object modules - - ********************************************************************* -} - --- --------------------------------------------------------------------------- --- | Unloading old objects ready for a new compilation sweep. --- --- The compilation manager provides us with a list of linkables that it --- considers \"stable\", i.e. won't be recompiled this time around. For --- each of the modules current linked in memory, --- --- * if the linkable is stable (and it's the same one -- the user may have --- recompiled the module on the side), we keep it, --- --- * otherwise, we unload it. --- --- * we also implicitly unload all temporary bindings at this point. --- -unload :: HscEnv - -> [Linkable] -- ^ The linkables to *keep*. - -> IO () -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 - - -- Extract DynLinker for passing into required places - let dl = hsc_dynLinker hsc_env - - new_pls - <- modifyPLS dl $ \pls -> do - pls1 <- unload_wkr hsc_env linkables pls - return (pls1, pls1) - - let dflags = hsc_dflags hsc_env - debugTraceMsg dflags 3 $ - text "unload: retaining objs" <+> ppr (objs_loaded new_pls) - debugTraceMsg dflags 3 $ - text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) - return () - -unload_wkr :: HscEnv - -> [Linkable] -- stable linkables - -> PersistentLinkerState - -> IO PersistentLinkerState --- Does the core unload business --- (the wrapper blocks exceptions and deals with the PLS get and put) - -unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do - -- NB. careful strictness here to avoid keeping the old PLS when - -- we're unloading some code. -fghci-leak-check with the tests in - -- testsuite/ghci can detect space leaks here. - - let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables - - discard keep l = not (linkableInSet l keep) - - (objs_to_unload, remaining_objs_loaded) = - partition (discard objs_to_keep) objs_loaded - (bcos_to_unload, remaining_bcos_loaded) = - partition (discard bcos_to_keep) bcos_loaded - - mapM_ unloadObjs objs_to_unload - mapM_ unloadObjs bcos_to_unload - - -- If we unloaded any object files at all, we need to purge the cache - -- of lookupSymbol results. - when (not (null (objs_to_unload ++ - filter (not . null . linkableObjs) bcos_to_unload))) $ - purgeLookupSymbolCache hsc_env - - let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded - - -- Note that we want to remove all *local* - -- (i.e. non-isExternal) names too (these are the - -- temporary bindings from the command line). - keep_name :: (Name, a) -> Bool - keep_name (n,_) = isExternalName n && - nameModule n `elemModuleSet` bcos_retained - - itbl_env' = filterNameEnv keep_name itbl_env - closure_env' = filterNameEnv keep_name closure_env - - !new_pls = pls { itbl_env = itbl_env', - closure_env = closure_env', - bcos_loaded = remaining_bcos_loaded, - objs_loaded = remaining_objs_loaded } - - return new_pls - where - unloadObjs :: Linkable -> IO () - unloadObjs lnk - | hostIsDynamic = return () - -- We don't do any cleanup when linking objects with the - -- dynamic linker. Doing so introduces extra complexity for - -- not much benefit. - - -- Code unloading currently disabled due to instability. - -- See #16841. - -- id False, so that the pattern-match checker doesn't complain - | id False -- otherwise - = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk] - -- The components of a BCO linkable may contain - -- dot-o files. Which is very confusing. - -- - -- But the BCO parts can be unlinked just by - -- letting go of them (plus of course depopulating - -- the symbol table which is done in the main body) - | otherwise = return () -- see #16841 - -{- ********************************************************************** - - Loading packages - - ********************************************************************* -} - -data LibrarySpec - = Objects [FilePath] -- Full path names of set of .o files, including trailing .o - -- We allow batched loading to ensure that cyclic symbol - -- references can be resolved (see #13786). - -- For dynamic objects only, try to find the object - -- file in all the directories specified in - -- v_Library_paths before giving up. - - | Archive FilePath -- Full path name of a .a file, including trailing .a - - | DLL String -- "Unadorned" name of a .DLL/.so - -- e.g. On unix "qt" denotes "libqt.so" - -- On Windows "burble" denotes "burble.DLL" or "libburble.dll" - -- loadDLL is platform-specific and adds the lib/.so/.DLL - -- suffixes platform-dependently - - | DLLPath FilePath -- Absolute or relative pathname to a dynamic library - -- (ends with .dll or .so). - - | Framework String -- Only used for darwin, but does no harm - -instance Outputable LibrarySpec where - ppr (Objects objs) = text "Objects" <+> ppr objs - ppr (Archive a) = text "Archive" <+> text a - ppr (DLL s) = text "DLL" <+> text s - ppr (DLLPath f) = text "DLLPath" <+> text f - ppr (Framework s) = text "Framework" <+> text s - --- If this package is already part of the GHCi binary, we'll already --- have the right DLLs for this package loaded, so don't try to --- load them again. --- --- But on Win32 we must load them 'again'; doing so is a harmless no-op --- as far as the loader is concerned, but it does initialise the list --- of DLL handles that rts/Linker.c maintains, and that in turn is --- used by lookupSymbol. So we must call addDLL for each library --- just to get the DLL handle into the list. -partOfGHCi :: [PackageName] -partOfGHCi - | isWindowsHost || isDarwinHost = [] - | otherwise = map (PackageName . mkFastString) - ["base", "template-haskell", "editline"] - -showLS :: LibrarySpec -> String -showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" -showLS (Archive nm) = "(static archive) " ++ nm -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 --- automatically, and it doesn't matter what order you specify the input --- packages. --- -linkPackages :: 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. --- --- However we do need the package-config stuff (to find aux libs etc), --- and following them lets us load libraries in the right order, which --- 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 - -- 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 - pkgs' <- link (pkgs_loaded pls) new_pks - return $! pls { pkgs_loaded = pkgs' } - where - dflags = hsc_dflags hsc_env - pkgstate = unitState dflags - - link :: [UnitId] -> [UnitId] -> IO [UnitId] - link pkgs new_pkgs = - foldM link_one pkgs new_pkgs - - link_one pkgs new_pkg - | new_pkg `elem` pkgs -- Already linked - = return pkgs - - | Just pkg_cfg <- lookupUnitId pkgstate new_pkg - = do { -- Link dependents first - pkgs' <- link pkgs (unitDepends pkg_cfg) - -- Now link the package itself - ; linkPackage 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 - = do - let dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - is_dyn = interpreterDynamic (hscInterp hsc_env) - dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg - | otherwise = map ST.unpack $ Packages.unitLibraryDirs 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 - -- interpreted references to FFI to the compiled FFI. - -- We therefore filter it out so that we don't get - -- duplicate symbol errors. - hs_libs' = filter ("HSffi" /=) hs_libs - - -- Because of slight differences between the GHC dynamic linker and - -- the native system linker some packages have to link with a - -- different list of libraries when using GHCi. Examples include: libs - -- that are actually gnu ld scripts, and the possibility that the .a - -- libs do not exactly match the .so/.dll equivalents. So if the - -- package file provides an "extra-ghci-libraries" field then we use - -- that instead of the "extra-libraries" field. - extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg) - then Packages.unitExtDepLibsSys pkg - else Packages.unitExtDepLibsGhc pkg) - linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ] - extra_libs = extdeplibs ++ linkerlibs - - -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths dflags (platformOS platform) - dirs_env <- addEnvPaths "LIBRARY_PATH" dirs - - hs_classifieds - <- mapM (locateLib hsc_env True dirs_env gcc_paths) hs_libs' - extra_classifieds - <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs - let classifieds = hs_classifieds ++ extra_classifieds - - -- Complication: all the .so's must be loaded before any of the .o's. - let known_dlls = [ dll | DLLPath dll <- classifieds ] - dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Objects objs <- classifieds - , obj <- objs ] - archs = [ arch | Archive arch <- classifieds ] - - -- Add directories to library search paths - let dll_paths = map takeDirectory known_dlls - all_paths = nub $ map normalise $ dll_paths ++ dirs - all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths - pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env - - maybePutSDoc dflags - (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") - - -- See comments with partOfGHCi -#if defined(CAN_LOAD_DLL) - when (unitPackageName pkg `notElem` partOfGHCi) $ do - loadFrameworks hsc_env platform pkg - -- See Note [Crash early load_dyn and locateLib] - -- Crash early if can't load any of `known_dlls` - mapM_ (load_dyn hsc_env True) known_dlls - -- For remaining `dlls` crash early only when there is surely - -- no package's DLL around ... (not is_dyn) - mapM_ (load_dyn hsc_env (not is_dyn) . platformSOName platform) dlls -#endif - -- After loading all the DLLs, we can load the static objects. - -- Ordering isn't important here, because we do one final link - -- step to resolve everything. - mapM_ (loadObj hsc_env) objs - mapM_ (loadArchive hsc_env) archs - - maybePutStr dflags "linking ... " - ok <- resolveObjs hsc_env - - -- DLLs are loaded, reset the search paths - -- Import libraries will be loaded via loadArchive so only - -- reset the DLL search path after all archives are loaded - -- as well. - mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache - - if succeeded ok - then maybePutStrLn dflags "done." - else let errmsg = text "unable to load unit `" - <> pprUnitInfoForUser pkg <> text "'" - in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) - -{- -Note [Crash early load_dyn and locateLib] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a package is "normal" (exposes it's code from more than zero Haskell -modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then -it has it's code compiled and linked into the DLL, which GHCi linker picks -when loading the package's code (see the big comment in the beginning of -`locateLib`). - -When loading DLLs, GHCi linker simply calls the system's `dlopen` or -`LoadLibrary` APIs. This is quite different from the case when GHCi linker -loads an object file or static library. When loading an object file or static -library GHCi linker parses them and resolves all symbols "manually". -These object file or static library may reference some external symbols -defined in some external DLLs. And GHCi should know which these -external DLLs are. - -But when GHCi loads a DLL, it's the *system* linker who manages all -the necessary dependencies, and it is able to load this DLL not having -any extra info. Thus we don't *have to* crash in this case even if we -are unable to load any supposed dependencies explicitly. - -Suppose during GHCi session a client of the package wants to -`foreign import` a symbol which isn't exposed by the package DLL, but -is exposed by such an external (dependency) DLL. -If the DLL isn't *explicitly* loaded because `load_dyn` failed to do -this, then the client code eventually crashes because the GHCi linker -isn't able to locate this symbol (GHCi linker maintains a list of -explicitly loaded DLLs it looks into when trying to find a symbol). - -This is why we still should try to load all the dependency DLLs -even though we know that the system linker loads them implicitly when -loading the package DLL. - -Why we still keep the `crash_early` opportunity then not allowing such -a permissive behaviour for any DLLs? Well, we, perhaps, improve a user -experience in some cases slightly. - -But if it happens there exist other corner cases where our current -usage of `crash_early` flag is overly restrictive, we may lift the -restriction very easily. --} - --- we have already searched the filesystem; the strings passed to load_dyn --- can be passed directly to loadDLL. They are either fully-qualified --- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, --- loadDLL is going to search the system paths to find the library. -load_dyn :: HscEnv -> Bool -> FilePath -> IO () -load_dyn hsc_env crash_early dll = do - r <- loadDLL hsc_env dll - case r of - Nothing -> return () - Just err -> - if crash_early - then cmdLineErrorIO err - else let dflags = hsc_dflags hsc_env in - when (wopt Opt_WarnMissedExtraSharedLib dflags) - $ putLogMsg dflags - (Reason Opt_WarnMissedExtraSharedLib) SevWarning - noSrcSpan $ withPprStyle defaultUserStyle (note err) - where - note err = vcat $ map text - [ err - , "It's OK if you don't want to use symbols from it directly." - , "(the package DLL is loaded by the system linker" - , " which manages dependencies by itself)." ] - -loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO () -loadFrameworks hsc_env platform pkg - = when (platformUsesFrameworks platform) $ mapM_ load frameworks - where - fw_dirs = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg - frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg - - load fw = do r <- loadFramework hsc_env fw_dirs fw - case r of - Nothing -> return () - Just err -> cmdLineErrorIO ("can't load framework: " - ++ fw ++ " (" ++ err ++ ")" ) - --- Try to find an object file for a given library in the given paths. --- If it isn't present, we assume that addDLL in the RTS can find it, --- which generally means that it should be a dynamic library in the --- standard system search path. --- For GHCi we tend to prefer dynamic libraries over static ones as --- they are easier to load and manage, have less overhead. -locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String - -> IO LibrarySpec -locateLib hsc_env is_hs lib_dirs gcc_dirs lib - | not is_hs - -- For non-Haskell libraries (e.g. gmp, iconv): - -- first look in library-dirs for a dynamic library (on User paths only) - -- (libfoo.so) - -- then try looking for import libraries on Windows (on User paths only) - -- (.dll.a, .lib) - -- first look in library-dirs for a dynamic library (on GCC paths only) - -- (libfoo.so) - -- then check for system dynamic libraries (e.g. kernel32.dll on windows) - -- then try looking for import libraries on Windows (on GCC paths only) - -- (.dll.a, .lib) - -- then look in library-dirs for a static library (libfoo.a) - -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so) - -- then try looking for import libraries on Windows (.dll.a, .lib) - -- then look in library-dirs and inplace GCC for a static library (libfoo.a) - -- then try "gcc --print-file-name" to search gcc's search path - -- for a dynamic library (#5289) - -- otherwise, assume loadDLL can find it - -- - -- The logic is a bit complicated, but the rationale behind it is that - -- loading a shared library for us is O(1) while loading an archive is - -- O(n). Loading an import library is also O(n) so in general we prefer - -- shared libraries because they are simpler and faster. - -- - = -#if defined(CAN_LOAD_DLL) - findDll user `orElse` -#endif - tryImpLib user `orElse` -#if defined(CAN_LOAD_DLL) - findDll gcc `orElse` - findSysDll `orElse` -#endif - tryImpLib gcc `orElse` - findArchive `orElse` - tryGcc `orElse` - assumeDll - - | loading_dynamic_hs_libs -- search for .so libraries first. - = findHSDll `orElse` - findDynObject `orElse` - assumeDll - - | otherwise - -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a - = findObject `orElse` - findArchive `orElse` - assumeDll - - where - dflags = hsc_dflags hsc_env - interp = hscInterp hsc_env - dirs = lib_dirs ++ gcc_dirs - gcc = False - user = True - - obj_file - | is_hs && loading_profiled_hs_libs = lib <.> "p_o" - | otherwise = lib <.> "o" - dyn_obj_file = lib <.> "dyn_o" - arch_files = [ "lib" ++ lib ++ lib_tag <.> "a" - , lib <.> "a" -- native code has no lib_tag - , "lib" ++ lib, lib - ] - lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" - - loading_profiled_hs_libs = interpreterProfiled interp - loading_dynamic_hs_libs = interpreterDynamic interp - - import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib" - , "lib" ++ lib <.> "dll.a", lib <.> "dll.a" - ] - - hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags - hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name - - so_name = platformSOName platform lib - lib_so_name = "lib" ++ so_name - dyn_lib_file = case (arch, os) of - (ArchX86_64, OSSolaris2) -> "64" so_name - _ -> so_name - - findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file - findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file - findArchive = let local name = liftM (fmap Archive) $ findFile dirs name - in apply (map local arch_files) - findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file - findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs - in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file - findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ - findSystemLibrary hsc_env so_name - tryGcc = let search = searchForLibUsingGcc dflags - dllpath = liftM (fmap DLLPath) - short = dllpath $ search so_name lib_dirs - full = dllpath $ search lib_so_name lib_dirs - gcc name = liftM (fmap Archive) $ search name lib_dirs - files = import_libs ++ arch_files - dlls = [short, full] - archives = map gcc files - in apply $ -#if defined(CAN_LOAD_DLL) - dlls ++ -#endif - archives - tryImpLib re = case os of - OSMinGW32 -> - let dirs' = if re == user then lib_dirs else gcc_dirs - implib name = liftM (fmap Archive) $ - findFile dirs' name - in apply (map implib import_libs) - _ -> return Nothing - - -- TH Makes use of the interpreter so this failure is not obvious. - -- So we are nice and warn/inform users why we fail before we do. - -- But only for haskell libraries, as C libraries don't have a - -- profiling/non-profiling distinction to begin with. - assumeDll - | is_hs - , not loading_dynamic_hs_libs - , interpreterProfiled interp - = do - warningMsg dflags - (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ - text " \tTrying dynamic library instead. If this fails try to rebuild" <+> - text "libraries with profiling support.") - return (DLL lib) - | otherwise = return (DLL lib) - infixr `orElse` - f `orElse` g = f >>= maybe g return - - apply :: [IO (Maybe a)] -> IO (Maybe a) - apply [] = return Nothing - apply (x:xs) = do x' <- x - if isJust x' - then return x' - else apply xs - - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - -searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) -searchForLibUsingGcc dflags so dirs = do - -- GCC does not seem to extend the library search path (using -L) when using - -- --print-file-name. So instead pass it a new base location. - str <- askLd dflags (map (FileOption "-B") dirs - ++ [Option "--print-file-name", Option so]) - let file = case lines str of - [] -> "" - l:_ -> l - if (file == so) - then return Nothing - else do b <- doesFileExist file -- file could be a folder (see #16063) - return (if b then Just file else Nothing) - --- | Retrieve the list of search directory GCC and the System use to find --- libraries and components. See Note [Fork/Exec Windows]. -getGCCPaths :: DynFlags -> OS -> IO [FilePath] -getGCCPaths dflags os - = case os of - OSMinGW32 -> - do gcc_dirs <- getGccSearchDirectory dflags "libraries" - sys_dirs <- getSystemDirectories - return $ nub $ gcc_dirs ++ sys_dirs - _ -> return [] - --- | Cache for the GCC search directories as this can't easily change --- during an invocation of GHC. (Maybe with some env. variable but we'll) --- deal with that highly unlikely scenario then. -{-# NOINLINE gccSearchDirCache #-} -gccSearchDirCache :: IORef [(String, [String])] -gccSearchDirCache = unsafePerformIO $ newIORef [] - --- Note [Fork/Exec Windows] --- ~~~~~~~~~~~~~~~~~~~~~~~~ --- fork/exec is expensive on Windows, for each time we ask GCC for a library we --- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1. --- So instead get a list of location that GCC would search and use findDirs --- which hopefully is written in an optimized mannor to take advantage of --- caching. At the very least we remove the overhead of the fork/exec and waits --- which dominate a large percentage of startup time on Windows. -getGccSearchDirectory :: DynFlags -> String -> IO [FilePath] -getGccSearchDirectory dflags key = do - cache <- readIORef gccSearchDirCache - case lookup key cache of - Just x -> return x - Nothing -> do - str <- askLd dflags [Option "--print-search-dirs"] - let line = dropWhile isSpace str - name = key ++ ": =" - if null line - then return [] - else do let val = split $ find name line - dirs <- filterM doesDirectoryExist val - modifyIORef' gccSearchDirCache ((key, dirs):) - return val - where split :: FilePath -> [FilePath] - split r = case break (==';') r of - (s, [] ) -> [s] - (s, (_:xs)) -> s : split xs - - find :: String -> String -> String - find r x = let lst = lines x - val = filter (r `isPrefixOf`) lst - in if null val - then [] - else case break (=='=') (head val) of - (_ , []) -> [] - (_, (_:xs)) -> xs - --- | Get a list of system search directories, this to alleviate pressure on --- the findSysDll function. -getSystemDirectories :: IO [FilePath] -#if defined(mingw32_HOST_OS) -getSystemDirectories = fmap (:[]) getSystemDirectory -#else -getSystemDirectories = return [] -#endif - --- | Merge the given list of paths with those in the environment variable --- given. If the variable does not exist then just return the identity. -addEnvPaths :: String -> [String] -> IO [String] -addEnvPaths name list - = do -- According to POSIX (chapter 8.3) a zero-length prefix means current - -- working directory. Replace empty strings in the env variable with - -- `working_dir` (see also #14695). - working_dir <- getCurrentDirectory - values <- lookupEnv name - case values of - Nothing -> return list - Just arr -> return $ list ++ splitEnv working_dir arr - where - splitEnv :: FilePath -> String -> [String] - splitEnv working_dir value = - case break (== envListSep) value of - (x, [] ) -> - [if null x then working_dir else x] - (x, (_:xs)) -> - (if null x then working_dir else x) : splitEnv working_dir xs -#if defined(mingw32_HOST_OS) - envListSep = ';' -#else - envListSep = ':' -#endif - --- ---------------------------------------------------------------------------- --- 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) - } - -{- ********************************************************************** - - Helper functions - - ********************************************************************* -} - -maybePutSDoc :: DynFlags -> SDoc -> IO () -maybePutSDoc dflags s - = when (verbosity dflags > 1) $ - putLogMsg dflags - NoReason - SevInteractive - noSrcSpan - $ withPprStyle defaultUserStyle s - -maybePutStr :: DynFlags -> String -> IO () -maybePutStr dflags s = maybePutSDoc dflags (text s) - -maybePutStrLn :: DynFlags -> String -> IO () -maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") diff --git a/compiler/GHC/Runtime/Linker/Types.hs b/compiler/GHC/Runtime/Linker/Types.hs deleted file mode 100644 index e40de2b55e..0000000000 --- a/compiler/GHC/Runtime/Linker/Types.hs +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------ --- --- Types for the Dynamic Linker --- --- (c) The University of Glasgow 2019 --- ------------------------------------------------------------------------------ - -module GHC.Runtime.Linker.Types - ( DynLinker(..) - , PersistentLinkerState(..) - , Linkable(..) - , Unlinked(..) - , SptEntry(..) - , isObjectLinkable - , linkableObjs - , isObject - , nameOfObject - , isInterpretable - , byteCodeOfObject - ) -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 ) -import GHCi.RemoteTypes ( ForeignHValue ) - -import GHC.Types.Var ( Id ) -import GHC.Types.Name.Env ( NameEnv ) -import GHC.Types.Name ( Name ) - -import GHC.Utils.Outputable -import GHC.Utils.Panic - -type ClosureEnv = NameEnv (Name, ForeignHValue) - -newtype DynLinker = - DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) } - -data PersistentLinkerState - = PersistentLinkerState { - - -- Current global mapping from Names to their true values - closure_env :: ClosureEnv, - - -- 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 currently loaded interpreted modules (home package) - bcos_loaded :: ![Linkable], - - -- And the currently-loaded compiled modules (home package) - objs_loaded :: ![Linkable], - - -- 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], - - -- we need to remember the name of previous temporary DLL/.so - -- libraries so we can link them (see #10322) - temp_sos :: ![(FilePath, String)] } - --- | Information we can use to dynamically link modules into the compiler -data Linkable = LM { - linkableTime :: UTCTime, -- ^ Time at which this linkable was built - -- (i.e. when the bytecodes were produced, - -- or the mod date on the files) - linkableModule :: Module, -- ^ The linkable module itself - linkableUnlinked :: [Unlinked] - -- ^ Those files and chunks of code we have yet to link. - -- - -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. - -- If this list is empty, the Linkable represents a fake linkable, which - -- is generated with no backend is used to avoid recompiling modules. - -- - -- ToDo: Do items get removed from this list when they get linked? - } - -instance Outputable Linkable where - ppr (LM when_made mod unlinkeds) - = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) - $$ nest 3 (ppr unlinkeds) - --- | Objects which have yet to be linked by the compiler -data Unlinked - = DotO FilePath -- ^ An object file (.o) - | DotA FilePath -- ^ Static archive file (.a) - | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | BCOs CompiledByteCode - [SptEntry] -- ^ A byte-code object, lives only in memory. Also - -- carries some static pointer table entries which - -- should be loaded along with the BCOs. - -- See Note [Grant plan for static forms] in - -- "GHC.Iface.Tidy.StaticPtrTable". - -instance Outputable Unlinked where - ppr (DotO path) = text "DotO" <+> text path - ppr (DotA path) = text "DotA" <+> text path - ppr (DotDLL path) = text "DotDLL" <+> text path - ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt - --- | An entry to be inserted into a module's static pointer table. --- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". -data SptEntry = SptEntry Id Fingerprint - -instance Outputable SptEntry where - ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr - - -isObjectLinkable :: Linkable -> Bool -isObjectLinkable l = not (null unlinked) && all isObject unlinked - where unlinked = linkableUnlinked l - -- A linkable with no Unlinked's is treated as a BCO. We can - -- generate a linkable with no Unlinked's as a result of - -- compiling a module in NoBackend mode, and this choice - -- happens to work well with checkStability in module GHC. - -linkableObjs :: Linkable -> [FilePath] -linkableObjs l = [ f | DotO f <- linkableUnlinked l ] - -------------------------------------------- - --- | Is this an actual file on disk we can link in somehow? -isObject :: Unlinked -> Bool -isObject (DotO _) = True -isObject (DotA _) = True -isObject (DotDLL _) = True -isObject _ = False - --- | Is this a bytecode linkable with no file on disk? -isInterpretable :: Unlinked -> Bool -isInterpretable = not . isObject - --- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object -nameOfObject :: Unlinked -> FilePath -nameOfObject (DotO fn) = fn -nameOfObject (DotA fn) = fn -nameOfObject (DotDLL fn) = fn -nameOfObject other = pprPanic "nameOfObject" (ppr other) - --- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable -byteCodeOfObject :: Unlinked -> CompiledByteCode -byteCodeOfObject (BCOs bc _) = bc -byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) 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/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs deleted file mode 100644 index 1b728fb067..0000000000 --- a/compiler/GHC/SysTools/ExtraObj.hs +++ /dev/null @@ -1,251 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHC Extra object linking code --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ - -module GHC.SysTools.ExtraObj ( - mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, - checkLinkInfo, getLinkInfo, getCompilerInfo, - ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts, - haveRtsOptsFlags -) where - -import GHC.Utils.Asm -import GHC.Utils.Error -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Unit.State -import GHC.Platform -import GHC.Utils.Outputable as Outputable -import GHC.Types.SrcLoc ( noSrcSpan ) -import GHC.Unit -import GHC.SysTools.Elf -import GHC.Utils.Misc -import GHC.Prelude -import qualified GHC.Data.ShortText as ST - -import Control.Monad -import Data.Maybe - -import Control.Monad.IO.Class - -import GHC.SysTools.FileCleanup -import GHC.SysTools.Tasks -import GHC.SysTools.Info - -mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath -mkExtraObj dflags extn xs - = do cFile <- newTempName dflags TFL_CurrentModule extn - oFile <- newTempName dflags TFL_GhcSession "o" - writeFile cFile xs - ccInfo <- liftIO $ getCompilerInfo dflags - runCc Nothing dflags - ([Option "-c", - FileOption "" cFile, - Option "-o", - FileOption "" oFile] - ++ if extn /= "s" - then cOpts - else asmOpts ccInfo) - return oFile - where - pkgs = unitState dflags - - -- Pass a different set of options to the C compiler depending one whether - -- we're compiling C or assembler. When compiling C, we pass the usual - -- set of include directories and PIC flags. - cOpts = map Option (picCCOpts dflags) - ++ map (FileOption "-I" . ST.unpack) - (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit) - - -- When compiling assembler code, we drop the usual C options, and if the - -- compiler is Clang, we add an extra argument to tell Clang to ignore - -- unused command line options. See trac #11684. - asmOpts ccInfo = - if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [Option "-Qunused-arguments"] - else [] - --- When linking a binary, we need to create a C main() function that --- starts everything off. This used to be compiled statically as part --- of the RTS, but that made it hard to change the -rtsopts setting, --- so now we generate and compile a main() stub as part of every --- binary and pass the -rtsopts setting directly to the RTS (#5373) --- --- On Windows, when making a shared library we also may need a DllMain. --- -mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath -mkExtraObjToLinkIntoBinary dflags = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ - putLogMsg dflags NoReason SevInfo noSrcSpan - $ withPprStyle defaultUserStyle - (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - mkExtraObj dflags "c" (showSDoc dflags main) - where - main - | gopt Opt_NoHsMain dflags = Outputable.empty - | otherwise - = case ghcLink dflags of - LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32 - then dllMain - else Outputable.empty - _ -> exeMain - - exeMain = vcat [ - text "#include ", - text "extern StgClosure ZCMain_main_closure;", - text "int main(int argc, char *argv[])", - char '{', - text " RtsConfig __conf = defaultRtsConfig;", - text " __conf.rts_opts_enabled = " - <> text (show (rtsOptsEnabled dflags)) <> semi, - text " __conf.rts_opts_suggestions = " - <> text (if rtsOptsSuggestions dflags - then "true" - else "false") <> semi, - text "__conf.keep_cafs = " - <> text (if gopt Opt_KeepCAFs dflags - then "true" - else "false") <> semi, - case rtsOpts dflags of - Nothing -> Outputable.empty - Just opts -> text " __conf.rts_opts= " <> - text (show opts) <> semi, - text " __conf.rts_hs_main = true;", - text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", - char '}', - char '\n' -- final newline, to keep gcc happy - ] - - dllMain = vcat [ - text "#include ", - text "#include ", - text "#include ", - char '\n', - text "bool", - text "WINAPI", - text "DllMain ( HINSTANCE hInstance STG_UNUSED", - text " , DWORD reason STG_UNUSED", - text " , LPVOID reserved STG_UNUSED", - text " )", - text "{", - text " return true;", - text "}", - char '\n' -- final newline, to keep gcc happy - ] - --- Write out the link info section into a new assembly file. Previously --- this was included as inline assembly in the main.c file but this --- is pretty fragile. gas gets upset trying to calculate relative offsets --- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages - - if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) - else return [] - - where - platform = targetPlatform dflags - link_opts info = hcat [ - -- "link info" section (see Note [LinkInfo section]) - makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, - - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- "GHC.CmmToAsm" for another instance - -- where we need to do this. - if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," - <> sectionType platform "progbits" <> char '\n' - else Outputable.empty - ] - --- | Return the "link info" string --- --- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> [UnitId] -> IO String -getLinkInfo dflags dep_packages = do - package_link_opts <- getUnitLinkOpts dflags dep_packages - let unit_state = unitState dflags - home_unit = mkHomeUnitFromFlags dflags - ctx = initSDocContext dflags defaultUserStyle - pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) - then getUnitFrameworks ctx unit_state home_unit dep_packages - else return [] - let extra_ld_inputs = ldInputs dflags - let - link_info = (package_link_opts, - pkg_frameworks, - rtsOpts dflags, - rtsOptsEnabled dflags, - gopt Opt_NoHsMain dflags, - map showOpt extra_ld_inputs, - getOpts dflags opt_l) - -- - return (show link_info) - -platformSupportsSavingLinkOpts :: OS -> Bool -platformSupportsSavingLinkOpts os - | os == OSSolaris2 = False -- see #5382 - | otherwise = osElfTarget os - --- See Note [LinkInfo section] -ghcLinkInfoSectionName :: String -ghcLinkInfoSectionName = ".debug-ghc-link-info" - -- if we use the ".debug" prefix, then strip will strip it by default - --- Identifier for the note (see Note [LinkInfo section]) -ghcLinkInfoNoteName :: String -ghcLinkInfoNoteName = "GHC link info" - --- Returns 'False' if it was, and we can avoid linking, because the --- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool -checkLinkInfo dflags pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - -- ToDo: Windows and OS X do not use the ELF binary format, so - -- readelf does not work there. We need to find another way to do - -- this. - = return False -- conservatively we should return True, but not - -- linking in this case was the behaviour for a long - -- time so we leave it as-is. - | otherwise - = do - link_info <- getLinkInfo dflags pkg_deps - debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString dflags exe_file - ghcLinkInfoSectionName ghcLinkInfoNoteName - let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg dflags 3 $ case m_exe_link_info of - Nothing -> text "Exe link info: Not found" - Just s - | sameLinkInfo -> text ("Exe link info is the same") - | otherwise -> text ("Exe link info is different: " ++ s) - return (not sameLinkInfo) - -{- Note [LinkInfo section] - ~~~~~~~~~~~~~~~~~~~~~~~ - -The "link info" is a string representing the parameters of the link. We save -this information in the binary, and the next time we link, if nothing else has -changed, we use the link info stored in the existing binary to decide whether -to re-link or not. - -The "link info" string is stored in a ELF section called ".debug-ghc-link-info" -(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to -not follow the specified record-based format (see #11022). - --} - -haveRtsOptsFlags :: DynFlags -> Bool -haveRtsOptsFlags dflags = - isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of - RtsOptsSafeOnly -> False - _ -> True 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.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')) -- cgit v1.2.1