[Git][ghc/ghc][wip/req_smp] ghc-config: add GhcRTSWithSMP flag
doyougnu (@doyougnu)
gitlab at gitlab.haskell.org
Tue Dec 20 23:22:12 UTC 2022
doyougnu pushed to branch wip/req_smp at Glasgow Haskell Compiler / GHC
Commits:
6fe2dd6d by doyougnu at 2022-12-20T18:21:23-05:00
ghc-config: add GhcRTSWithSMP flag
- - - - -
3 changed files:
- hadrian/src/Oracles/TestSettings.hs
- hadrian/src/Settings/Builders/RunTest.hs
- testsuite/ghc-config/ghc-config.hs
Changes:
=====================================
hadrian/src/Oracles/TestSettings.hs
=====================================
@@ -32,6 +32,7 @@ data TestSetting = TestHostOS
| TestGhcWithRtsLinker
| TestGhcUnregisterised
| TestGhcWithSMP
+ | TestGhcRTSWithSMP
| TestGhcDynamic
| TestGhcProfiled
| TestAR
@@ -62,6 +63,7 @@ testSetting key = do
TestGhcWithRtsLinker -> "GhcWithRtsLinker"
TestGhcUnregisterised -> "GhcUnregisterised"
TestGhcWithSMP -> "GhcWithSMP"
+ TestGhcRTSWithSMP -> "GhcRTSWithSMP"
TestGhcDynamic -> "GhcDynamic"
TestGhcProfiled -> "GhcProfiled"
TestAR -> "AR"
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -68,8 +68,8 @@ data TestCompilerArgs = TestCompilerArgs{
, withInterpreter :: Bool
, unregisterised :: Bool
, tables_next_to_code :: Bool
- , targetWithSMP :: Bool
- , bootstrapperWithSMP :: Bool
+ , targetWithSMP :: Bool -- test compiler can produce threaded programs
+ , bootstrapperWithSMP :: Bool -- test compiler is linked with a threaded RTS
, debugAssertions :: Bool
-- ^ Whether the compiler has debug assertions enabled,
-- corresponding to the -DDEBUG option.
@@ -148,7 +148,7 @@ outOfTreeCompilerArgs = do
withInterpreter <- getBooleanSetting TestGhcWithInterpreter
unregisterised <- getBooleanSetting TestGhcUnregisterised
tables_next_to_code <- getBooleanSetting TestGhcUnregisterised
- bootstrapperWithSMP <- getBooleanSetting TestGhcWithSMP
+ bootstrapperWithSMP <- getBooleanSetting TestGhcRTSWithSMP
targetWithSMP <- getBooleanSetting TestGhcWithSMP
debugAssertions <- getBooleanSetting TestGhcDebugged
@@ -267,8 +267,11 @@ runTestBuilderArgs = builder Testsuite ? do
, arg "-e", arg $ asBool "ghc_with_threaded_rts=" (hasThreadedRts)
, arg "-e", arg $ asBool "config.have_fast_bignum=" (bignumBackend /= "native" && not bignumCheck)
, arg "-e", arg $ asBool "ghc_with_smp=" (if stageNumber (C.stage ctx) == 1 || isCross
- then targetWithSMP
- else bootstrapperWithSMP)
+ -- cross compilers are a special case, for example in the JS
+ -- backend GHC is linked with a SMP'd RTS, but the target does
+ -- not support SMP
+ then bootstrapperWithSMP
+ else targetWithSMP)
, arg "-e", arg $ asBool "target_with_smp=" targetWithSMP
, arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
=====================================
testsuite/ghc-config/ghc-config.hs
=====================================
@@ -2,41 +2,43 @@ import System.Environment
import System.Process
import Data.Maybe
+import qualified Data.List as L
+
main :: IO ()
main = do
[ghc] <- getArgs
info <- readProcess ghc ["+RTS", "--info"] ""
let fields = read info :: [(String,String)]
- getGhcFieldOrFail fields "HostOS" "Host OS"
- getGhcFieldOrFail fields "WORDSIZE" "Word size"
+ getGhcFieldOrFail fields "HostOS" "Host OS"
+ getGhcFieldOrFail fields "WORDSIZE" "Word size"
getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform"
- getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
+ getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture"
+ getGhcRTSWithSMP fields "GhcRTSWithSMP" "RTS way"
info <- readProcess ghc ["--info"] ""
let fields = read info :: [(String,String)]
- getGhcFieldOrFail fields "GhcStage" "Stage"
- getGhcFieldOrFail fields "GhcDebugged" "Debug on"
+ getGhcFieldOrFail fields "GhcStage" "Stage"
+ getGhcFieldOrFail fields "GhcDebugged" "Debug on"
getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
- getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
- getGhcFieldOrFail fields "GhcWithRtsLinker" "target has RTS linker"
- getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised"
- getGhcFieldOrFail fields "GhcWithSMP" "Support SMP"
- getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
- getGhcFieldOrFail fields "GhcLibdir" "LibDir"
- getGhcFieldOrFail fields "GhcGlobalPackageDb" "Global Package DB"
- getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO"
- getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO"
- getGhcFieldOrDefault fields "LeadingUnderscore" "Leading underscore" "NO"
+ getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
+ getGhcFieldOrFail fields "GhcWithRtsLinker" "target has RTS linker"
+ getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised"
+ getGhcFieldOrFail fields "GhcWithSMP" "Support SMP"
+ getGhcFieldOrFail fields "GhcLibdir" "LibDir"
+ getGhcFieldOrFail fields "GhcGlobalPackageDb" "Global Package DB"
+ getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO"
+ getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO"
+ getGhcFieldOrDefault fields "LeadingUnderscore" "Leading underscore" "NO"
getGhcFieldOrDefault fields "GhcTablesNextToCode" "Tables next to code" "NO"
- getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
- getGhcFieldProgWithDefault fields "CLANG" "LLVM clang command" "clang"
- getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc"
- getGhcFieldProgWithDefault fields "TEST_CC" "C compiler command" "gcc"
- getGhcFieldProgWithDefault fields "TEST_CC_OPTS" "C compiler flags" ""
- getGhcFieldProgWithDefault fields "TEST_CXX" "C++ compiler command" "g++"
+ getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
+ getGhcFieldProgWithDefault fields "CLANG" "LLVM clang command" "clang"
+ getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc"
+ getGhcFieldProgWithDefault fields "TEST_CC" "C compiler command" "gcc"
+ getGhcFieldProgWithDefault fields "TEST_CC_OPTS" "C compiler flags" ""
+ getGhcFieldProgWithDefault fields "TEST_CXX" "C++ compiler command" "g++"
getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO ()
getGhcFieldOrFail fields mkvar key
@@ -85,3 +87,12 @@ parseVersion v = case break (== '.') v of
[] -> []
('.':v') -> parseVersion v'
_ -> error "bug in parseVersion"
+
+-- | Specialty function for determining if the RTS the test compiler is linked
+-- with is threaded and thus supports SMP. Should be equivalent to
+-- 'ghc +RTS --info | grep "RTS way" | grep thr'
+getGhcRTSWithSMP :: [(String,String)] -> String -> String -> IO ()
+getGhcRTSWithSMP fields mkvar key
+ = getGhcField fields mkvar key go (fail ("No field: " ++ key))
+ where go s | "thr" `L.isInfixOf` s = "YES"
+ | otherwise = "NO"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6fe2dd6dba905e13a9dd8c0e1a48aa81ba137cd4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6fe2dd6dba905e13a9dd8c0e1a48aa81ba137cd4
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/20221220/3f710edc/attachment-0001.html>
More information about the ghc-commits
mailing list