From 256f85d735310196d437ede86046f2a86efedc6d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Moonlight?= Date: Tue, 12 Mar 2024 09:15:46 +0100 Subject: [PATCH] Backport of #9443 "Use linker capability detection to improve linker use" (#9797) --- Cabal/src/Distribution/Simple/Configure.hs | 53 +++++++++---------- Cabal/src/Distribution/Simple/GHC/Internal.hs | 4 +- .../Distribution/Simple/Program/Builtin.hs | 44 +++++++++++++-- Cabal/src/Distribution/Simple/Program/Db.hs | 6 ++- changelog.d/pr-9443 | 11 ++++ 5 files changed, 83 insertions(+), 35 deletions(-) create mode 100644 changelog.d/pr-9443 diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 74daa6660ac..bc8e5f5d289 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -76,7 +76,7 @@ import Distribution.Simple.Program import Distribution.Simple.Setup as Setup import Distribution.Simple.BuildTarget import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program.Db (appendProgramSearchPath, modifyProgramSearchPath) +import Distribution.Simple.Program.Db (appendProgramSearchPath, modifyProgramSearchPath, lookupProgramByName) import Distribution.Simple.Utils import Distribution.System import Distribution.Types.PackageVersionConstraint @@ -102,7 +102,8 @@ import qualified Distribution.Simple.HaskellSuite as HaskellSuite import Control.Exception ( try ) import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) -import Distribution.Compat.Directory ( listDirectory ) +import Distribution.Compat.Directory + ( listDirectory, doesPathExist ) import Data.ByteString.Lazy ( ByteString ) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BLC8 @@ -115,8 +116,6 @@ import System.Directory , getTemporaryDirectory, removeFile) import System.FilePath ( (), isAbsolute, takeDirectory ) -import Distribution.Compat.Directory - ( doesPathExist ) import qualified System.Info ( compilerName, compilerVersion ) import System.IO @@ -639,21 +638,16 @@ configure (pkg_descr0, pbi) cfg = do "--enable-split-objs; ignoring") return False - let compilerSupportsGhciLibs :: Bool - compilerSupportsGhciLibs = - case compilerId comp of - CompilerId GHC version - | version > mkVersion [9,3] && windows -> - False - CompilerId GHC _ -> - True - CompilerId GHCJS _ -> - True - _ -> False - where - windows = case compPlatform of - Platform _ Windows -> True - Platform _ _ -> False + -- Basically yes/no/unknown. + let linkerSupportsRelocations :: Maybe Bool + linkerSupportsRelocations = + case lookupProgramByName "ld" programDb'' of + Nothing -> Nothing + Just ld -> + case Map.lookup "Supports relocatable output" $ programProperties ld of + Just "YES" -> Just True + Just "NO" -> Just False + _other -> Nothing let ghciLibByDefault = case compilerId comp of @@ -673,10 +667,12 @@ configure (pkg_descr0, pbi) cfg = do withGHCiLib_ <- case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of - True | not compilerSupportsGhciLibs -> do + -- NOTE: If linkerSupportsRelocations is Nothing this may still fail if the + -- linker does not support -r. + True | not (fromMaybe True linkerSupportsRelocations) -> do warn verbosity $ - "--enable-library-for-ghci is no longer supported on Windows with" - ++ " GHC 9.4 and later; ignoring..." + "--enable-library-for-ghci is not supported with the current" + ++ " linker; ignoring..." return False v -> return v @@ -951,11 +947,11 @@ dependencySatisfiable then internalDepSatisfiable else -- Backward compatibility for the old sublibrary syntax - (sublibs == mainLibSet + sublibs == mainLibSet && Map.member (pn, CLibName $ LSubLibName $ packageNameToUnqualComponentName depName) - requiredDepsMap) + requiredDepsMap || all visible sublibs @@ -982,7 +978,7 @@ dependencySatisfiable internalDepSatisfiable = Set.isSubsetOf (NES.toSet sublibs) packageLibraries internalDepSatisfiableExternally = - all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs + all (not . null . PackageIndex.lookupInternalDependency installedPackageSet pn vr) sublibs -- Check whether a library exists and is visible. -- We don't disambiguate between dependency on non-existent or private @@ -1451,8 +1447,7 @@ getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform = -- flag into a single package db stack. -- interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack -interpretPackageDbFlags userInstall specificDBs = - extra initialStack specificDBs +interpretPackageDbFlags userInstall = extra initialStack where initialStack | userInstall = [GlobalPackageDB, UserPackageDB] | otherwise = [GlobalPackageDB] @@ -1698,8 +1693,8 @@ ccLdOptionsBuildInfo cflags ldflags ldflags_static = let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static - (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static + extraLibsStatic' = filter ("-l" `isPrefixOf`) ldflags_static + extraLibDirsStatic' = filter ("-L" `isPrefixOf`) ldflags_static in mempty { includeDirs = map (drop 2) includeDirs', extraLibs = map (drop 2) extraLibs', diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 507831f3cab..6b595b75f3a 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -101,7 +101,9 @@ configureToolchain _implInfo ghcProg ghcInfo = } . addKnownProgram ldProgram { programFindLocation = findProg ldProgramName extraLdPath, - programPostConf = configureLd + programPostConf = \v cp -> + -- Call any existing configuration first and then add any new configuration + configureLd v =<< programPostConf ldProgram v cp } . addKnownProgram arProgram { programFindLocation = findProg arProgramName extraArPath diff --git a/Cabal/src/Distribution/Simple/Program/Builtin.hs b/Cabal/src/Distribution/Simple/Program/Builtin.hs index 5bb324f388f..81aee4b93d6 100644 --- a/Cabal/src/Distribution/Simple/Program/Builtin.hs +++ b/Cabal/src/Distribution/Simple/Program/Builtin.hs @@ -256,8 +256,7 @@ arProgram = simpleProgram "ar" stripProgram :: Program stripProgram = (simpleProgram "strip") { - programFindVersion = \verbosity -> - findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + programFindVersion = findProgramVersion "--version" stripExtractVersion . lessVerbose } hsc2hsProgram :: Program @@ -322,7 +321,44 @@ greencardProgram :: Program greencardProgram = simpleProgram "greencard" ldProgram :: Program -ldProgram = simpleProgram "ld" +ldProgram = (simpleProgram "ld") + { programPostConf = \verbosity ldProg -> do + -- The `lld` linker cannot create merge (relocatable) objects so we + -- want to detect this. + -- If the linker does support relocatable objects, we want to use that + -- to create partially pre-linked objects for GHCi, so we get much + -- faster loading as we do not have to do the separate loading and + -- in-memory linking the static linker in GHC does, but can offload + -- parts of this process to a pre-linking step. + -- However this requires the linker to support this features. Not all + -- linkers do, and notably as of this writing `lld` which is a popular + -- choice for windows linking does not support this feature. However + -- if using binutils ld or another linker that supports --relocatable, + -- we should still be good to generate pre-linked objects. + ldHelpOutput <- + getProgramInvocationOutput + verbosity + (programInvocation ldProg ["--help"]) + -- In case the linker does not support '--help'. Eg the LLVM linker, + -- `lld` only accepts `-help`. + `catchIO` (\_ -> return "") + let k = "Supports relocatable output" + -- Standard GNU `ld` uses `--relocatable` while `ld.gold` uses + -- `-relocatable` (single `-`). + v + | "-relocatable" `isInfixOf` ldHelpOutput = "YES" + -- ld64 on macOS has this lovely response for "--help" + -- + -- ld64: For information on command line options please use 'man ld'. + -- + -- it does however support -r, if you read the manpage + -- (e.g. https://www.manpagez.com/man/1/ld64/) + | "ld64:" `isPrefixOf` ldHelpOutput = "YES" + | otherwise = "NO" + + m = Map.insert k v (programProperties ldProg) + return $ ldProg{programProperties = m} + } tarProgram :: Program tarProgram = (simpleProgram "tar") { @@ -334,7 +370,7 @@ tarProgram = (simpleProgram "tar") { -- Some versions of tar don't support '--help'. `catchIO` (\_ -> return "") let k = "Supports --format" - v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + v = if "--format" `isInfixOf` tarHelpOutput then "YES" else "NO" m = Map.insert k v (programProperties tarProg) return $ tarProg { programProperties = m } } diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index b9fb61a7913..b1edb84499f 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -47,6 +47,7 @@ module Distribution.Simple.Program.Db ( userSpecifyArgss, userSpecifiedArgs, lookupProgram, + lookupProgramByName, updateProgram, configuredPrograms, @@ -309,8 +310,11 @@ userSpecifiedArgs prog = -- | Try to find a configured program lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram -lookupProgram prog = Map.lookup (programName prog) . configuredProgs +lookupProgram = lookupProgramByName . programName +-- | Try to find a configured program +lookupProgramByName :: String -> ProgramDb -> Maybe ConfiguredProgram +lookupProgramByName name = Map.lookup name . configuredProgs -- | Update a configured program in the database. updateProgram :: ConfiguredProgram -> ProgramDb diff --git a/changelog.d/pr-9443 b/changelog.d/pr-9443 new file mode 100644 index 00000000000..353f1fb8cbd --- /dev/null +++ b/changelog.d/pr-9443 @@ -0,0 +1,11 @@ +synopsis: Use linker capability detection to improve linker use +packages: Cabal +prs: #9443 + +description: { + +- Previously the GHC version number and platform were used as a proxy for whether + the linker can generate relocatable objects. +- Now, the ability of the linker to create relocatable objects is detected. + +}