[Git][ghc/ghc][wip/toolchain-selection] 2 commits: ghc-toolchain: Rename readProcess to readProcessStdout
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon May 1 17:31:29 UTC 2023
Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC
Commits:
9651258b by Rodrigo Mesquita at 2023-05-01T17:37:40+01:00
ghc-toolchain: Rename readProcess to readProcessStdout
Fixes bugs regarding a translation from the original autconf program
that failed to account for the exit code.
The longer name reenforces that we really only care about the stdout,
and the exit code and stderr of the program are irrelevant for the case.
- - - - -
f0218199 by Rodrigo Mesquita at 2023-05-01T18:31:20+01:00
Re-introduce ld-override option
- - - - -
8 changed files:
- configure.ac
- utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
- utils/ghc-toolchain/src/Main.hs
Changes:
=====================================
configure.ac
=====================================
@@ -446,6 +446,11 @@ FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
dnl ** Which ld to use
dnl --------------------------------------------------------------
AC_ARG_VAR(LD,[Use as the path to ld. See also --disable-ld-override.])
+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 disabled GHC will try to tell gcc to use whichever linker is selected by the LD environment variable. [default=override enabled]])],
+ [],
+ [enable_ld_override=yes])
dnl ** Which objdump to use?
dnl --------------------------------------------------------------
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs
=====================================
@@ -96,7 +96,7 @@ checkLeadingUnderscore :: Cc -> Nm -> M Bool
checkLeadingUnderscore cc nm = checking ctxt $ withTempDir $ \dir -> do
let test_o = dir </> "test.o"
compileC cc test_o prog
- out <- readProgram (nmProgram nm) [test_o]
+ out <- readProgramStdout (nmProgram nm) [test_o]
return $ "_func" `isInfixOf` out
where
prog = "int func(void) { return 0; }"
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
=====================================
@@ -6,6 +6,7 @@ module GHC.Toolchain.Program
, runProgram
, callProgram
, readProgram
+ , readProgramStdout
-- * Finding 'Program's
, ProgOpt(..)
, emptyProgOpt
@@ -58,10 +59,20 @@ callProgram prog args = do
, "Exited with code " ++ show n
]
-readProgram :: Program -> [String] -> M String
+-- | Runs a program with a list of arguments and returns the exit code and the
+-- stdout and stderr output
+readProgram :: Program -> [String] -> M (ExitCode, String, String)
readProgram prog args = do
logExecute prog args
- liftIO $ readProcess (prgPath prog) (prgFlags prog ++ args) ""
+ liftIO $ readProcessWithExitCode (prgPath prog) (prgFlags prog ++ args) ""
+
+-- | Runs a program with a list of arguments and returns the stdout output
+readProgramStdout :: Program -> [String] -> M String
+readProgramStdout prog args = do
+ logExecute prog args
+ (_code, stdout, _stderr) <- liftIO $ readProcessWithExitCode (prgPath prog) (prgFlags prog ++ args) ""
+ -- Ignores the exit code!
+ return stdout
logExecute :: Program -> [String] -> M ()
logExecute prog args =
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs
=====================================
@@ -22,7 +22,7 @@ data Ar = Ar { arMkArchive :: Program
findAr :: ProgOpt -> M Ar
findAr progOpt = checking "for 'ar'" $ do
bareAr <- findProgram "ar archiver" progOpt ["ar"]
- arIsGnu <- ("GNU" `isInfixOf`) <$> readProgram bareAr ["--version"]
+ arIsGnu <- ("GNU" `isInfixOf`) <$> readProgramStdout bareAr ["--version"]
-- Figure out how to invoke ar to create archives...
mkArchive <- checking "for how to make archives"
@@ -84,7 +84,7 @@ checkArSupportsDashL bareAr = checking "that ar supports -L" $ withTempDir $ \di
callProgram bareAr ["qc", archive2, file "b0", file "b1"]
oneOf "trying -L"
[ do callProgram bareAr ["qcL", merged, archive1, archive2]
- contents <- readProgram bareAr ["t", merged]
+ contents <- readProgramStdout bareAr ["t", merged]
return $ not $ "conftest.a1" `isInfixOf` contents
, return False
]
@@ -98,7 +98,7 @@ checkArSupportsAtFile bareAr mkArchive = checking "that ar supports @-files" $ w
createFile f
writeFile atfile (unlines objs)
callProgram mkArchive [archive, "@" ++ dir </> "conftest.atfile"]
- contents <- readProgram bareAr ["t", archive]
+ contents <- readProgramStdout bareAr ["t", archive]
if lines contents == objs
then return True
else logDebug "Contents didn't match" >> return False
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
=====================================
@@ -22,8 +22,8 @@ data CcLink = CcLink { ccLinkProgram :: Program
}
deriving (Show, Read)
-findCcLink :: ProgOpt -> ArchOS -> Cc -> Maybe Readelf -> M CcLink
-findCcLink progOpt archOs cc readelf = checking "for C compiler for linking command" $ do
+findCcLink :: ProgOpt -> Maybe Bool -> ArchOS -> Cc -> Maybe Readelf -> M CcLink
+findCcLink progOpt ldOverride archOs cc readelf = checking "for C compiler for linking command" $ do
ccLinkProgram <- case poPath progOpt of
Just _ ->
-- If the user specified a linker don't second-guess them
@@ -31,16 +31,16 @@ findCcLink progOpt archOs cc readelf = checking "for C compiler for linking comm
Nothing -> do
-- If not then try to find a decent linker on our own
rawCcLink <- findProgram "C compiler for linking" progOpt [prgPath $ ccProgram cc]
- findLinkFlags cc rawCcLink <|> pure rawCcLink
+ findLinkFlags ldOverride cc rawCcLink <|> pure rawCcLink
ccLinkSupportsNoPie <- checkSupportsNoPie ccLinkProgram
checkBfdCopyBug archOs cc readelf ccLinkProgram
ccLinkProgram <- addPlatformDepLinkFlags archOs cc ccLinkProgram
return $ CcLink {ccLinkProgram, ccLinkSupportsNoPie}
-- | Try to convince @cc@ to use a more efficient linker than @bfd.ld@
-findLinkFlags :: Cc -> Program -> M Program
-findLinkFlags cc ccLink
- | doLinkerSearch =
+findLinkFlags :: Maybe Bool -> Cc -> Program -> M Program
+findLinkFlags ldOverride 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.
@@ -54,6 +54,13 @@ findLinkFlags cc ccLink
<|> (ccLink <$ checkLinkWorks cc ccLink)
| otherwise =
return ccLink
+ where
+ enableOverride = case ldOverride of
+ -- ROMES: We're basically defining the default value here,
+ -- wouldn't it be better to define the default on construction?
+ Nothing -> True
+ Just True -> True
+ Just False -> False
-- | Should we attempt to find a more efficient linker on this platform?
--
@@ -77,8 +84,8 @@ checkSupportsNoPie ccLink = withTempDir $ \dir -> do
let test = dir </> "test"
-- Check output as some GCC versions only warn and don't respect -Werror
-- when passed an unrecognized flag.
- out <- readProgram ccLink ["-no-pie", "-Werror", "-x", "c", test_c, "-o", test]
- if "unrecognized" `isInfixOf` out
+ (code, out, _err) <- readProgram ccLink ["-no-pie", "-Werror", "-x", "c", test_c, "-o", test]
+ if isSuccess code && "unrecognized" `isInfixOf` out
then return False
else return True
@@ -119,7 +126,7 @@ checkBfdCopyBug archOs cc mb_readelf ccLink
callProgram ccLink ["-o", exe, test_o, main_o, lib_so]
- out <- readProgram (readelfProgram readelf) ["-r", exe]
+ out <- readProgramStdout (readelfProgram readelf) ["-r", exe]
when ("R_ARM_COPY" `isInfixOf` out) $
throwE "Your linker is affected by binutils #16177. Please choose a different linker."
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs
=====================================
@@ -36,14 +36,14 @@ checkMergingWorks cc nm mergeObjs =
compileC cc (fo "a") "void funA(int x) { return x; }"
compileC cc (fo "b") "void funB(int x) { return x; }"
callProgram (mergeObjsProgram mergeObjs) [fo "a", fo "b", "-o", fo "out"]
- out <- readProgram (nmProgram nm) [fo "out"]
+ out <- readProgramStdout (nmProgram nm) [fo "out"]
let ok = all (`isInfixOf` out) ["funA", "funB"]
unless ok $ throwE "merged objects is missing symbols"
checkForGoldT22266 :: Cc -> CcLink -> MergeObjs -> M ()
checkForGoldT22266 cc ccLink mergeObjs = do
version <- checking "for ld.gold object merging bug (binutils #22266)" $
- readProgram (mergeObjsProgram mergeObjs) ["--version"]
+ readProgramStdout (mergeObjsProgram mergeObjs) ["--version"]
when ("gold" `isInfixOf` version) check_it
where
check_it =
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Toolchain.Utils
@@ -5,6 +6,7 @@ module GHC.Toolchain.Utils
, expectFileExists
, withTempDir
, oneOf
+ , isSuccess
) where
import Control.Monad
@@ -13,6 +15,7 @@ import Control.Monad.IO.Class
import System.Directory
import System.FilePath
import System.IO.Error
+import System.Exit
import GHC.Toolchain.Prelude
@@ -52,3 +55,9 @@ expectFileExists path err = do
oneOf :: String -> [M b] -> M b
oneOf err = foldr (<|>) (throwE err)
+
+isSuccess :: ExitCode -> Bool
+isSuccess = \case
+ ExitSuccess -> True
+ ExitFailure _ -> False
+
=====================================
utils/ghc-toolchain/src/Main.hs
=====================================
@@ -44,6 +44,7 @@ data Opts = Opts
, optDllwrap :: ProgOpt
, optUnregisterised :: Maybe Bool
, optTablesNextToCode :: Maybe Bool
+ , optLdOverride :: Maybe Bool
, optVerbosity :: Int
, optKeepTemp :: Bool
}
@@ -65,6 +66,7 @@ emptyOpts = Opts
, optWindres = po0
, optUnregisterised = Nothing
, optTablesNextToCode = Nothing
+ , optLdOverride = Nothing -- See comment in Link on 'enableOverride'. Shouldn't we set the default here?
, optVerbosity = 0
, optKeepTemp = False
}
@@ -98,6 +100,9 @@ _optUnregisterised = Lens optUnregisterised (\x o -> o {optUnregisterised=x})
_optTablesNextToCode :: Lens Opts (Maybe Bool)
_optTablesNextToCode = Lens optTablesNextToCode (\x o -> o {optTablesNextToCode=x})
+_optLdOvveride :: Lens Opts (Maybe Bool)
+_optLdOvveride = Lens optLdOverride (\x o -> o {optLdOverride=x})
+
_optVerbosity :: Lens Opts Int
_optVerbosity = Lens optVerbosity (\x o -> o {optVerbosity=x})
@@ -114,6 +119,7 @@ options =
concat
[ enableDisable "unregisterised" "unregisterised backend" _optUnregisterised
, enableDisable "tables-next-to-code" "Tables-next-to-code optimisation" _optTablesNextToCode
+ , enableDisable "ld-override" "override gcc's default linker" _optLdOvveride
] ++
concat
[ progOpts "cc" "C compiler" _optCc
@@ -235,13 +241,12 @@ determineTablesNextToCode
determineTablesNextToCode archOs unreg userReq =
case userReq of
Just True
+ | not tntcSupported
+ -> throwE "Tables-next-to-code not supported by this platform"
| unreg -> throwE "Tables-next-to-code cannot be used with unregisterised code generator"
- | tntcSupported -> throwE "Tables-next-to-code not supported by this platform"
| otherwise -> return True
Just False -> return False
- Nothing
- | tntcSupported -> return True
- | otherwise -> return False
+ Nothing -> pure tntcSupported
where
tntcSupported = tablesNextToCodeSupported archOs
@@ -253,7 +258,7 @@ mkTarget opts = do
archOs <- parseTriple cc0 (optTriple opts)
cc <- addPlatformDepCcFlags archOs cc0
readelf <- optional $ findReadelf (optReadelf opts)
- ccLink <- findCcLink (optCcLink opts) archOs cc readelf
+ ccLink <- findCcLink (optCcLink opts) (optLdOverride opts) archOs cc readelf
ar <- findAr (optAr opts)
ranlib <- if arNeedsRanlib ar
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/102ae4bc247076c8e70b57c5cec00c5dc82feaaf...f02181995fcccea4e456431db8698dfd7a1309d6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/102ae4bc247076c8e70b57c5cec00c5dc82feaaf...f02181995fcccea4e456431db8698dfd7a1309d6
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230501/a2ac20cf/attachment-0001.html>
More information about the ghc-commits
mailing list