diff options
Diffstat (limited to 'compiler/GHC/Driver/Pipeline.hs')
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 375 |
1 files changed, 17 insertions, 358 deletions
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 2a2d9e294c..d8abadc0e5 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -20,9 +20,6 @@ module GHC.Driver.Pipeline ( -- collection of source files. oneShot, compileFile, - -- Interfaces for the batch-mode driver - linkBinary, - -- Interfaces for the compilation manager (interpreted/batch-mode) preprocess, compileOne, compileOne', @@ -32,8 +29,7 @@ module GHC.Driver.Pipeline ( PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..), phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv, hscPostBackendPhase, getLocation, setModLocation, setDynFlags, - runPhase, exeFileName, - maybeCreateManifest, + runPhase, doCpp, linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode ) where @@ -64,9 +60,14 @@ import GHC.Parser.Header import GHC.Parser.Errors.Ppr import GHC.SysTools -import GHC.SysTools.ExtraObj import GHC.SysTools.FileCleanup -import GHC.SysTools.Ar + +import GHC.Linker.ExtraObj +import GHC.Linker.Dynamic +import GHC.Linker.MacOS +import GHC.Linker.Unit +import GHC.Linker.Static +import GHC.Linker.Types import GHC.Utils.Outputable import GHC.Utils.Error @@ -78,7 +79,6 @@ import GHC.Utils.Exception as Exception import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import qualified GHC.LanguageExtensions as LangExt import GHC.Settings -import GHC.Runtime.Linker.Types import GHC.Data.Bag ( unitBag ) import GHC.Data.FastString ( mkFastString ) @@ -549,8 +549,8 @@ link' dflags batch_attempt_linking hpt let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables - - exe_file = exeFileName staticLink dflags + platform = targetPlatform dflags + exe_file = exeFileName platform staticLink (outputFile dflags) linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps @@ -585,7 +585,8 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). - let exe_file = exeFileName staticLink dflags + let platform = targetPlatform dflags + exe_file = exeFileName platform staticLink (outputFile dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return True @@ -606,7 +607,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do | Just c <- map (lookupUnitId unit_state) pkg_deps, lib <- packageHsLibs dflags c ] - pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs + pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs if any isNothing pkg_libfiles then return True else do e_lib_times <- mapM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) @@ -615,11 +616,11 @@ linkingNeeded dflags staticLink linkables pkg_deps = do then return True else checkLinkInfo dflags pkg_deps exe_file -findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath) -findHSLib dflags dirs lib = do - let batch_lib_file = if WayDyn `notElem` ways dflags +findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) +findHSLib platform ws dirs lib = do + let batch_lib_file = if WayDyn `notElem` ws then "lib" ++ lib <.> "a" - else platformSOName (targetPlatform dflags) lib + else platformSOName platform lib found <- filterM doesFileExist (map (</> batch_lib_file) dirs) case found of [] -> return Nothing @@ -1727,307 +1728,6 @@ getHCFilePackages filename = _other -> return [] ------------------------------------------------------------------------------ --- Static linking, of .o files - --- The list of packages passed to link is the list of packages on --- which this program depends, as discovered by the compilation --- manager. It is combined with the list of packages that the user --- specifies on the command line with -package flags. --- --- In one-shot linking mode, we can't discover the package --- dependencies (because we haven't actually done any compilation or --- read any interface files), so the user must explicitly specify all --- the packages. - -{- -Note [-Xlinker -rpath vs -Wl,-rpath] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --Wl takes a comma-separated list of options which in the case of --Wl,-rpath -Wl,some,path,with,commas parses the path with commas -as separate options. -Buck, the build system, produces paths with commas in them. - --Xlinker doesn't have this disadvantage and as far as I can tell -it is supported by both gcc and clang. Anecdotally nvcc supports --Xlinker, but not -Wl. --} - -linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO () -linkBinary = linkBinary' False - -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO () -linkBinary' staticLink dflags o_files dep_units = do - let platform = targetPlatform dflags - toolSettings' = toolSettings dflags - verbFlags = getVerbFlags dflags - output_fn = exeFileName staticLink dflags - home_unit = mkHomeUnitFromFlags dflags - - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. - - full_output_fn <- if isAbsolute output_fn - then return output_fn - else do d <- getCurrentDirectory - return $ normalise (d </> output_fn) - pkg_lib_paths <- getUnitLibraryPath - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - home_unit - (ways dflags) - dep_units - let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths - get_pkg_lib_path_opts l - | osElfTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "$ORIGIN" </> - (l `makeRelativeTo` full_output_fn) - else l - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - rpath = if gopt Opt_RPath dflags - then ["-Xlinker", "-rpath", "-Xlinker", libpath] - else [] - -- Solaris 11's linker does not support -rpath-link option. It silently - -- ignores it and then complains about next option which is -l<some - -- dir> as being a directory and not expected object file, E.g - -- ld: elf error: file - -- /tmp/ghc-src/libraries/base/dist-install/build: - -- elf_begin: I/O error: region read: Is a directory - rpathlink = if (platformOS platform) == OSSolaris2 - then [] - else ["-Xlinker", "-rpath-link", "-Xlinker", l] - in ["-L" ++ l] ++ rpathlink ++ rpath - | osMachOTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - WayDyn `elem` ways dflags && - gopt Opt_RPath dflags - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "@loader_path" </> - (l `makeRelativeTo` full_output_fn) - else l - in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] - | otherwise = ["-L" ++ l] - - pkg_lib_path_opts <- - if gopt Opt_SingleLibFolder dflags - then do - libs <- getLibs dflags dep_units - tmpDir <- newTempDir dflags - sequence_ [ copyFile lib (tmpDir </> basename) - | (lib, basename) <- libs] - return [ "-L" ++ tmpDir ] - else pure pkg_lib_path_opts - - let - dead_strip - | gopt Opt_WholeArchiveHsLibs dflags = [] - | otherwise = if osSubsectionsViaSymbols (platformOS platform) - then ["-Wl,-dead_strip"] - else [] - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags - noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units - - let - (pre_hs_libs, post_hs_libs) - | gopt Opt_WholeArchiveHsLibs dflags - = if platformOS platform == OSDarwin - then (["-Wl,-all_load"], []) - -- OS X does not have a flag to turn off -all_load - else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) - | otherwise - = ([],[]) - - pkg_link_opts <- do - (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units - return $ if staticLink - then package_hs_libs -- If building an executable really means making a static - -- library (e.g. iOS), then we only keep the -l options for - -- HS packages, because libtool doesn't accept other options. - -- In the case of iOS these need to be added by hand to the - -- final link in Xcode. - else other_flags ++ dead_strip - ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs - ++ extra_libs - -- -Wl,-u,<sym> contained in other_flags - -- needs to be put before -l<package>, - -- otherwise Solaris linker fails linking - -- a binary with unresolved symbols in RTS - -- which are defined in base package - -- the reason for this is a note in ld(1) about - -- '-u' option: "The placement of this option - -- on the command line is significant. - -- This option must be placed before the library - -- that defines the symbol." - - -- frameworks - pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units - let framework_opts = getFrameworkOpts dflags platform - - -- probably _stub.o files - let extra_ld_inputs = ldInputs dflags - - rc_objs <- maybeCreateManifest dflags output_fn - - let link dflags args | staticLink = GHC.SysTools.runLibtool dflags args - | platformOS platform == OSDarwin - = GHC.SysTools.runLink dflags args >> GHC.SysTools.runInjectRPaths dflags pkg_lib_paths output_fn - | otherwise - = GHC.SysTools.runLink dflags args - - link dflags ( - map GHC.SysTools.Option verbFlags - ++ [ GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ] - ++ libmLinkOpts - ++ map GHC.SysTools.Option ( - [] - - -- See Note [No PIE when linking] - ++ picCCOpts dflags - - -- Permit the linker to auto link _symbol to _imp_symbol. - -- This lets us link against DLLs without needing an "import library". - ++ (if platformOS platform == OSMinGW32 - then ["-Wl,--enable-auto-import"] - else []) - - -- '-no_compact_unwind' - -- C++/Objective-C exceptions cannot use optimised - -- stack unwinding code. The optimised form is the - -- default in Xcode 4 on at least x86_64, and - -- without this flag we're also seeing warnings - -- like - -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog - -- on x86. - ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' && - not staticLink && - (platformOS platform == OSDarwin) && - case platformArch platform of - ArchX86 -> True - ArchX86_64 -> True - ArchARM {} -> True - ArchARM64 -> True - _ -> False - then ["-Wl,-no_compact_unwind"] - else []) - - -- '-Wl,-read_only_relocs,suppress' - -- ld gives loads of warnings like: - -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure - -- when linking any program. We're not sure - -- whether this is something we ought to fix, but - -- for now this flags silences them. - ++ (if platformOS platform == OSDarwin && - platformArch platform == ArchX86 && - not staticLink - then ["-Wl,-read_only_relocs,suppress"] - else []) - - ++ (if toolSettings_ldIsGnuLd toolSettings' && - not (gopt Opt_WholeArchiveHsLibs dflags) - then ["-Wl,--gc-sections"] - else []) - - ++ o_files - ++ lib_path_opts) - ++ extra_ld_inputs - ++ map GHC.SysTools.Option ( - rc_objs - ++ framework_opts - ++ pkg_lib_path_opts - ++ extraLinkObj:noteLinkObjs - ++ pkg_link_opts - ++ pkg_framework_opts - ++ (if platformOS platform == OSDarwin - -- dead_strip_dylibs, will remove unused dylibs, and thus save - -- space in the load commands. The -headerpad is necessary so - -- that we can inject more @rpath's later for the left over - -- libraries during runInjectRpaths phase. - -- - -- See Note [Dynamic linking on macOS]. - then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] - else []) - )) - -exeFileName :: Bool -> DynFlags -> FilePath -exeFileName staticLink dflags - | Just s <- outputFile dflags = - case platformOS (targetPlatform dflags) of - OSMinGW32 -> s <?.> "exe" - _ -> if staticLink - then s <?.> "a" - else s - | otherwise = - if platformOS (targetPlatform dflags) == OSMinGW32 - then "main.exe" - else if staticLink - then "liba.a" - else "a.out" - where s <?.> ext | null (takeExtension s) = s <.> ext - | otherwise = s - -maybeCreateManifest - :: DynFlags - -> FilePath -- filename of executable - -> IO [FilePath] -- extra objects to embed, maybe -maybeCreateManifest dflags exe_filename - | platformOS (targetPlatform dflags) == OSMinGW32 && - gopt Opt_GenManifest dflags - = do let manifest_filename = exe_filename <.> "manifest" - - writeFile manifest_filename $ - "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++ - " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++ - " <assemblyIdentity version=\"1.0.0.0\"\n"++ - " processorArchitecture=\"X86\"\n"++ - " name=\"" ++ dropExtension exe_filename ++ "\"\n"++ - " type=\"win32\"/>\n\n"++ - " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++ - " <security>\n"++ - " <requestedPrivileges>\n"++ - " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++ - " </requestedPrivileges>\n"++ - " </security>\n"++ - " </trustInfo>\n"++ - "</assembly>\n" - - -- Windows will find the manifest file if it is named - -- foo.exe.manifest. However, for extra robustness, and so that - -- we can move the binary around, we can embed the manifest in - -- the binary itself using windres: - if not (gopt Opt_EmbedManifest dflags) then return [] else do - - rc_filename <- newTempName dflags TFL_CurrentModule "rc" - rc_obj_filename <- - newTempName dflags TFL_GhcSession (objectSuf dflags) - - writeFile rc_filename $ - "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" - -- magic numbers :-) - -- show is a bit hackish above, but we need to escape the - -- backslashes in the path. - - runWindres dflags $ map GHC.SysTools.Option $ - ["--input="++rc_filename, - "--output="++rc_obj_filename, - "--output-format=coff"] - -- no FileOptions here: windres doesn't like seeing - -- backslashes, apparently - - removeFile manifest_filename - - return [rc_obj_filename] - | otherwise = return [] - linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLibCheck dflags o_files dep_units = do @@ -2038,47 +1738,6 @@ linkDynLibCheck dflags o_files dep_units = do text " Call hs_init_ghc() from your main() function to set these options.") linkDynLib dflags o_files dep_units --- | Linking a static lib will not really link anything. It will merely produce --- a static archive of all dependent static libraries. The resulting library --- will still need to be linked with any remaining link flags. -linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO () -linkStaticLib dflags o_files dep_units = do - let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] - modules = o_files ++ extra_ld_inputs - output_fn = exeFileName True dflags - home_unit = mkHomeUnitFromFlags dflags - - full_output_fn <- if isAbsolute output_fn - then return output_fn - else do d <- getCurrentDirectory - return $ normalise (d </> output_fn) - output_exists <- doesFileExist full_output_fn - (when output_exists) $ removeFile full_output_fn - - pkg_cfgs_init <- getPreloadUnitsAnd - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - home_unit - dep_units - - let pkg_cfgs - | gopt Opt_LinkRts dflags - = pkg_cfgs_init - | otherwise - = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init - - archives <- concatMapM (collectArchives dflags) pkg_cfgs - - ar <- foldl mappend - <$> (Archive <$> mapM loadObj modules) - <*> mapM loadAr archives - - if toolSettings_ldIsGnuLd (toolSettings dflags) - then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar - else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar - - -- run ranlib over the archive. write*Ar does *not* create the symbol index. - runRanlib dflags [GHC.SysTools.FileOption "" output_fn] -- ----------------------------------------------------------------------------- -- Running CPP |