Magnus pushed to branch wip/mangoiv/improve-linker-discovery at Glasgow Haskell Compiler / GHC Commits: 9fd0f84e by mangoiv at 2026-07-30T17:02:08+02:00 configure: implement a saner linker discovery algorithm in dist/configure - - - - - 9 changed files: - distrib/configure.ac.in - + m4/bindist_determine_linker.m4 - m4/find_merge_objects.m4 - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Lens.hs - utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs - utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs Changes: ===================================== distrib/configure.ac.in ===================================== @@ -175,7 +175,11 @@ AC_SUBST([CmmCPPSupportsG0]) dnl ** Which ld to use? dnl -------------------------------------------------------------- -FIND_LD([$target],[GccUseLdOpt]) +dnl currently if you pass $LD=foo, merge objs command will be set to $(which foo) +dnl which is not required by GHC and also wrong. +BINDIST_DETERMINE_LINKER([$target],[GccUseLdOpt]) +dnl at this point, we should have set LD in all cases, so FIND_MERGE_OBJECTS command can +dnl go off and do it's thing FIND_MERGE_OBJECTS() CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 $GccUseLdOpt" CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 $GccUseLdOpt" @@ -427,6 +431,7 @@ checkMake380 make checkMake380 gmake # Toolchain target files +USER_LD="$LD" FIND_GHC_TOOLCHAIN_BIN([YES]) PREP_TARGET_FILE FIND_GHC_TOOLCHAIN([.]) ===================================== m4/bindist_determine_linker.m4 ===================================== @@ -0,0 +1,133 @@ +# BINDIST_DETERMINE_LINKER +# ------------------------ +# +# This is used to determine the linker within the bindists configure +# +# Notes: +# - usually, linking works by invoking $CC +# - objects are merged using $LD directly +# - $LD is a configure variable and is meaningless to $CC +# - gcc only knows linker *flavours*, it cannot use paths +# which means that the linker path should not be an absolute path +# - clang konws --ld-path which means that it can be passed that +# flag and also merge objs can be an absolute path +# +# Algorithm: +# if $LD is set +# then if $CC accepts --ld-path=$(which $LD) +# then set --ld-path=$(which $LD), MergeObjsCommand=$(which $LD) +# else if $CC accepts --fuse-ld=$LD ($LD is a linker flavour, not an absolute path) +# then set -fuse-ld=$LD, MergeObjsCommand=$LD (not $(which ld)) +# else Reject with +# "$LD is not compatible with $CC you chose. This means that $LD is either +# an unsupported linker flavour or your $CC does not support absolute linker +# paths" +# else if --disable-ld-override is set or $target is macos +# then if $CC accepts --ld-path=$(which ld) +# then set --ld-path=$(which ld), set MergeObjsCommand=$(which ld) +# else set *no* flag (equivalent to --fuse-ld=ld, if you will), set MergeObjsCommand=ld +# else if $CC accepts --ld-path=$(which ld.lld) +# then set --ld-path=$(which ld.lld), MergeObjsCommand=$(which ld.lld) +# else if $CC accepts -fuse-ld=lld +# then set -fuse-ld=lld, MergeObjsCommand=ld.lld +# else set *no* flag (equivalent to --fuse-ld=ld), set MergeObjsCommand=ld +# +# $1 = the platform +# $2 = the variable to set with GHC options to configure gcc to use the chosen linker +# +AC_DEFUN([BINDIST_DETERMINE_LINKER],[ + AC_ARG_ENABLE(ld-override, + [AS_HELP_STRING([--disable-ld-override], + [Prevent GHC from overriding the default linker used by gcc. If ld-override is enabled GHC will try to tell gcc to use whichever linker is selected by the LD environment variable. [default=override enabled]])], + [], + [enable_ld_override=yes]) + + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_TARGET]) + + check_ld_path() { + AC_MSG_CHECKING([whether C compiler supports --ld-path=[$]1]) + ld_path="[$]1" + echo 'int main(void) { return 0; }' > conftest.c + if $CC -o conftest.o "--ld-path=$ld_path" $LDFLAGS conftest.c > /dev/null 2>&1 + then + AC_MSG_RESULT([yes]) + ld_path_ok=yes + else + AC_MSG_RESULT([no]) + ld_path_ok=no + fi + rm -f conftest.c conftest.o + } + + check_fuse_ld() { + AC_MSG_CHECKING([whether C compiler supports -fuse-ld=[$]1]) + ld="[$]1" + echo 'int main(void) {return 0;}' > conftest.c + if $CC -o conftest.o -fuse-ld=[$]1 $LDFLAGS conftest.c > /dev/null 2>&1 + then + AC_MSG_RESULT([yes]) + fuse_ld_ok=yes + else + AC_MSG_RESULT([no]) + fuse_ld_ok=no + fi + rm -f conftest.c conftest.o + } + + try_set_linker_to() { + AC_MSG_CHECKING([whether linker can be set to [$]1]) + tmp_ld=[$]1 + ld_path_ok="no" + if test "z$tmp_ld" != "z" && check_ld_path "$tmp_ld" && test "x$ld_path_ok" = "xyes"; + then $2="--ld-path=$tmp_ld" + AC_CHECK_TARGET_TOOL([LD], [$tmp_ld]) + linker_set_successfully=yes + else # --ld-path does not work or $LD cannot be resolved to an absolute path + fuse_ld_ok=no + if check_fuse_ld "$tmp_ld" && test "x$fuse_ld_ok" = "xyes"; + then $2="-fuse-ld=$tmp_ld" + AC_CHECK_TARGET_TOOL([LD], [$tmp_ld]) + linker_set_successfully=yes + else AC_MSG_WARN(["$tmp_ld could not be set via either '--ld-path' or '-fuse-ld"]) + linker_set_successfully=no + fi + fi + } + + # we are lenient when $LD=ld and just act as if $LD wasn't set and + # enable-ld-override is off + if test "z$LD" != "z" && test "z$LD" != "zld"; + then linker_set_successfully=no + try_set_linker_to "$LD" + if test "z$linker_set_successfully" != "zyes"; + then AC_MSG_FAILURE([ $tmp_ld is an invalid linker. If your C compiler accepts the '--ld-path' flag, + \$LD can be either of an executable name that is in \$PATH *or* a path to an executable. + If your C compiler only supports the '--fuse-ld' flag, \$LD can only be one of the linker flavours supported + by it. Mind that if your C compiler supports '--ld-path', 'configure' will always prefer using an absolute path + to your linker as that is less error-prone.]) + fi + + else # $LD is not set -- we will do the ld-override non-sense + if test "x$enable_ld_override" = "xyes" && test "z$LD" != "zld" && case "$1" in + *-darwin) false ;; # don't do the ld override thing on macos + *) true ;; + esac; + then + AC_MSG_NOTICE(["enable ld override was set and no more specific linker was chosen by setting \$LD, trying to find best possible linker"]) + try_set_linker_to "lld" + if test "z$linker_set_successfully" != "zyes"; + then # ... bail out, just use ld in path + $2="" + AC_CHECK_TARGET_TOOL([LD], [ld]) + fi + else # ld override is not set and $LD not set either + $2="" + AC_CHECK_TARGET_TOOL([LD], [ld]) + fi + fi + + AC_MSG_NOTICE([linker discovery set $2 set to $$2]) + + CHECK_LD_COPY_BUG([$1]) +]) ===================================== m4/find_merge_objects.m4 ===================================== @@ -22,7 +22,6 @@ AC_DEFUN([CHECK_MERGE_OBJECTS],[ ]) AC_DEFUN([FIND_MERGE_OBJECTS],[ - AC_REQUIRE([FIND_LD]) if test -z ${MergeObjsCmd+x}; then AC_MSG_NOTICE([Setting cmd]) ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module Main where @@ -11,7 +13,7 @@ import System.Exit import System.Console.GetOpt import System.Environment import System.FilePath ((</>)) -import qualified System.IO (readFile, writeFile) +import qualified System.IO (writeFile, readFile') import GHC.Platform.ArchOS @@ -33,6 +35,10 @@ import GHC.Toolchain.Tools.MergeObjs import GHC.Toolchain.Tools.Readelf import GHC.Toolchain.NormaliseTriple (normaliseTriple) import Text.Read (readMaybe) +import System.IO (hPutStrLn, stderr) +import Control.Exception (try, IOException, catch, displayException) +import GHC.Stack (HasCallStack) +import Data.Foldable (traverse_) data Opts = Opts { optTriple :: Maybe String @@ -72,6 +78,8 @@ data Opts = Opts , optTablesNextToCode :: Maybe Bool , optUseLibFFIForAdjustors :: Maybe Bool , optLdOverride :: Maybe Bool + -- ^ whether or not to not use ld in $PATH and instead search for a + -- linker that GHC deems "better" , optVerbosity :: Int , optKeepTemp :: Bool } @@ -200,7 +208,7 @@ options = [ enableDisable "unregisterised" "unregisterised backend" _optUnregisterised , enableDisable "tables-next-to-code" "info-tables-next-to-code optimisation" _optTablesNextToCode , enableDisable "libffi-adjustors" "the use of libffi for adjustors, even on platforms which have support for more efficient, native adjustor implementations." _optUseLibFFIForAdjustors - , enableDisable "ld-override" "override gcc's default linker" _optLdOvveride + , enableDisable "ld-override" "search for a more efficient linker than your default linker" _optLdOvveride , enableDisable "locally-executable" "the use of a target prefix which will be added to all tool names when searching for toolchain components" _optLocallyExecutable , enableDisable "dwarf-unwind" "Enable DWARF unwinding support in the runtime system via elfutils' libdw" _optDwarfUnwind ] ++ @@ -280,12 +288,11 @@ options = "The output path for the generated target toolchain configuration" formatOpts :: [OptDescr (FormatOpts -> FormatOpts)] -formatOpts = [ - (Option ['o'] ["output"] (ReqArg (set _formatOptOutput) "OUTPUT") +formatOpts = + [ (Option ['o'] ["output"] (ReqArg (set _formatOptOutput) "OUTPUT") "The output path for the formatted target toolchain configuration") , (Option ['i'] ["input"] (ReqArg (set _formatOptInput) "INPUT") - "The target file to format") - ] + "The target file to format") ] validateOpts :: Opts -> [String] validateOpts opts = mconcat @@ -297,30 +304,38 @@ main :: IO () main = do argv <- getArgs case argv of - ("format": args) -> doFormat args + ("format" : args) -> doFormat args _ -> doConfigure argv -- The format mode is very useful for normalising paths and newlines on windows. -doFormat :: [String] -> IO () +doFormat :: HasCallStack => [String] -> IO () doFormat args = do let (opts0, _nonopts, errs) = getOpt RequireOrder formatOpts args case errs of [] -> do let opts = foldr (.) id opts0 emptyFormatOpts - tgtFile <- System.IO.readFile (view _formatOptInput opts) - case readMaybe @Target tgtFile of - Nothing -> error $ "Failed to read a valid Target value from " ++ view _formatOptInput opts ++ ":\n" ++ tgtFile - Just tgt -> do + tgtFile <- try @IOException $ System.IO.readFile' (view _formatOptInput opts) + case tgtFile of + Right (readMaybe @Target -> Just tgt) -> do let file = formatOptOutput opts System.IO.writeFile file (show tgt) + `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Failed to write the formatted Target file to" ++ file ++ ". Writing caused the following IOException:\n" + ++ displayException e + Right contents -> do + hPutStrLn stderr $ "Failed to read a valid Target value from " ++ view _formatOptInput opts ++ "invalid file was:\n" ++ contents + exitWith (ExitFailure 1) + Left reason -> do + hPutStrLn stderr $ "Failed to read a valid Target value from " ++ view _formatOptInput opts ++ ", because an IOException occured:\n" ++ displayException reason + exitWith (ExitFailure 1) _ -> do - mapM_ putStrLn errs - putStrLn $ usageInfo "ghc-toolchain" formatOpts + mapM_ (hPutStrLn stderr) errs + hPutStrLn stderr $ usageInfo "ghc-toolchain" formatOpts exitWith (ExitFailure 1) -doConfigure :: [String] -> IO () +doConfigure :: HasCallStack => [String] -> IO () doConfigure args = do let (opts0, _nonopts, parseErrs) = getOpt RequireOrder options args let opts = foldr (.) id opts0 emptyOpts @@ -329,18 +344,22 @@ doConfigure args = do let env = Env { verbosity = optVerbosity opts , targetPrefix = case optTargetPrefix opts of Just prefix -> Just prefix + -- TODO: why is this `fromMaybe (error _)`? that seems wrong (ah okay, because that would already mean that `errs` is not null; seems bad that we have this here though) Nothing -> Just $ fromMaybe (error "undefined triple") (optTriple opts) ++ "-" , keepTemp = optKeepTemp opts , canLocallyExecute = fromMaybe True (optLocallyExecutable opts) , logContexts = [] } r <- runM env (run opts) + `catch` \(e :: IOException) -> pure $ Left [Error {errorLogContexts = [], errorMessage = displayException e}] case r of - Left err -> print err >> exitWith (ExitFailure 2) + Left errs -> do + traverse_ (hPutStrLn stderr . formatError) errs + exitWith (ExitFailure 1) Right () -> return () errs -> do - mapM_ putStrLn errs - putStrLn $ usageInfo "ghc-toolchain" options + mapM_ (hPutStrLn stderr) errs + hPutStrLn stderr $ usageInfo "ghc-toolchain" options exitWith (ExitFailure 1) run :: Opts -> M () @@ -449,15 +468,15 @@ mkTarget opts = do cc0 <- findBasicCc (optCc opts) parseTriple cc0 normalised_triple - cc0 <- findCc archOs tgtLlvmTarget (optCc opts) + cc <- findCc archOs tgtLlvmTarget (optCc opts) cxx <- findCxx archOs tgtLlvmTarget (optCxx opts) - cpp <- findCpp (optCpp opts) cc0 - hsCpp <- findHsCpp (optHsCpp opts) cc0 + cpp <- findCpp (optCpp opts) cc + hsCpp <- findHsCpp (optHsCpp opts) cc -- TODO: same case as ranlib below -- TODO: we need it really only for javascript target (maybe wasm target as well) - jsCpp <- Just <$> findJsCpp (optJsCpp opts) cc0 - cmmCpp <- findCmmCpp (optCmmCpp opts) cc0 - cc <- addPlatformDepCcFlags archOs cc0 + jsCpp <- Just <$> findJsCpp (optJsCpp opts) cc + cmmCpp <- findCmmCpp (optCmmCpp opts) cc + ccWithPlatformFlags <- addPlatformDepCcFlags archOs cc readelf <- optional $ findReadelf (optReadelf opts) -- TODO: We could have -- ranlib <- if arNeedsRanlib ar @@ -466,11 +485,21 @@ mkTarget opts = do -- but in order to match the configure output, for now we do ranlib <- findRanlib (optRanlib opts) ar <- findAr tgtVendor (optAr opts) - ccLink <- findCcLink tgtLlvmTarget (optLd opts) (optCcLink opts) (ldOverrideWhitelist archOs && fromMaybe True (optLdOverride opts)) archOs cc readelf ar ranlib - + ccLink <- findCcLink + tgtLlvmTarget + (optLd opts) + (optCcLink opts) + (ldOverrideWhitelist archOs + -- ld-override is enabled by default + && fromMaybe True (optLdOverride opts)) + archOs + ccWithPlatformFlags + readelf + ar + ranlib nm <- findNm (optNm opts) - mergeObjs <- optional $ findMergeObjs (optMergeObjs opts) cc ccLink nm + mergeObjs <- optional $ findMergeObjs (optMergeObjs opts) ccWithPlatformFlags ccLink nm when (isNothing mergeObjs && not (arSupportsDashL ar)) $ throwE "Neither a object-merging tool (e.g. ld -r) nor an ar that supports -L is available" @@ -494,15 +523,15 @@ mkTarget opts = do _ -> return (Nothing, Nothing) -- various other properties of the platform - tgtWordSize <- checkWordSize cc - tgtEndianness <- checkEndianness cc - tgtSymbolsHaveLeadingUnderscore <- checkLeadingUnderscore cc nm - tgtSupportsSubsectionsViaSymbols <- checkSubsectionsViaSymbols archOs cc - tgtSupportsIdentDirective <- checkIdentDirective cc - tgtSupportsGnuNonexecStack <- checkGnuNonexecStack archOs cc - tgtHasLibm <- checkTargetHasLibm cc + tgtWordSize <- checkWordSize ccWithPlatformFlags + tgtEndianness <- checkEndianness ccWithPlatformFlags + tgtSymbolsHaveLeadingUnderscore <- checkLeadingUnderscore ccWithPlatformFlags nm + tgtSupportsSubsectionsViaSymbols <- checkSubsectionsViaSymbols archOs ccWithPlatformFlags + tgtSupportsIdentDirective <- checkIdentDirective ccWithPlatformFlags + tgtSupportsGnuNonexecStack <- checkGnuNonexecStack archOs ccWithPlatformFlags + tgtHasLibm <- checkTargetHasLibm ccWithPlatformFlags tgtRTSWithLibdw <- case optDwarfUnwind opts of - Just True -> checkTargetHasLibdw cc (optLibdwIncludes opts) (optLibdwLibraries opts) + Just True -> checkTargetHasLibdw ccWithPlatformFlags (optLibdwIncludes opts) (optLibdwLibraries opts) _ -> pure Nothing -- code generator configuration @@ -515,14 +544,14 @@ mkTarget opts = do let prog = "int main(int argc, char** argv) { return 0; }" via_c_args = ["-fwrapv", "-fno-builtin"] forM_ via_c_args $ \arg -> checking ("support of "++arg) $ withTempDir $ \dir -> do - let cc' = over (_ccProgram % _prgFlags) (++ [arg]) cc + let cc' = over (_ccProgram % _prgFlags) (++ [arg]) ccWithPlatformFlags compileC cc' (dir </> "test.o") prog return () let t = Target { tgtArchOs = archOs , tgtVendor , tgtLocallyExecutable = fromMaybe True (optLocallyExecutable opts) - , tgtCCompiler = cc + , tgtCCompiler = ccWithPlatformFlags , tgtCxxCompiler = cxx , tgtCPreprocessor = cpp , tgtHsCPreprocessor = hsCpp ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Lens.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} -- | A very simple Lens implementation module GHC.Toolchain.Lens ( Lens(..) @@ -7,11 +8,15 @@ module GHC.Toolchain.Lens , (&) ) where -import Prelude ((.), ($), (++)) +import Prelude ((.), ($), (++), Monoid, (<>)) import Data.Function ((&)) +import GHC.Records data Lens a b = Lens { view :: (a -> b), set :: (b -> a -> a) } +instance HasField "over" (Lens a b) ((b -> b) -> a -> a) where + getField = over + (%) :: Lens a b -> Lens b c -> Lens a c a % b = Lens { view = view b . view a , set = \y x -> set a (set b y (view a x)) x ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} module GHC.Toolchain.Monad ( Env(..) @@ -21,6 +22,10 @@ module GHC.Toolchain.Monad , logDebug , checking , withLogContext + + -- * Errors + , Error (..) + , formatError ) where import Prelude hiding (readFile, writeFile, appendFile) @@ -63,6 +68,9 @@ data Error = Error { errorMessage :: String } deriving (Show) +formatError :: Error -> String +formatError Error {errorMessage, errorLogContexts} = unlines $ errorMessage : errorLogContexts + throwE :: String -> M a throwE msg = throwEs [msg] ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Toolchain.Tools.Cc ( Cc(..) @@ -23,6 +24,7 @@ import GHC.Platform.ArchOS import GHC.Toolchain.Prelude import GHC.Toolchain.Utils import GHC.Toolchain.Program +import System.Exit (ExitCode(..)) newtype Cc = Cc { ccProgram :: Program } @@ -109,11 +111,12 @@ checkCcSupportsExtraViaCFlags cc = checking "whether cc supports extra via-c fla , "-fwrapv", "-fno-builtin" , "-Werror", "-x", "c" , "-o", test_o, test_c] - when (not (isSuccess code) - || "unrecognized" `isInfixOf` out - || "unrecognized" `isInfixOf` err - ) $ - throwE "Your C compiler must support the -fwrapv and -fno-builtin flags" + + if | ExitSuccess <- code + , not $ "unrecognized" `isInfixOf` out + , not $ "unrecognized" `isInfixOf` err + -> pure () + | otherwise -> throwE "Your C compiler must support the -fwrapv and -fno-builtin flags" -- | Preprocess the given program. preprocess ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -1,7 +1,8 @@ -{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedRecordDot #-} module GHC.Toolchain.Tools.Link ( CcLink(..), findCcLink ) where @@ -18,6 +19,8 @@ import GHC.Toolchain.Tools.Cc import GHC.Toolchain.Tools.Ar import GHC.Toolchain.Tools.Ranlib import GHC.Toolchain.Tools.Readelf +import System.Exit (ExitCode(..)) +import Control.Applicative -- | Configuration on how the C compiler can be used to link data CcLink = CcLink { ccLinkProgram :: Program @@ -47,61 +50,97 @@ instance Show CcLink where _ccLinkProgram :: Lens CcLink Program _ccLinkProgram = Lens ccLinkProgram (\x o -> o{ccLinkProgram=x}) -findCcLink :: String -- ^ The llvm target to use if CcLink supports --target - -> ProgOpt - -> ProgOpt - -> Bool -- ^ Whether we should search for a more efficient linker - -> ArchOS -> Cc -> Maybe Readelf -> Ar -> Ranlib -> M CcLink -findCcLink target ld progOpt ldOverride archOs cc readelf ar ranlib = checking "for C compiler for linking command" $ do +-- | tries to add flags to the c compiler to run as a linker +findCcLink :: String -- ^ The llvm target to use if CcLink supports --target + -> ProgOpt -- ^ The contents of $LD + -> ProgOpt -- ^ The c compiler intended for invoking the linker + -> Bool -- ^ Whether GHC should disregard ld and search for a linker it considers better + -> ArchOS + -> Cc -- ^ the c compiler used for compiling c programs, used as a fallback + -> Maybe Readelf -> Ar -> Ranlib -> M CcLink +findCcLink target ld progOpt userLdOverride archOs cc readelf ar ranlib = checking "for C compiler for linking command" $ do -- Use the specified linker or try using the C compiler rawCcLink <- findProgram "C compiler for linking" progOpt [] <|> pure (programFromOpt progOpt (prgPath $ ccProgram cc) []) - -- See #23857 for why we check to see if LD is set here - -- TLDR: If the user explicitly sets LD then in ./configure - -- we don't perform a linker search (and set -fuse-ld), so - -- we do the same here for consistency. - ccLinkProgram <- case (poPath ld, poFlags progOpt) of - (_, Just _) -> - -- If the user specified linker flags don't second-guess them - pure rawCcLink - (Just {}, _) -> - pure rawCcLink - _ -> do - -- If not then try to find decent linker flags - findLinkFlags ldOverride cc rawCcLink <|> pure rawCcLink - ccLinkProgram <- linkSupportsTarget archOs cc target ccLinkProgram - ccLinkSupportsNoPie <- checkSupportsNoPie cc ccLinkProgram - ccLinkSupportsCompactUnwind <- checkSupportsCompactUnwind archOs cc ccLinkProgram - ccLinkSupportsFilelist <- checkSupportsFilelist cc ccLinkProgram - ccLinkSupportsSingleModule <- checkSupportsSingleModule archOs cc ccLinkProgram - ccLinkIsGnu <- checkLinkIsGnu archOs ccLinkProgram - checkBfdCopyBug archOs cc readelf ccLinkProgram - ccLinkProgram <- addPlatformDepLinkFlags archOs cc ccLinkProgram - ccLinkSupportsVerbatimNamespace <- linkSupportsVerbatimNamespace cc ar ranlib ccLinkProgram - let ccLink = CcLink {ccLinkProgram, ccLinkSupportsNoPie, - ccLinkSupportsCompactUnwind, ccLinkSupportsFilelist, - ccLinkSupportsSingleModule, ccLinkIsGnu, ccLinkSupportsVerbatimNamespace} - ccLink <- linkRequiresNoFixupChains archOs cc ccLink - ccLink <- linkRequiresNoWarnDuplicateLibraries archOs cc ccLink - return ccLink - - --- | Try to convince @cc@ to use a more efficient linker than @bfd.ld@ -findLinkFlags :: Bool -> Cc -> Program -> M Program -findLinkFlags enableOverride cc ccLink - | enableOverride && doLinkerSearch = - oneOf "this can't happen" - [ -- Annoyingly, gcc silently falls back to vanilla ld (typically bfd - -- ld) if @-fuse-ld@ is given with a non-existent linker. - -- Consequently, we must first check that the desired ld - -- executable exists before trying cc. - do _ <- findProgram (linker ++ " linker") emptyProgOpt ["ld."++linker] - prog <$ checkLinkWorks cc prog - | linker <- ["lld", "bfd"] - , let prog = over _prgFlags (++["-fuse-ld="++linker]) ccLink - ] - <|> (ccLink <$ checkLinkWorks cc ccLink) - | otherwise = - return ccLink + ccLinkProgram <- if + -- A cc with linker was already specified, don't doubt the user's proficiency, + -- autonomy and right to segmentation faults + | Just _ <- progOpt.poFlags -> pure rawCcLink + -- we get a $LD; now figure out how to pass it to the $CC + | Just ldPathOrFlavour <- ld.poPath + -- even though $LD=ld doesn't really mean anything to C compilers, + -- we are lenient and just act as if $LD wasn't set and enable-ld-override + -- is off + , ldPathOrFlavour /= "ld" -> do + flip oneOf' + + [ do + -- first check if the c compiler supports --ld-path, which goes best with $LD + ldPath <- findProgram (ldPathOrFlavour <> " linker") emptyProgOpt $ tryLdPrefix [ldPathOrFlavour] + -- findProgram takes a userSpec but in our case this is emptyProgOpt, so we just + -- extract the path that it found and ignore the (empty) arguments + checkLink rawCcLink [ fLdPath ldPath.prgPath ] + , -- second, check if the c compiler instead understands -fuse-ld (linker "flavour"); + -- do not try to expand the path first since absolute paths are not valid linker flavours + checkLink rawCcLink [ fUseLd ldPathOrFlavour] ] + + -- $LD was set but we couldn't figure out how to pass it to $CC. This is a hard failure, + -- we report it. + [ ldPathOrFlavour <> " is an invalid linker." + , "$LD can be either of an executable name that is in $PATH *or* a" + <> " path to an executable." + , "If your C compiler only supports the '-fuse-ld' flag, $LD can" + <> " only be one of the linker flavours supported by it." + , "Mind that if your C compiler supports '--ld-path', 'configure'" + <> " will always prefer using an absolute path to your linker as" + <> " that is less error-prone." ] + + -- $LD is not set or $LD=ld (see above) + -- Try to convince @cc@ to use a more efficient linker than @bfd.ld@ + | let ldOverride + | Just "ld" <- ld.poPath = False + | otherwise = userLdOverride + , ldOverride -> + asum + [ -- Annoyingly, gcc silently falls back to vanilla ld + -- if @-fuse-ld@ is given passed a non-existent linker. + -- Consequently, we must first check that the desired ld + -- executable exists before trying cc. + do linkerPath <- findProgram (linker ++ " linker") emptyProgOpt [ linker ] + checkLink rawCcLink [ fLdPath linkerPath.prgPath] + <|> checkLink rawCcLink [ fUseLd linker] + | linker <- tryLdPrefix ["lld", "bfd"] + ] + -- fall back to raw ld + <|> checkLink rawCcLink [] + + -- we can't help the user + | otherwise -> checkLink rawCcLink [] + + targetedCcLink <- linkSupportsTarget archOs cc target ccLinkProgram + ccLinkSupportsNoPie <- checkSupportsNoPie cc targetedCcLink + ccLinkSupportsCompactUnwind <- checkSupportsCompactUnwind archOs cc targetedCcLink + ccLinkSupportsFilelist <- checkSupportsFilelist cc targetedCcLink + ccLinkSupportsSingleModule <- checkSupportsSingleModule archOs cc targetedCcLink + ccLinkIsGnu <- checkLinkIsGnu archOs targetedCcLink + checkedCcLink <- addPlatformDepLinkFlags archOs cc targetedCcLink + ccLinkSupportsVerbatimNamespace <- linkSupportsVerbatimNamespace cc ar ranlib checkedCcLink + + checkBfdCopyBug archOs cc readelf targetedCcLink + + let finalCcLink = CcLink + { ccLinkProgram = checkedCcLink, ccLinkSupportsNoPie + , ccLinkSupportsCompactUnwind, ccLinkSupportsFilelist + , ccLinkSupportsSingleModule, ccLinkIsGnu, ccLinkSupportsVerbatimNamespace } + + linkRequiresNoFixupChains archOs cc finalCcLink + >>= linkRequiresNoWarnDuplicateLibraries archOs cc + where + checkLink ccLink extraFlags = + let prog = over _prgFlags (extraFlags <>) ccLink + in prog <$ checkLinkWorks cc prog + tryLdPrefix progs = [id, ("ld." <>)] <*> progs + fUseLd flavour = "-fuse-ld=" <> flavour + fLdPath path = "--ld-path=" <> path -- | Test whether the linker supports the verbatim '-l:libfoo.a' syntax, allowing -- us better control over partial static linking. @@ -150,20 +189,6 @@ linkSupportsTarget archOs cc target link = checking "whether cc linker supports --target" $ supportsTarget archOs (Lens id const) (checkLinkWorks cc) target link --- | Should we attempt to find a more efficient linker on this platform? --- --- N.B. On Darwin it is quite important that we use the system linker --- unchanged as it is very easy to run into broken setups (e.g. unholy mixtures --- of Homebrew and the Apple toolchain). --- --- See #21712. -doLinkerSearch :: Bool -#if defined(linux_HOST_OS) -doLinkerSearch = True -#else -doLinkerSearch = False -#endif - -- | See Note [No PIE when linking] in GHC.Driver.Session checkSupportsNoPie :: Cc -> Program -> M Bool checkSupportsNoPie cc ccLink = checking "whether the cc linker supports -no-pie" $ @@ -174,7 +199,11 @@ checkSupportsNoPie cc ccLink = checking "whether the cc linker supports -no-pie" -- Check output as some GCC versions only warn and don't respect -Werror -- when passed an unrecognized flag. (code, out, err) <- readProgram ccLink ["-no-pie", "-Werror", test_o, "-o", test] - return (isSuccess code && not ("unrecognized" `isInfixOf` out) && not ("unrecognized" `isInfixOf` err)) + return if + | ExitSuccess <- code + , not ("unrecognized" `isInfixOf` out) + , not ("unrecognized" `isInfixOf` err) -> True + | otherwise -> False -- ROMES:TODO: This check is wrong here and in configure because with ld.gold parses "-n" "o_compact_unwind" -- TODO: @@ -191,7 +220,8 @@ checkSupportsCompactUnwind archOs cc ccLink compileC cc test_o "int foo() { return 0; }" exitCode <- runProgram ccLink ["-r", "-Wl,-no_compact_unwind", "-o", test2_o, test_o] - return $ isSuccess exitCode + return if | ExitSuccess <- exitCode -> True + | otherwise -> False | otherwise = return False checkSupportsFilelist :: Cc -> Program -> M Bool @@ -210,7 +240,8 @@ checkSupportsFilelist cc ccLink = checking "whether the cc linker understands -f exitCode <- runProgram ccLink ["-r", "-Wl,-filelist", test_ofiles, "-o", test_o] - return (isSuccess exitCode) + return if | ExitSuccess <- exitCode -> True + | otherwise -> False -- | Check that the (darwin) linker supports @-single_module@. -- ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs ===================================== @@ -7,19 +7,18 @@ module GHC.Toolchain.Utils , withTempDir , oneOf , oneOf' - , isSuccess , lastLine , findM ) where -import Control.Exception +import Control.Applicative (asum) +import Control.Exception ( throwIO, bracket, try ) import Control.Monad import Control.Monad.IO.Class import Data.List (unsnoc) import System.Directory import System.FilePath import System.IO.Error -import System.Exit import GHC.Toolchain.Prelude @@ -61,12 +60,7 @@ oneOf err = oneOf' [err] -- | Like 'oneOf' but takes a multi-line error message if none of the checks -- succeed. oneOf' :: [String] -> [M b] -> M b -oneOf' err = foldr (<|>) (throwEs err) - -isSuccess :: ExitCode -> Bool -isSuccess = \case - ExitSuccess -> True - ExitFailure _ -> False +oneOf' err as = asum $ as <> [throwEs err] lastLine :: String -> String lastLine = maybe "" snd . unsnoc . lines View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9fd0f84ec49c0ec5c92475bf3edc89ca... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9fd0f84ec49c0ec5c92475bf3edc89ca... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help