[Git][ghc/ghc][wip/toolchain-selection] ghc-toolchain: Rename readProcess to readProcessStdout
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon May 1 16:15:09 UTC 2023
Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC
Commits:
102ae4bc by Rodrigo Mesquita at 2023-05-01T17:14:57+01:00
ghc-toolchain: Rename readProcess to readProcessStdout
Fixes a bug regarding a translation from the 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.
- - - - -
6 changed files:
- 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
Changes:
=====================================
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,8 +59,16 @@ 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 $ 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
liftIO $ readProcess (prgPath prog) (prgFlags 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
=====================================
@@ -77,8 +77,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 +119,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
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/102ae4bc247076c8e70b57c5cec00c5dc82feaaf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/102ae4bc247076c8e70b57c5cec00c5dc82feaaf
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/c5fbbf95/attachment-0001.html>
More information about the ghc-commits
mailing list