Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 43198b09 by Sylvain Henry at 2025-11-19T20:38:18-05:00 Build external interpreter program on demand (#24731) This patch teaches GHC how to build the external interpreter program when it is missing. As long as we have the `ghci` library, doing this is trivial so most of this patch is refactoring for doing it sanely. - - - - - c900b914 by Rodrigo Mesquita at 2025-11-19T20:38:19-05:00 Add tests for #23973 and #26565 These were fixed by 4af4f0f070f83f948e49ad5d7835fd91b8d3f0e6 in !10417 - - - - - 28 changed files: - compiler/GHC.hs - + compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/Config/Linker.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Linker/Config.hs - compiler/GHC/Linker/Dynamic.hs - + compiler/GHC/Linker/Executable.hs - − compiler/GHC/Linker/ExtraObj.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/MacOS.hs - compiler/GHC/Linker/Static.hs - compiler/GHC/Linker/Windows.hs - + compiler/GHC/Runtime/Interpreter/C.hs - + compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/SysTools/Tasks.hs - compiler/ghc.cabal.in - + testsuite/tests/bytecode/T23973.hs - + testsuite/tests/bytecode/T23973.script - + testsuite/tests/bytecode/T23973.stdout - + testsuite/tests/bytecode/T26565.hs - + testsuite/tests/bytecode/T26565.script - + testsuite/tests/bytecode/T26565.stdout - testsuite/tests/bytecode/all.T - + testsuite/tests/driver/T24731.hs - testsuite/tests/driver/all.T - utils/iserv/iserv.cabal.in Changes: ===================================== compiler/GHC.hs ===================================== @@ -337,7 +337,6 @@ module GHC ( import GHC.Prelude hiding (init) import GHC.Platform -import GHC.Platform.Ways import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename , isSourceFilename, startPhase ) @@ -351,7 +350,6 @@ import GHC.Driver.Backend import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.StgToJS (initStgToJSConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Main import GHC.Driver.Make @@ -360,10 +358,11 @@ import GHC.Driver.Monad import GHC.Driver.Ppr import GHC.ByteCode.Types -import qualified GHC.Linker.Loader as Loader import GHC.Runtime.Loader import GHC.Runtime.Eval import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Init +import GHC.Driver.Config.Interpreter import GHC.Runtime.Context import GHCi.RemoteTypes @@ -439,10 +438,8 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo import qualified GHC.Unit.Home.Graph as HUG -import GHC.Settings import Control.Applicative ((<|>)) -import Control.Concurrent import Control.Monad import Control.Monad.Catch as MC import Data.Foldable @@ -715,98 +712,16 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m () setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger - lookup_cache <- liftIO $ mkInterpSymbolCache - - -- see Note [Target code interpreter] - interp <- if -#if !defined(wasm32_HOST_ARCH) - -- Wasm dynamic linker - | ArchWasm32 <- platformArch $ targetPlatform dflags - -> do - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - dyld <- liftIO $ makeAbsolute $ topDir dflags "dyld.mjs" - libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger dflags "libraries" - let profiled = ways dflags `hasWay` WayProf - way_tag = if profiled then "_p" else "" - let cfg = - WasmInterpConfig - { wasmInterpDyLD = dyld, - wasmInterpLibDir = libdir, - wasmInterpOpts = getOpts dflags opt_i, - wasmInterpBrowser = gopt Opt_GhciBrowser dflags, - wasmInterpBrowserHost = ghciBrowserHost dflags, - wasmInterpBrowserPort = ghciBrowserPort dflags, - wasmInterpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags, - wasmInterpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags, - wasmInterpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags, - wasmInterpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags, - wasmInterpTargetPlatform = targetPlatform dflags, - wasmInterpProfiled = profiled, - wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags), - wasmInterpUnitState = ue_homeUnitState $ hsc_unit_env hsc_env - } - pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache -#endif - - -- JavaScript interpreter - | ArchJavaScript <- platformArch (targetPlatform dflags) - -> do - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - let cfg = JSInterpConfig - { jsInterpNodeConfig = defaultNodeJsSettings - , jsInterpScript = topDir dflags "ghc-interp.js" - , jsInterpTmpFs = hsc_tmpfs hsc_env - , jsInterpTmpDir = tmpDir dflags - , jsInterpLogger = hsc_logger hsc_env - , jsInterpCodegenCfg = initStgToJSConfig dflags - , jsInterpUnitEnv = hsc_unit_env hsc_env - , jsInterpFinderOpts = initFinderOpts dflags - , jsInterpFinderCache = hsc_FC hsc_env - } - return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) - - -- external interpreter - | gopt Opt_ExternalInterpreter dflags - -> do - let - prog = pgm_i dflags ++ flavour - profiled = ways dflags `hasWay` WayProf - dynamic = ways dflags `hasWay` WayDyn - flavour - | profiled && dynamic = "-prof-dyn" - | profiled = "-prof" - | dynamic = "-dyn" - | otherwise = "" - msg = text "Starting " <> text prog - tr <- if verbosity dflags >= 3 - then return (logInfo logger $ withPprStyle defaultDumpStyle msg) - else return (pure ()) - let - conf = IServConfig - { iservConfProgram = prog - , iservConfOpts = getOpts dflags opt_i - , iservConfProfiled = profiled - , iservConfDynamic = dynamic - , iservConfHook = createIservProcessHook (hsc_hooks hsc_env) - , iservConfTrace = tr - } - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) - - -- Internal interpreter - | otherwise - -> -#if defined(HAVE_INTERNAL_INTERPRETER) - do - loader <- liftIO Loader.uninitializedLoader - return (Just (Interp InternalInterp loader lookup_cache)) -#else - return Nothing -#endif - + let platform = targetPlatform dflags + let unit_env = hsc_unit_env hsc_env + let tmpfs = hsc_tmpfs hsc_env + let finder_cache = hsc_FC hsc_env + interp_opts' <- liftIO $ initInterpOpts dflags + let interp_opts = interp_opts' + { interpCreateProcess = createIservProcessHook (hsc_hooks hsc_env) + } + + interp <- liftIO $ initInterpreter tmpfs logger platform finder_cache unit_env interp_opts modifySession $ \h -> hscSetFlags dflags h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -0,0 +1,46 @@ +module GHC.Driver.Config.Interpreter + ( initInterpOpts + ) +where + +import GHC.Prelude +import GHC.Runtime.Interpreter.Init +import GHC.Driver.DynFlags +import GHC.Driver.Session +import GHC.Driver.Config.Finder +import GHC.Driver.Config.StgToJS +import GHC.SysTools.Tasks +import GHC.Linker.Executable + +import System.FilePath +import System.Directory + +initInterpOpts :: DynFlags -> IO InterpOpts +initInterpOpts dflags = do + wasm_dyld <- makeAbsolute $ topDir dflags "dyld.mjs" + js_interp <- makeAbsolute $ topDir dflags "ghc-interp.js" + pure $ InterpOpts + { interpExternal = gopt Opt_ExternalInterpreter dflags + , interpProg = pgm_i dflags + , interpOpts = getOpts dflags opt_i + , interpWays = ways dflags + , interpNameVer = ghcNameVersion dflags + , interpCreateProcess = Nothing + , interpWasmDyld = wasm_dyld + , interpBrowser = gopt Opt_GhciBrowser dflags + , interpBrowserHost = ghciBrowserHost dflags + , interpBrowserPort = ghciBrowserPort dflags + , interpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags + , interpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags + , interpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags + , interpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags + , interpJsInterp = js_interp + , interpTmpDir = tmpDir dflags + , interpJsCodegenCfg = initStgToJSConfig dflags + , interpFinderOpts = initFinderOpts dflags + , interpVerbosity = verbosity dflags + , interpLdConfig = configureLd dflags + , interpCcConfig = configureCc dflags + , interpExecutableLinkOpts = initExecutableLinkOpts dflags + } + ===================================== compiler/GHC/Driver/Config/Linker.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Linker.Config import GHC.Driver.DynFlags import GHC.Driver.Session +import GHC.Settings import Data.List (isPrefixOf) @@ -52,6 +53,8 @@ initLinkerConfig dflags = , linkerOptionsPost = post_args , linkerTempDir = tmpDir dflags , linkerFilter = ld_filter + , linkerSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind (toolSettings dflags) + , linkerIsGnuLd = toolSettings_ldIsGnuLd (toolSettings dflags) } {- Note [Solaris linker] ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Driver.DynFlags ( ParMakeCount(..), ways, HasDynFlags(..), ContainsDynFlags(..), - RtsOptsEnabled(..), + RtsOptsEnabled(..), haveRtsOptsFlags, GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), PackageArg(..), ModRenaming(..), @@ -902,6 +902,13 @@ data RtsOptsEnabled | RtsOptsAll deriving (Show) +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True + + -- | Are we building with @-fPIE@ or @-fPIC@ enabled? positionIndependent :: DynFlags -> Bool positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -71,7 +71,7 @@ import GHC.SysTools import GHC.SysTools.Cpp import GHC.Utils.TmpFs -import GHC.Linker.ExtraObj +import GHC.Linker.Executable import GHC.Linker.Static import GHC.Linker.Static.Utils import GHC.Linker.Types @@ -444,7 +444,9 @@ link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt case ghcLink dflags of LinkBinary | backendUseJSLinker (backend dflags) -> linkJSBinary logger tmpfs fc dflags unit_env obj_files pkg_deps - | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps + | otherwise -> do + let opts = initExecutableLinkOpts dflags + linkExecutable logger tmpfs opts unit_env obj_files pkg_deps LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps other -> panicBadLink other @@ -511,7 +513,8 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do if not (null lib_errs) || any (t <) lib_times then return $ needsRecompileBecause LibraryChanged else do - res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file + let opts = initExecutableLinkOpts dflags + res <- checkLinkInfo logger opts unit_env pkg_deps exe_file if res then return $ needsRecompileBecause FlagsChanged else return UpToDate @@ -585,7 +588,9 @@ doLink hsc_env o_files = do LinkBinary | backendUseJSLinker (backend dflags) -> linkJSBinary logger tmpfs fc dflags unit_env o_files [] - | otherwise -> linkBinary logger tmpfs dflags unit_env o_files [] + | otherwise -> do + let opts = initExecutableLinkOpts dflags + linkExecutable logger tmpfs opts unit_env o_files [] LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] LinkMergedObj ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -15,6 +15,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch import GHC.Driver.Hooks +import GHC.Driver.DynFlags import Control.Monad.Trans.Reader import GHC.Driver.Pipeline.Monad import GHC.Driver.Pipeline.Phases @@ -74,7 +75,6 @@ import GHC.CmmToLlvm.Version.Type (LlvmVersion (..)) import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) import GHC.Settings import System.IO -import GHC.Linker.ExtraObj import GHC.Linker.Dynamic import GHC.Utils.Panic import GHC.Utils.Touch @@ -416,6 +416,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do let unit_env = hsc_unit_env hsc_env let home_unit = hsc_home_unit_maybe hsc_env let tmpfs = hsc_tmpfs hsc_env + let tmpdir = tmpDir dflags let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc @@ -437,7 +438,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do let include_paths = include_paths_quote ++ include_paths_global let gcc_extra_viac_flags = extraGccViaCFlags dflags - let pic_c_flags = picCCOpts dflags + let cc_config = configureCc dflags let verbFlags = getVerbFlags dflags @@ -486,14 +487,14 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env withAtomicRename output_fn $ \temp_outputFilename -> - GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( + GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs tmpdir cc_config ( [ GHC.SysTools.Option "-c" , GHC.SysTools.FileOption "" input_fn , GHC.SysTools.Option "-o" , GHC.SysTools.FileOption "" temp_outputFilename ] ++ map GHC.SysTools.Option ( - pic_c_flags + (ccPicOpts cc_config) -- See Note [Produce big objects on Windows] ++ [ "-Wa,-mbig-obj" @@ -1149,7 +1150,8 @@ joinObjectFiles hsc_env o_files output_fn | otherwise = do withAtomicRename output_fn $ \tmp_ar -> - liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files + let ar_opts = configureAr dflags + in liftIO $ runAr logger ar_opts Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files where dashLSupported = sArSupportsDashL (settings dflags) dashL = if dashLSupported then "L" else "" ===================================== compiler/GHC/Linker/Config.hs ===================================== @@ -23,5 +23,7 @@ data LinkerConfig = LinkerConfig , linkerOptionsPost :: [Option] -- ^ Linker options (after user options) , linkerTempDir :: TempDir -- ^ Temporary directory to use , linkerFilter :: [String] -> [String] -- ^ Output filter + , linkerSupportsCompactUnwind :: !Bool -- ^ Does the linker support compact unwind + , linkerIsGnuLd :: !Bool -- ^ Is it GNU LD (used for gc-sections support) } ===================================== compiler/GHC/Linker/Dynamic.hs ===================================== @@ -12,6 +12,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule)) +import GHC.SysTools.Tasks import GHC.Driver.Config.Linker import GHC.Driver.Session @@ -207,8 +208,10 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] ) -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 - when (gopt Opt_RPath dflags) $ - runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn + when (gopt Opt_RPath dflags) $ do + let otool_opts = configureOtool dflags + let install_name_opts = configureInstallName dflags + runInjectRPaths logger otool_opts install_name_opts pkg_lib_paths output_fn _ -> do ------------------------------------------------------------------- -- Making a DSO ===================================== compiler/GHC/Linker/Executable.hs ===================================== @@ -0,0 +1,534 @@ +-- | Linking executables +module GHC.Linker.Executable + ( linkExecutable + , ExecutableLinkOpts (..) + , initExecutableLinkOpts + -- RTS Opts + , RtsOptsEnabled (..) + -- * Link info + , LinkInfo (..) + , initLinkInfo + , checkLinkInfo + , ghcLinkInfoSectionName + , ghcLinkInfoNoteName + , platformSupportsSavingLinkOpts + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Unit +import GHC.Unit.Env + +import GHC.Utils.Asm +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import GHC.Driver.Session +import GHC.Driver.Config.Linker + +import qualified GHC.Data.ShortText as ST + +import GHC.SysTools +import GHC.SysTools.Elf +import GHC.Linker.Config +import GHC.Linker.Unit +import GHC.Linker.MacOS +import GHC.Linker.Windows +import GHC.Linker.Dynamic (libmLinkOpts) +import GHC.Linker.External (runLink) +import GHC.Linker.Static.Utils (exeFileName) + +import Control.Monad +import Data.Maybe +import System.FilePath +import System.Directory + +data ExecutableLinkOpts = ExecutableLinkOpts + { leOutputFile :: Maybe FilePath + , leNameVersion :: GhcNameVersion + , leWays :: Ways + , leDynLibLoader :: DynLibLoader + , leRelativeDynlibPaths :: !Bool + , leUseXLinkerRPath :: !Bool + , leSingleLibFolder :: !Bool + , leWholeArchiveHsLibs :: !Bool + , leGenManifest :: !Bool + , leRPath :: !Bool + , leCompactUnwind :: !Bool + , leLibraryPaths :: [String] + , leFrameworkOpts :: FrameworkOpts + , leManifestOpts :: ManifestOpts + , leLinkerConfig :: LinkerConfig + , leOtoolConfig :: OtoolConfig + , leCcConfig :: CcConfig + , leInstallNameConfig :: InstallNameConfig + , leInputs :: [Option] + , lePieOpts :: [String] + , leTempDir :: TempDir + , leVerbFlags :: [String] + , leNoHsMain :: !Bool + , leMainSymbol :: String + , leRtsOptsEnabled :: !RtsOptsEnabled + , leRtsOptsSuggestions :: !Bool + , leKeepCafs :: !Bool + , leRtsOpts :: Maybe String + } + +initExecutableLinkOpts :: DynFlags -> ExecutableLinkOpts +initExecutableLinkOpts dflags = + let + platform = targetPlatform dflags + os = platformOS platform + in ExecutableLinkOpts + { leOutputFile = outputFile_ dflags + , leNameVersion = ghcNameVersion dflags + , leWays = ways dflags + , leDynLibLoader = dynLibLoader dflags + , leRelativeDynlibPaths = gopt Opt_RelativeDynlibPaths dflags + , leUseXLinkerRPath = useXLinkerRPath dflags os + , leSingleLibFolder = gopt Opt_SingleLibFolder dflags + , leWholeArchiveHsLibs = gopt Opt_WholeArchiveHsLibs dflags + , leGenManifest = gopt Opt_GenManifest dflags + , leRPath = gopt Opt_RPath dflags + , leCompactUnwind = gopt Opt_CompactUnwind dflags + , leLibraryPaths = libraryPaths dflags + , leFrameworkOpts = initFrameworkOpts dflags + , leManifestOpts = initManifestOpts dflags + , leLinkerConfig = initLinkerConfig dflags + , leCcConfig = configureCc dflags + , leOtoolConfig = configureOtool dflags + , leInstallNameConfig = configureInstallName dflags + , leInputs = ldInputs dflags + , lePieOpts = pieCCLDOpts dflags + , leTempDir = tmpDir dflags + , leVerbFlags = getVerbFlags dflags + , leNoHsMain = gopt Opt_NoHsMain dflags + , leMainSymbol = "ZCMain_main" + , leRtsOptsEnabled = rtsOptsEnabled dflags + , leRtsOptsSuggestions = rtsOptsSuggestions dflags + , leKeepCafs = gopt Opt_KeepCAFs dflags + , leRtsOpts = rtsOpts dflags + } + +leHaveRtsOptsFlags :: ExecutableLinkOpts -> Bool +leHaveRtsOptsFlags opts = + isJust (leRtsOpts opts) + || case leRtsOptsEnabled opts of + RtsOptsSafeOnly -> False + _ -> True + +linkExecutable :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkExecutable logger tmpfs opts unit_env o_files dep_units = do + let static_link = False + let platform = ue_platform unit_env + unit_state = ue_homeUnitState unit_env + verbFlags = leVerbFlags opts + arch_os = platformArchOS platform + output_fn = exeFileName arch_os static_link (leOutputFile opts) + namever = leNameVersion opts + -- For the wasm target, when ghc is invoked with -dynamic, + -- when linking the final .wasm binary we must still ensure + -- the static archives are selected. Otherwise wasm-ld would + -- fail to find and link the .so library dependencies. wasm-ld + -- can link PIC objects into static .wasm binaries fine, so we + -- only adjust the ways in the final linking step, and only + -- when linking .wasm binary (which is supposed to be fully + -- static), not when linking .so shared libraries. + ways_ + | ArchWasm32 <- platformArch platform = removeWay WayDyn $ leWays opts + | otherwise = leWays opts + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d output_fn) + + -- 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. + pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) + let pkg_lib_paths = collectLibraryDirs ways_ pkgs + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget (platformOS platform) && + leDynLibLoader opts == SystemDependent && + ways_ `hasWay` WayDyn + = let libpath = if leRelativeDynlibPaths opts + then "$ORIGIN" + (l `makeRelativeTo` full_output_fn) + else l + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + rpath = if leUseXLinkerRPath opts + 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) && + leDynLibLoader opts == SystemDependent && + ways_ `hasWay` WayDyn && + leUseXLinkerRPath opts + = let libpath = if leRelativeDynlibPaths opts + 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 leSingleLibFolder opts + then do + libs <- getLibs namever ways_ unit_env dep_units + tmpDir <- newTempSubDir logger tmpfs (leTempDir opts) + sequence_ [ copyFile lib (tmpDir basename) + | (lib, basename) <- libs] + return [ "-L" ++ tmpDir ] + else pure pkg_lib_path_opts + + let + dead_strip + | leWholeArchiveHsLibs opts = [] + | otherwise = if osSubsectionsViaSymbols (platformOS platform) + then ["-Wl,-dead_strip"] + else [] + let lib_paths = leLibraryPaths opts + let lib_path_opts = map ("-L"++) lib_paths + + extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs opts unit_state + noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs opts unit_env dep_units + + let + (pre_hs_libs, post_hs_libs) + | leWholeArchiveHsLibs opts + = 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 + unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units + return $ otherFlags unit_link_opts ++ dead_strip + ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs + ++ extraLibs unit_link_opts + -- -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 unit_env dep_units + let framework_opts = getFrameworkOpts (leFrameworkOpts opts) platform + + -- probably _stub.o files + let extra_ld_inputs = leInputs opts + + rc_objs <- case platformOS platform of + OSMinGW32 | leGenManifest opts -> maybeCreateManifest logger tmpfs (leManifestOpts opts) output_fn + _ -> return [] + + let linker_config = leLinkerConfig opts + let args = ( map GHC.SysTools.Option verbFlags + ++ [ GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ++ libmLinkOpts platform + ++ map GHC.SysTools.Option ( + [] + + -- See Note [No PIE when linking] + ++ lePieOpts opts + + -- 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 not (leCompactUnwind opts) && + linkerSupportsCompactUnwind (leLinkerConfig opts) && + (platformOS platform == OSDarwin) && + case platformArch platform of + ArchX86_64 -> True + ArchAArch64 -> True + _ -> False + then ["-Wl,-no_compact_unwind"] + else []) + + -- We should rather be asking does it support --gc-sections? + ++ (if linkerIsGnuLd (leLinkerConfig opts) && + not (leWholeArchiveHsLibs opts) + 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 + -- See Note [RTS/ghc-internal interface] + -- (-u<sym> must come before -lghc-internal...!) + ++ (if ghcInternalUnitId `elem` map unitId pkgs + then [concat [ "-Wl,-u," + , ['_' | platformLeadingUnderscore platform] + , "init_ghc_hs_iface" ]] + else []) + ++ 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 []) + )) + + runLink logger tmpfs linker_config args + + -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 + when (platformOS platform == OSDarwin && leRPath opts) $ + GHC.Linker.MacOS.runInjectRPaths logger (leOtoolConfig opts) (leInstallNameConfig opts) pkg_lib_paths output_fn + +mkExtraObj :: Logger -> TmpFs -> TempDir -> CcConfig -> UnitState -> Suffix -> String -> IO FilePath +mkExtraObj logger tmpfs tmpdir cc_config unit_state extn xs + = do + -- 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. + let cOpts = map Option (ccPicOpts cc_config) + ++ map (FileOption "-I" . ST.unpack) + (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit) + cFile <- newTempName logger tmpfs tmpdir TFL_CurrentModule extn + oFile <- newTempName logger tmpfs tmpdir TFL_GhcSession "o" + writeFile cFile xs + runCc Nothing logger tmpfs tmpdir cc_config + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ if extn /= "s" + then cOpts + else []) + return oFile + +-- | Create object containing main() entry point +-- +-- 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) +mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitState -> IO (Maybe FilePath) +mkExtraObjToLinkIntoBinary logger tmpfs opts unit_state = do + when (leNoHsMain opts && leHaveRtsOptsFlags opts) $ + logInfo logger $ 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.") + + if leNoHsMain opts + -- Don't try to build the extra object if it is not needed. Compiling the + -- extra object assumes the presence of the RTS in the unit database + -- (because the extra object imports Rts.h) but GHC's build system may try + -- to build some helper programs before building and registering the RTS! + -- See #18938 for an example where hp2ps failed to build because of a failed + -- (unsafe) lookup for the RTS in the unit db. + then pure Nothing + else mk_extra_obj exeMain + + where + tmpdir = leTempDir opts + cc_config = leCcConfig opts + mk_extra_obj = fmap Just . mkExtraObj logger tmpfs tmpdir cc_config unit_state "c" . renderWithContext defaultSDocContext + + exeMain = vcat [ + text "#include ", + text "extern StgClosure " <> text (leMainSymbol opts) <> text "_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (leRtsOptsEnabled opts)) <> semi, + text " __conf.rts_opts_suggestions = " + <> (if leRtsOptsSuggestions opts + then text "true" + else text "false") <> semi, + text "__conf.keep_cafs = " + <> (if leKeepCafs opts + then text "true" + else text "false") <> semi, + case leRtsOpts opts of + Nothing -> Outputable.empty + Just rts_opts -> text " __conf.rts_opts= " <> + text (show rts_opts) <> semi, + text " __conf.rts_hs_main = true;", + text " return hs_main(argc,argv,&" <> text (leMainSymbol opts) <> text "_closure,__conf);", + char '}', + 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 :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary logger tmpfs opts unit_env dep_packages = do + link_info <- initLinkInfo opts unit_env dep_packages + + if (platformSupportsSavingLinkOpts (platformOS platform )) + then fmap (:[]) $ mkExtraObj logger tmpfs tmpdir cc_config unit_state "s" (renderWithContext defaultSDocContext (link_opts link_info)) + else return [] + + where + unit_state = ue_homeUnitState unit_env + platform = ue_platform unit_env + tmpdir = leTempDir opts + cc_config = leCcConfig opts + link_opts info = hcat + [ -- "link info" section (see Note [LinkInfo section]) + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 (show 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 + ] + +data LinkInfo = LinkInfo + { liPkgLinkOpts :: UnitLinkOpts + , liPkgFrameworks :: [String] + , liRtsOpts :: Maybe String + , liRtsOptsEnabled :: !RtsOptsEnabled + , liNoHsMain :: !Bool + , liLdInputs :: [String] + , liLdOpts :: [String] + } + deriving (Show) + + +-- | Return the "link info" +-- +-- See Note [LinkInfo section] +initLinkInfo :: ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO LinkInfo +initLinkInfo opts unit_env dep_packages = do + package_link_opts <- getUnitLinkOpts (leNameVersion opts) (leWays opts) unit_env dep_packages + pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) + then return [] + else do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) + return (collectFrameworks ps) + pure $ LinkInfo + { liPkgLinkOpts = package_link_opts + , liPkgFrameworks = pkg_frameworks + , liRtsOpts = leRtsOpts opts + , liRtsOptsEnabled = leRtsOptsEnabled opts + , liNoHsMain = leNoHsMain opts + , liLdInputs = map showOpt (leInputs opts) + , liLdOpts = map showOpt (linkerOptionsPost (leLinkerConfig opts)) + } + +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 :: Logger -> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo logger opts unit_env pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = 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 <- initLinkInfo opts unit_env pkg_deps + debugTraceMsg logger 3 $ text ("Link info: " ++ show link_info) + m_exe_link_info <- readElfNoteAsString logger exe_file + ghcLinkInfoSectionName ghcLinkInfoNoteName + let sameLinkInfo = (Just (show link_info) == m_exe_link_info) + debugTraceMsg logger 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). + +-} + +{- +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. +-} + ===================================== compiler/GHC/Linker/ExtraObj.hs deleted ===================================== @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHC Extra object linking code --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ - -module GHC.Linker.ExtraObj - ( mkExtraObj - , mkExtraObjToLinkIntoBinary - , mkNoteObjsToLinkIntoBinary - , checkLinkInfo - , getLinkInfo - , ghcLinkInfoSectionName - , ghcLinkInfoNoteName - , platformSupportsSavingLinkOpts - , haveRtsOptsFlags - ) -where - -import GHC.Prelude -import GHC.Platform - -import GHC.Unit -import GHC.Unit.Env - -import GHC.Utils.Asm -import GHC.Utils.Error -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Logger -import GHC.Utils.TmpFs - -import GHC.Driver.Session -import GHC.Driver.Ppr - -import qualified GHC.Data.ShortText as ST - -import GHC.SysTools.Elf -import GHC.SysTools.Tasks -import GHC.Linker.Unit - -import Control.Monad -import Data.Maybe - -mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath -mkExtraObj logger tmpfs dflags unit_state extn xs - = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn - oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o" - writeFile cFile xs - runCc Nothing logger tmpfs dflags - ([Option "-c", - FileOption "" cFile, - Option "-o", - FileOption "" oFile] - ++ if extn /= "s" - then cOpts - else []) - return oFile - where - -- 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 unit_state rtsUnit) - --- 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 :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) -mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ - logInfo logger $ 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.") - - case ghcLink dflags of - -- Don't try to build the extra object if it is not needed. Compiling the - -- extra object assumes the presence of the RTS in the unit database - -- (because the extra object imports Rts.h) but GHC's build system may try - -- to build some helper programs before building and registering the RTS! - -- See #18938 for an example where hp2ps failed to build because of a failed - -- (unsafe) lookup for the RTS in the unit db. - _ | gopt Opt_NoHsMain dflags - -> return Nothing - - LinkDynLib - | OSMinGW32 <- platformOS (targetPlatform dflags) - -> mk_extra_obj dllMain - - | otherwise - -> return Nothing - - _ -> mk_extra_obj exeMain - - where - mk_extra_obj = fmap Just . mkExtraObj logger tmpfs dflags unit_state "c" . showSDoc dflags - - 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 = " - <> (if rtsOptsSuggestions dflags - then text "true" - else text "false") <> semi, - text "__conf.keep_cafs = " - <> (if gopt Opt_KeepCAFs dflags - then text "true" - else text "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 :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_packages = do - link_info <- getLinkInfo dflags unit_env dep_packages - - if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info)) - else return [] - - where - unit_state = ue_homeUnitState unit_env - platform = ue_platform unit_env - link_opts info = hcat - [ -- "link info" section (see Note [LinkInfo section]) - makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info - - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- "GHC.CmmToAsm" for another instance - -- where we need to do this. - , if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," - <> sectionType platform "progbits" <> char '\n' - else Outputable.empty - ] - --- | Return the "link info" string --- --- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String -getLinkInfo dflags unit_env dep_packages = do - package_link_opts <- getUnitLinkOpts (ghcNameVersion dflags) (ways dflags) unit_env dep_packages - pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) - then return [] - else do - ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) - return (collectFrameworks ps) - let link_info = - ( package_link_opts - , pkg_frameworks - , rtsOpts dflags - , rtsOptsEnabled dflags - , gopt Opt_NoHsMain dflags - , map showOpt (ldInputs dflags) - , getOpts dflags opt_l - ) - return (show link_info) - -platformSupportsSavingLinkOpts :: OS -> Bool -platformSupportsSavingLinkOpts os - | 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 :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool -checkLinkInfo logger dflags unit_env pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) - -- ToDo: Windows and OS X do not use the ELF binary format, so - -- readelf does not work there. We need to find another way to do - -- this. - = 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 unit_env pkg_deps - debugTraceMsg logger 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString logger exe_file - ghcLinkInfoSectionName ghcLinkInfoNoteName - let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg logger 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 ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -406,6 +406,7 @@ loadCmdLineLibs'' interp hsc_env pls = , libraryPaths = lib_paths_base}) = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let ld_config = configureLd dflags -- (c) Link libraries from the command-line let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] @@ -421,7 +422,7 @@ loadCmdLineLibs'' interp hsc_env pls = OSMinGW32 -> "pthread" : minus_ls_1 _ -> minus_ls_1 -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths logger dflags os + gcc_paths <- getGCCPaths logger platform ld_config lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base @@ -1254,6 +1255,7 @@ loadPackage interp hsc_env pkgs = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + ld_config = configureLd dflags platform = targetPlatform dflags is_dyn = interpreterDynamic interp dirs | is_dyn = [map ST.unpack $ Packages.unitLibraryDynDirs pkg | pkg <- pkgs] @@ -1281,7 +1283,7 @@ loadPackage interp hsc_env pkgs extra_libs = zipWith (++) extdeplibs linkerlibs -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths logger dflags (platformOS platform) + gcc_paths <- getGCCPaths logger platform ld_config dirs_env <- traverse (addEnvPaths "LIBRARY_PATH") dirs hs_classifieds @@ -1507,6 +1509,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env diag_opts = initDiagOpts dflags + ld_config = configureLd dflags dirs = lib_dirs ++ gcc_dirs gcc = False user = True @@ -1570,7 +1573,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary interp so_name #endif - tryGcc = let search = searchForLibUsingGcc logger dflags + tryGcc = let search = searchForLibUsingGcc logger ld_config #if defined(CAN_LOAD_DLL) dllpath = liftM (fmap DLLPath) short = dllpath $ search so_name lib_dirs @@ -1624,11 +1627,11 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 #endif os = platformOS platform -searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) -searchForLibUsingGcc logger dflags so dirs = do +searchForLibUsingGcc :: Logger -> LdConfig -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc logger ld_config 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 logger dflags (map (FileOption "-B") dirs + str <- askLd logger ld_config (map (FileOption "-B") dirs ++ [Option "--print-file-name", Option so]) let file = case lines str of [] -> "" @@ -1640,10 +1643,10 @@ searchForLibUsingGcc logger dflags so dirs = do -- | Retrieve the list of search directory GCC and the System use to find -- libraries and components. See Note [Fork/Exec Windows]. -getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath] -getGCCPaths logger dflags os - | os == OSMinGW32 || platformArch (targetPlatform dflags) == ArchWasm32 = - do gcc_dirs <- getGccSearchDirectory logger dflags "libraries" +getGCCPaths :: Logger -> Platform -> LdConfig -> IO [FilePath] +getGCCPaths logger platform ld_config + | platformOS platform == OSMinGW32 || platformArch platform == ArchWasm32 = + do gcc_dirs <- getGccSearchDirectory logger ld_config "libraries" sys_dirs <- getSystemDirectories return $ nub $ gcc_dirs ++ sys_dirs | otherwise = return [] @@ -1663,8 +1666,8 @@ gccSearchDirCache = unsafePerformIO $ newIORef [] -- which hopefully is written in an optimized manner 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 :: Logger -> DynFlags -> String -> IO [FilePath] -getGccSearchDirectory logger dflags key = do +getGccSearchDirectory :: Logger -> LdConfig -> String -> IO [FilePath] +getGccSearchDirectory logger ld_config key = do #if defined(wasm32_HOST_ARCH) pure [] #else @@ -1672,7 +1675,7 @@ getGccSearchDirectory logger dflags key = do case lookup key cache of Just x -> return x Nothing -> do - str <- askLd logger dflags [Option "--print-search-dirs"] + str <- askLd logger ld_config [Option "--print-search-dirs"] let line = dropWhile isSpace str name = key ++ ": =" if null line ===================================== compiler/GHC/Linker/MacOS.hs ===================================== @@ -17,7 +17,6 @@ import GHC.Unit.Types import GHC.Unit.State import GHC.Unit.Env -import GHC.Settings import GHC.SysTools.Tasks import GHC.Runtime.Interpreter @@ -49,13 +48,13 @@ import Text.ParserCombinators.ReadP as Parser -- dynamic library through @-add_rpath@. -- -- See Note [Dynamic linking on macOS] -runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO () -runInjectRPaths logger toolSettings lib_paths dylib = do - info <- lines <$> askOtool logger toolSettings Nothing [Option "-L", Option dylib] +runInjectRPaths :: Logger -> OtoolConfig -> InstallNameConfig -> [FilePath] -> FilePath -> IO () +runInjectRPaths logger otool_opts install_name_opts lib_paths dylib = do + info <- lines <$> askOtool logger otool_opts 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 <- lines <$> askOtool logger toolSettings Nothing [Option "-l", Option dylib] + info <- lines <$> askOtool logger otool_opts Nothing [Option "-l", Option dylib] let paths = mapMaybe get_rpath info lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ] -- only find those rpaths, that aren't already in the library. @@ -63,7 +62,7 @@ runInjectRPaths logger toolSettings lib_paths dylib = do -- inject the rpaths case rpaths of [] -> return () - _ -> runInstallNameTool logger toolSettings $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] + _ -> runInstallNameTool logger install_name_opts $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] get_rpath :: String -> Maybe FilePath get_rpath l = case readP_to_S rpath_parser l of ===================================== compiler/GHC/Linker/Static.hs ===================================== @@ -1,12 +1,10 @@ module GHC.Linker.Static - ( linkBinary - , linkStaticLib + ( linkStaticLib ) where import GHC.Prelude import GHC.Platform -import GHC.Platform.Ways import GHC.Settings import GHC.SysTools @@ -19,24 +17,15 @@ import GHC.Unit.State import GHC.Utils.Logger import GHC.Utils.Monad -import GHC.Utils.Misc -import GHC.Utils.TmpFs -import GHC.Linker.MacOS import GHC.Linker.Unit -import GHC.Linker.Dynamic -import GHC.Linker.ExtraObj -import GHC.Linker.External -import GHC.Linker.Windows import GHC.Linker.Static.Utils -import GHC.Driver.Config.Linker import GHC.Driver.Session import System.FilePath import System.Directory import Control.Monad -import Data.Maybe ----------------------------------------------------------------------------- -- Static linking, of .o files @@ -51,225 +40,6 @@ import Data.Maybe -- 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 :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary = linkBinary' False - -linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do - let platform = ue_platform unit_env - unit_state = ue_homeUnitState unit_env - toolSettings' = toolSettings dflags - verbFlags = getVerbFlags dflags - arch_os = platformArchOS platform - output_fn = exeFileName arch_os staticLink (outputFile_ dflags) - namever = ghcNameVersion dflags - -- For the wasm target, when ghc is invoked with -dynamic, - -- when linking the final .wasm binary we must still ensure - -- the static archives are selected. Otherwise wasm-ld would - -- fail to find and link the .so library dependencies. wasm-ld - -- can link PIC objects into static .wasm binaries fine, so we - -- only adjust the ways in the final linking step, and only - -- when linking .wasm binary (which is supposed to be fully - -- static), not when linking .so shared libraries. - ways_ - | ArchWasm32 <- platformArch platform = removeWay WayDyn $ targetWays_ dflags - | otherwise = ways dflags - - full_output_fn <- if isAbsolute output_fn - then return output_fn - else do d <- getCurrentDirectory - return $ normalise (d output_fn) - - -- 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. - pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) - let pkg_lib_paths = collectLibraryDirs ways_ pkgs - 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 && - ways_ `hasWay` WayDyn - = 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 useXLinkerRPath dflags (platformOS platform) - 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 && - ways_ `hasWay` WayDyn && - useXLinkerRPath dflags (platformOS platform) - = 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 namever ways_ unit_env dep_units - tmpDir <- newTempSubDir logger tmpfs (tmpDir 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 <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state - noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env 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 - unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units - return $ otherFlags unit_link_opts ++ dead_strip - ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs - ++ extraLibs unit_link_opts - -- -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 unit_env dep_units - let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform - - -- probably _stub.o files - let extra_ld_inputs = ldInputs dflags - - rc_objs <- case platformOS platform of - OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn - _ -> return [] - - let linker_config = initLinkerConfig dflags - let link dflags args = do - runLink logger tmpfs linker_config args - -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 - when (platformOS platform == OSDarwin && gopt Opt_RPath dflags) $ - GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn - - link dflags ( - map GHC.SysTools.Option verbFlags - ++ [ GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ] - ++ libmLinkOpts platform - ++ map GHC.SysTools.Option ( - [] - - -- See Note [No PIE when linking] - ++ pieCCLDOpts 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 not (gopt Opt_CompactUnwind dflags) && - toolSettings_ldSupportsCompactUnwind toolSettings' && - (platformOS platform == OSDarwin) && - case platformArch platform of - ArchX86_64 -> True - ArchAArch64 -> True - _ -> False - then ["-Wl,-no_compact_unwind"] - else []) - - -- We should rather be asking does it support --gc-sections? - ++ (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 - -- See Note [RTS/ghc-internal interface] - -- (-u<sym> must come before -lghc-internal...!) - ++ (if ghcInternalUnitId `elem` map unitId pkgs - then [concat [ "-Wl,-u," - , ['_' | platformLeadingUnderscore platform] - , "init_ghc_hs_iface" ]] - else []) - ++ 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. @@ -309,4 +79,5 @@ linkStaticLib logger dflags unit_env o_files dep_units = do else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar -- run ranlib over the archive. write*Ar does *not* create the symbol index. - runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn] + let ranlib_opts = configureRanlib dflags + runRanlib logger ranlib_opts [GHC.SysTools.FileOption "" output_fn] ===================================== compiler/GHC/Linker/Windows.hs ===================================== @@ -1,5 +1,7 @@ module GHC.Linker.Windows - ( maybeCreateManifest + ( ManifestOpts (..) + , initManifestOpts + , maybeCreateManifest ) where @@ -12,13 +14,28 @@ import GHC.Utils.Logger import System.FilePath import System.Directory +data ManifestOpts = ManifestOpts + { manifestEmbed :: !Bool -- ^ Should the manifest be embedded in the binary with Windres + , manifestTempdir :: TempDir + , manifestWindresConfig :: WindresConfig + , manifestObjectSuf :: String + } + +initManifestOpts :: DynFlags -> ManifestOpts +initManifestOpts dflags = ManifestOpts + { manifestEmbed = gopt Opt_EmbedManifest dflags + , manifestTempdir = tmpDir dflags + , manifestWindresConfig = configureWindres dflags + , manifestObjectSuf = objectSuf dflags + } + maybeCreateManifest :: Logger -> TmpFs - -> DynFlags + -> ManifestOpts -> FilePath -- ^ filename of executable -> IO [FilePath] -- ^ extra objects to embed, maybe -maybeCreateManifest logger tmpfs dflags exe_filename = do +maybeCreateManifest logger tmpfs opts exe_filename = do let manifest_filename = exe_filename <.> "manifest" manifest = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ @@ -42,18 +59,18 @@ maybeCreateManifest logger tmpfs dflags exe_filename = do -- 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) + if not (manifestEmbed opts) then return [] else do - rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc" + rc_filename <- newTempName logger tmpfs (manifestTempdir opts) TFL_CurrentModule "rc" rc_obj_filename <- - newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags) + newTempName logger tmpfs (manifestTempdir opts) TFL_GhcSession (manifestObjectSuf opts) writeFile rc_filename $ "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n" -- magic numbers :-) - runWindres logger dflags $ map GHC.SysTools.Option $ + runWindres logger (manifestWindresConfig opts) $ map GHC.SysTools.Option $ ["--input="++rc_filename, "--output="++rc_obj_filename, "--output-format=coff"] ===================================== compiler/GHC/Runtime/Interpreter/C.hs ===================================== @@ -0,0 +1,85 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | External interpreter program +module GHC.Runtime.Interpreter.C + ( generateIservC + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Data.FastString +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Unit.Types +import GHC.Unit.Env +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Utils.Panic.Plain +import GHC.Linker.Executable +import GHC.Linker.Config +import GHC.Utils.CliOption + +-- | Generate iserv program for the target +generateIservC :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> IO FilePath +generateIservC logger tmpfs opts unit_env = do + -- get the unit-id of the ghci package. We need this to load the + -- interpreter code. + let unit_state = ue_homeUnitState unit_env + ghci_unit_id <- case lookupPackageName unit_state (PackageName (fsLit "ghci")) of + Nothing -> cmdLineErrorIO "C interpreter: couldn't find \"ghci\" package" + Just i -> pure i + + -- generate a temporary name for the iserv program + let tmpdir = leTempDir opts + exe_file <- newTempName logger tmpfs tmpdir TFL_GhcSession "iserv" + + let platform = ue_platform unit_env + let os = platformOS platform + + -- we inherit ExecutableLinkOpts for the target code (i.e. derived from + -- DynFlags specified by the user and from settings). We need to adjust these + -- options to generate the iserv program we want. Some settings are to be + -- shared (e.g. ways, platform, etc.) but some other must be set specifically + -- for iserv. + let opts' = opts + { -- write iserv program in some temporary directory + leOutputFile = Just exe_file + + -- we need GHC to generate a main entry point... + , leNoHsMain = False + + -- ...however the main symbol must be the iserv server + , leMainSymbol = zString (zEncodeFS (unitIdFS ghci_unit_id)) ++ "_GHCiziServer_defaultServer" + + -- we need to reset inputs, otherwise one of them may be defining + -- `main` too (with -no-hs-main). + , leInputs = [] + + -- we never know what symbols GHC will look up in the future, so we + -- must retain CAFs for running interpreted code. + , leKeepCafs = True + + -- enable all rts options + , leRtsOptsEnabled = RtsOptsAll + + -- Add -Wl,--export-dynamic enables GHCi to load dynamic objects that + -- refer to the RTS. This is harmless if you don't use it (adds a bit + -- of overhead to startup and increases the binary sizes) but if you + -- need it there's no alternative. + -- + -- The Solaris linker does not support --export-dynamic option. It also + -- does not need it since it exports all dynamic symbols by default + , leLinkerConfig = if + | osElfTarget os + , os /= OSFreeBSD + , os /= OSSolaris2 + -> (leLinkerConfig opts) + { linkerOptionsPost = linkerOptionsPost (leLinkerConfig opts) ++ [Option "-Wl,--export-dynamic"] + } + | otherwise + -> leLinkerConfig opts + } + linkExecutable logger tmpfs opts' unit_env [] [ghci_unit_id] + + pure exe_file ===================================== compiler/GHC/Runtime/Interpreter/Init.hs ===================================== @@ -0,0 +1,162 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Runtime.Interpreter.Init + ( initInterpreter + , InterpOpts (..) + ) +where + + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways +import GHC.Settings +import GHC.Unit.Finder +import GHC.Unit.Env +import GHC.Utils.TmpFs +import GHC.SysTools.Tasks + +import GHC.Linker.Executable +import qualified GHC.Linker.Loader as Loader +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.C +import GHC.StgToJS.Types (StgToJSConfig) + +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.Utils.Error +import Control.Concurrent +import System.Process + +data InterpOpts = InterpOpts + { interpExternal :: !Bool + , interpProg :: String + , interpOpts :: [String] + , interpWays :: Ways + , interpNameVer :: GhcNameVersion + , interpLdConfig :: LdConfig + , interpCcConfig :: CcConfig + , interpJsInterp :: FilePath + , interpTmpDir :: TempDir + , interpFinderOpts :: FinderOpts + , interpJsCodegenCfg :: StgToJSConfig + , interpVerbosity :: Int + , interpCreateProcess :: Maybe (CreateProcess -> IO ProcessHandle) -- create iserv process hook + , interpWasmDyld :: FilePath + , interpBrowser :: Bool + , interpBrowserHost :: String + , interpBrowserPort :: Int + , interpBrowserRedirectWasiConsole :: Bool + , interpBrowserPuppeteerLaunchOpts :: Maybe String + , interpBrowserPlaywrightBrowserType :: Maybe String + , interpBrowserPlaywrightLaunchOpts :: Maybe String + , interpExecutableLinkOpts :: ExecutableLinkOpts + } + +-- | Initialize code interpreter +initInterpreter + :: TmpFs + -> Logger + -> Platform + -> FinderCache + -> UnitEnv + -> InterpOpts + -> IO (Maybe Interp) +initInterpreter tmpfs logger platform finder_cache unit_env opts = do + + lookup_cache <- liftIO $ mkInterpSymbolCache + + -- see Note [Target code interpreter] + if +#if !defined(wasm32_HOST_ARCH) + -- Wasm dynamic linker + | ArchWasm32 <- platformArch platform + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger (interpLdConfig opts) "libraries" + let profiled = interpWays opts `hasWay` WayProf + way_tag = if profiled then "_p" else "" + let cfg = + WasmInterpConfig + { wasmInterpDyLD = interpWasmDyld opts + , wasmInterpLibDir = libdir + , wasmInterpOpts = interpOpts opts + , wasmInterpBrowser = interpBrowser opts + , wasmInterpBrowserHost = interpBrowserHost opts + , wasmInterpBrowserPort = interpBrowserPort opts + , wasmInterpBrowserRedirectWasiConsole = interpBrowserRedirectWasiConsole opts + , wasmInterpBrowserPuppeteerLaunchOpts = interpBrowserPuppeteerLaunchOpts opts + , wasmInterpBrowserPlaywrightBrowserType = interpBrowserPlaywrightBrowserType opts + , wasmInterpBrowserPlaywrightLaunchOpts = interpBrowserPlaywrightLaunchOpts opts + , wasmInterpTargetPlatform = platform + , wasmInterpProfiled = profiled + , wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (interpNameVer opts) + , wasmInterpUnitState = ue_homeUnitState unit_env + } + pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache +#endif + + -- JavaScript interpreter + | ArchJavaScript <- platformArch platform + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + let cfg = JSInterpConfig + { jsInterpNodeConfig = defaultNodeJsSettings + , jsInterpScript = interpJsInterp opts + , jsInterpTmpFs = tmpfs + , jsInterpTmpDir = interpTmpDir opts + , jsInterpLogger = logger + , jsInterpCodegenCfg = interpJsCodegenCfg opts + , jsInterpUnitEnv = unit_env + , jsInterpFinderOpts = interpFinderOpts opts + , jsInterpFinderCache = finder_cache + } + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) + + -- external interpreter + | interpExternal opts + -> do + let + profiled = interpWays opts `hasWay` WayProf + dynamic = interpWays opts `hasWay` WayDyn + prog <- case interpProg opts of + -- build iserv program if none specified + "" -> generateIservC logger tmpfs (interpExecutableLinkOpts opts) unit_env + _ -> pure (interpProg opts ++ flavour) + where + flavour + | profiled && dynamic = "-prof-dyn" + | profiled = "-prof" + | dynamic = "-dyn" + | otherwise = "" + let msg = text "Starting " <> text prog + tr <- if interpVerbosity opts >= 3 + then return (logInfo logger $ withPprStyle defaultDumpStyle msg) + else return (pure ()) + let + conf = IServConfig + { iservConfProgram = prog + , iservConfOpts = interpOpts opts + , iservConfProfiled = profiled + , iservConfDynamic = dynamic + , iservConfHook = interpCreateProcess opts + , iservConfTrace = tr + } + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) + + -- Internal interpreter + | otherwise + -> +#if defined(HAVE_INTERNAL_INTERPRETER) + do + loader <- liftIO Loader.uninitializedLoader + return (Just (Interp InternalInterp loader lookup_cache)) +#else + return Nothing +#endif ===================================== compiler/GHC/SysTools/Tasks.hs ===================================== @@ -13,7 +13,11 @@ module GHC.SysTools.Tasks , runSourceCodePreprocessor , runPp , runCc + , configureCc + , CcConfig (..) + , configureLd , askLd + , LdConfig(..) , runAs , runLlvmOpt , runLlvmLlc @@ -22,10 +26,20 @@ module GHC.SysTools.Tasks , figureLlvmVersion , runMergeObjects , runAr + , ArConfig (..) + , configureAr , askOtool + , configureOtool + , OtoolConfig (..) , runInstallNameTool + , InstallNameConfig (..) + , configureInstallName , runRanlib + , RanlibConfig (..) + , configureRanlib , runWindres + , WindresConfig (..) + , configureWindres ) where import GHC.Prelude @@ -207,15 +221,32 @@ runPp logger dflags args = traceSystoolCommand logger "pp" $ do opts = map Option (getOpts dflags opt_F) runSomething logger "Haskell pre-processor" prog (args ++ opts) +data CcConfig = CcConfig + { ccProg :: String + , cxxProg :: String + , ccOpts :: [String] + , cxxOpts :: [String] + , ccPicOpts :: [String] + } + +configureCc :: DynFlags -> CcConfig +configureCc dflags = CcConfig + { ccProg = pgm_c dflags + , cxxProg = pgm_cxx dflags + , ccOpts = getOpts dflags opt_c + , cxxOpts = getOpts dflags opt_cxx + , ccPicOpts = picCCOpts dflags + } + -- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do +runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> TempDir -> CcConfig -> [Option] -> IO () +runCc mLanguage logger tmpfs tmpdir opts args = traceSystoolCommand logger "cc" $ do let args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 -- We take care to pass -optc flags in args1 last to ensure that the -- user can override flags passed by GHC. See #14452. mb_env <- getGccEnv args2 - runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter dbgstring prog args2 + runSomethingResponseFile logger tmpfs tmpdir cc_filter dbgstring prog args2 mb_env where -- force the C compiler to interpret this file as C when @@ -223,38 +254,49 @@ runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do -- Also useful for plain .c files, just in case GHC saw a -- -x c option. (languageOptions, userOpts, prog, dbgstring) = case mLanguage of - Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler") - Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr) + Nothing -> ([], ccOpts opts, ccProg opts, "C Compiler") + Just language -> ([Option "-x", Option languageName], copts, prog, dbgstr) where - (languageName, opts, prog, dbgstr) = case language of - LangC -> ("c", userOpts_c - ,pgm_c dflags, "C Compiler") - LangCxx -> ("c++", userOpts_cxx - ,pgm_cxx dflags , "C++ Compiler") - LangObjc -> ("objective-c", userOpts_c - ,pgm_c dflags , "Objective C Compiler") - LangObjcxx -> ("objective-c++", userOpts_cxx - ,pgm_cxx dflags, "Objective C++ Compiler") + (languageName, copts, prog, dbgstr) = case language of + LangC -> ("c", ccOpts opts + ,ccProg opts, "C Compiler") + LangCxx -> ("c++", cxxOpts opts + ,cxxProg opts, "C++ Compiler") + LangObjc -> ("objective-c", ccOpts opts + ,ccProg opts, "Objective C Compiler") + LangObjcxx -> ("objective-c++", cxxOpts opts + ,cxxProg opts, "Objective C++ Compiler") LangAsm -> ("assembler", [] - ,pgm_c dflags, "Asm Compiler") + ,ccProg opts, "Asm Compiler") RawObject -> ("c", [] - ,pgm_c dflags, "C Compiler") -- claim C for lack of a better idea + ,ccProg opts, "C Compiler") -- claim C for lack of a better idea --JS backend shouldn't reach here, so we just pass -- strings to satisfy the totality checker LangJs -> ("js", [] - ,pgm_c dflags, "JS Backend Compiler") - userOpts_c = getOpts dflags opt_c - userOpts_cxx = getOpts dflags opt_cxx + ,ccProg opts, "JS Backend Compiler") isContainedIn :: String -> String -> Bool xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) --- | Run the linker with some arguments and return the output -askLd :: Logger -> DynFlags -> [Option] -> IO String -askLd logger dflags args = traceSystoolCommand logger "linker" $ do +data LdConfig = LdConfig + { ldProg :: String -- ^ LD program path + , ldOpts :: [Option] -- ^ LD program arguments + } + +configureLd :: DynFlags -> LdConfig +configureLd dflags = let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 ++ args + in LdConfig + { ldProg = p + , ldOpts = args0 ++ args1 + } + +-- | Run the linker with some arguments and return the output +askLd :: Logger -> LdConfig -> [Option] -> IO String +askLd logger ld_config args = traceSystoolCommand logger "linker" $ do + let p = ldProg ld_config + args2 = ldOpts ld_config ++ args mb_env <- getGccEnv args2 runSomethingWith logger "gcc" p args2 $ \real_args -> readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } @@ -373,31 +415,80 @@ runMergeObjects logger tmpfs dflags args = else do runSomething logger "Merge objects" p args2 -runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do - let ar = pgm_ar dflags +newtype ArConfig = ArConfig + { arProg :: String + } + +configureAr :: DynFlags -> ArConfig +configureAr dflags = ArConfig + { arProg = pgm_ar dflags + } + +runAr :: Logger -> ArConfig -> Maybe FilePath -> [Option] -> IO () +runAr logger opts cwd args = traceSystoolCommand logger "ar" $ do + let ar = arProg opts runSomethingFiltered logger id "Ar" ar args cwd Nothing -askOtool :: Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO String -askOtool logger toolSettings mb_cwd args = do - let otool = toolSettings_pgm_otool toolSettings +newtype OtoolConfig = OtoolConfig + { otoolProg :: String + } + +configureOtool :: DynFlags -> OtoolConfig +configureOtool dflags = OtoolConfig + { otoolProg = toolSettings_pgm_otool (toolSettings dflags) + } + +askOtool :: Logger -> OtoolConfig -> Maybe FilePath -> [Option] -> IO String +askOtool logger opts mb_cwd args = do + let otool = otoolProg opts runSomethingWith logger "otool" otool args $ \real_args -> readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } -runInstallNameTool :: Logger -> ToolSettings -> [Option] -> IO () -runInstallNameTool logger toolSettings args = do - let tool = toolSettings_pgm_install_name_tool toolSettings +newtype InstallNameConfig = InstallNameConfig + { installNameProg :: String + } + +configureInstallName :: DynFlags -> InstallNameConfig +configureInstallName dflags = InstallNameConfig + { installNameProg = toolSettings_pgm_install_name_tool (toolSettings dflags) + } + +runInstallNameTool :: Logger -> InstallNameConfig -> [Option] -> IO () +runInstallNameTool logger opts args = do + let tool = installNameProg opts runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing -runRanlib :: Logger -> DynFlags -> [Option] -> IO () -runRanlib logger dflags args = traceSystoolCommand logger "ranlib" $ do - let ranlib = pgm_ranlib dflags +newtype RanlibConfig = RanlibConfig + { ranlibProg :: String + } + +configureRanlib :: DynFlags -> RanlibConfig +configureRanlib dflags = RanlibConfig + { ranlibProg = pgm_ranlib dflags + } + +runRanlib :: Logger -> RanlibConfig -> [Option] -> IO () +runRanlib logger opts args = traceSystoolCommand logger "ranlib" $ do + let ranlib = ranlibProg opts runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing -runWindres :: Logger -> DynFlags -> [Option] -> IO () -runWindres logger dflags args = traceSystoolCommand logger "windres" $ do - let cc_args = map Option (sOpt_c (settings dflags)) - windres = pgm_windres dflags - opts = map Option (getOpts dflags opt_windres) +data WindresConfig = WindresConfig + { windresProg :: String + , windresOpts :: [Option] + , windresCOpts :: [Option] + } + +configureWindres :: DynFlags -> WindresConfig +configureWindres dflags = WindresConfig + { windresProg = pgm_windres dflags + , windresOpts = map Option (getOpts dflags opt_windres) + , windresCOpts = map Option (sOpt_c (settings dflags)) + } + +runWindres :: Logger -> WindresConfig -> [Option] -> IO () +runWindres logger opts args = traceSystoolCommand logger "windres" $ do + let cc_args = windresCOpts opts + windres = windresProg opts + wopts = windresOpts opts mb_env <- getGccEnv cc_args - runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env + runSomethingFiltered logger id "Windres" windres (wopts ++ args) Nothing mb_env ===================================== compiler/ghc.cabal.in ===================================== @@ -515,6 +515,7 @@ Library GHC.Driver.Config.HsToCore GHC.Driver.Config.HsToCore.Ticks GHC.Driver.Config.HsToCore.Usage + GHC.Driver.Config.Interpreter GHC.Driver.Config.Linker GHC.Driver.Config.Logger GHC.Driver.Config.Parser @@ -650,7 +651,7 @@ Library GHC.Linker.Deps GHC.Linker.Dynamic GHC.Linker.External - GHC.Linker.ExtraObj + GHC.Linker.Executable GHC.Linker.Loader GHC.Linker.MacOS GHC.Linker.Static @@ -723,6 +724,8 @@ Library GHC.Runtime.Heap.Inspect GHC.Runtime.Heap.Layout GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.C + GHC.Runtime.Interpreter.Init GHC.Runtime.Interpreter.JS GHC.Runtime.Interpreter.Process GHC.Runtime.Interpreter.Types ===================================== testsuite/tests/bytecode/T23973.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LinearTypes #-} + +module Main (main) where + +data Ur a where + Ur :: a -> Ur a + +unur :: Ur a -> a +unur (Ur a) = a + +segvGHCi :: Ur () +segvGHCi = Ur $ () + +main :: IO () +main = print (unur segvGHCi) + ===================================== testsuite/tests/bytecode/T23973.script ===================================== @@ -0,0 +1,2 @@ +:l T23973.hs +main ===================================== testsuite/tests/bytecode/T23973.stdout ===================================== @@ -0,0 +1 @@ +() ===================================== testsuite/tests/bytecode/T26565.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes #-} +module Test where + +data Ur a where + Ur :: a -> Ur a + ===================================== testsuite/tests/bytecode/T26565.script ===================================== @@ -0,0 +1,3 @@ +:l T26565 +Ur y = (\x -> Ur $ replicate 5 'a') 3 +y ===================================== testsuite/tests/bytecode/T26565.stdout ===================================== @@ -0,0 +1 @@ +"aaaaa" ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -6,6 +6,8 @@ test('T25975', extra_ways(ghci_ways), compile_and_run, # Some of the examples work more robustly with these flags ['-fno-break-points -fno-full-laziness']) +test('T26565', extra_files(["T26565.hs"]), ghci_script, ['T26565.script']) +test('T23973', extra_files(["T23973.hs"]), ghci_script, ['T23973.script']) + # Nullary data constructors test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) - ===================================== testsuite/tests/driver/T24731.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module T24731 where + +foo :: Int +foo = $([|10|]) ===================================== testsuite/tests/driver/all.T ===================================== @@ -333,3 +333,4 @@ test('T25382', normal, makefile_test, []) test('T26018', req_c, makefile_test, []) test('T24120', normal, compile, ['-Wunused-packages -hide-all-packages -package base -package system-cxx-std-lib']) test('T26551', [extra_files(['T26551.hs'])], makefile_test, []) +test('T24731', [only_ways(['ext-interp'])], compile, ['-fexternal-interpreter -pgmi ""']) ===================================== utils/iserv/iserv.cabal.in ===================================== @@ -30,15 +30,6 @@ Executable iserv C-Sources: cbits/iservmain.c Hs-Source-Dirs: src include-dirs: . - Build-Depends: array >= 0.5 && < 0.6, - base >= 4 && < 5, - binary >= 0.7 && < 0.11, - bytestring >= 0.10 && < 0.13, - containers >= 0.5 && < 0.9, - deepseq >= 1.4 && < 1.6, - ghci == @ProjectVersionMunged@ - - if os(windows) - Cpp-Options: -DWINDOWS - else - Build-Depends: unix >= 2.7 && < 2.9 + Build-Depends: + base >= 4 && < 5, + ghci == @ProjectVersionMunged@ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50dfc3a02d07d7da3a85b6a9f2151c7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50dfc3a02d07d7da3a85b6a9f2151c7... You're receiving this email because of your account on gitlab.haskell.org.