Backport of #9443 "Use linker capability detection to improve linker use" (#9797)

Author: Kleidukos

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',

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

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 }
   }

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

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.
+
+}