From 18e5103f0f73570e31421e67e54f1693936f5efd Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Fri, 25 Feb 2022 16:28:23 -0500
Subject: [PATCH] testsuite: More robust library way detection
Previously `test.mk` would try to determine whether the dynamic,
profiling, and vanilla library ways are available by searching for
`PrimOpWrappers.{,dyn_,p_}hi` in directory reported by `ghc-pkg field
ghc-prim library-dirs`. However, this is extremely fragile as
there is no guarantee that there is only one library directory. To
handle the case of multiple `library-dirs` correct we would
have to carry out the delicate task of tokenising the directory list (in
shell, no less).
Since this isn't a task that I am eager to solve, I have rather moved
the detection logic into the testsuite driver and instead perform a test
compilation in each of the ways. This should be more robust than the
previous approach.
I stumbled upon this while fixing #20579.
---
hadrian/src/Settings/Builders/RunTest.hs | 72 ++----------------------
testsuite/config/ghc | 41 +++++++++++---
testsuite/mk/test.mk | 22 --------
3 files changed, 38 insertions(+), 97 deletions(-)
diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs
index 76dc04133a55..33d09737c358 100644
--- a/hadrian/src/Settings/Builders/RunTest.hs
+++ b/hadrian/src/Settings/Builders/RunTest.hs
@@ -57,7 +57,6 @@ runTestGhcFlags = do
data TestCompilerArgs = TestCompilerArgs{
hasDynamicRts, hasThreadedRts :: Bool
- , libWays :: Set.Set Way
, hasDynamic :: Bool
, leadingUnderscore :: Bool
, withNativeCodeGen :: Bool
@@ -86,7 +85,6 @@ inTreeCompilerArgs stg = do
(hasDynamicRts, hasThreadedRts) <- do
ways <- interpretInContext (Context stg rts vanilla) getRtsWays
return (dynamic `elem` ways, threaded `elem` ways)
- libWays <- interpretInContext (Context stg compiler vanilla) getLibraryWays
-- MP: We should be able to vary if stage1/stage2 is dynamic, ie a dynamic stage1
-- should be able to built a static stage2?
hasDynamic <- flavour >>= dynamicGhcPrograms
@@ -126,14 +124,13 @@ ghcConfigPath = "test/ghcconfig"
-- | If the compiler is out-of-tree then we have to query the compiler to work out
-- facts about it.
-outOfTreeCompilerArgs :: String -> Action TestCompilerArgs
-outOfTreeCompilerArgs testGhc = do
+outOfTreeCompilerArgs :: Action TestCompilerArgs
+outOfTreeCompilerArgs = do
root <- buildRoot
need [root -/- ghcConfigPath]
(hasDynamicRts, hasThreadedRts) <- do
ways <- testRTSSettings
return ("dyn" `elem` ways, "thr" `elem` ways)
- libWays <- inferLibraryWays testGhc
hasDynamic <- getBooleanSetting TestGhcDynamic
leadingUnderscore <- getBooleanSetting TestLeadingUnderscore
withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen
@@ -162,9 +159,8 @@ outOfTreeCompilerArgs testGhc = do
-- thing
assertSameCompilerArgs :: Stage -> Action ()
assertSameCompilerArgs stg = do
- test_ghc <- testCompiler <$> userSetting defaultTestArgs
in_args <- inTreeCompilerArgs stg
- out_args <- outOfTreeCompilerArgs test_ghc
+ out_args <- outOfTreeCompilerArgs
-- The assertion to check we calculated the right thing
when (in_args /= out_args) $ putFailure $ unlines $
[ "Hadrian assertion failure: in-tree arguments don't match out-of-tree arguments."
@@ -190,7 +186,7 @@ runTestBuilderArgs = builder Testsuite ? do
TestCompilerArgs{..} <- expr $
case stageOfTestCompiler testGhc of
Just stg -> inTreeCompilerArgs stg
- Nothing -> outOfTreeCompilerArgs testGhc
+ Nothing -> outOfTreeCompilerArgs
-- MP: TODO, these should be queried from the test compiler?
bignumBackend <- getBignumBackend
@@ -220,8 +216,6 @@ runTestBuilderArgs = builder Testsuite ? do
let asBool :: String -> Bool -> String
asBool s b = s ++ show b
- hasLibWay w = elem w libWays
-
-- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
mconcat [ arg $ "testsuite/driver/runtests.py"
, pure [ "--rootdir=" ++ testdir | testdir <- rootdirs ]
@@ -256,9 +250,6 @@ runTestBuilderArgs = builder Testsuite ? do
, arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
, arg "-e", arg $ asBool "ghc_with_dynamic_rts=" (hasDynamicRts)
, arg "-e", arg $ asBool "ghc_with_threaded_rts=" (hasThreadedRts)
- , arg "-e", arg $ asBool "config.have_vanilla=" (hasLibWay vanilla)
- , arg "-e", arg $ asBool "config.have_dynamic=" (hasLibWay dynamic)
- , arg "-e", arg $ asBool "config.have_profiling=" (hasLibWay profiling)
, arg "-e", arg $ asBool "config.have_fast_bignum=" (bignumBackend /= "native" && not bignumCheck)
, arg "-e", arg $ asBool "ghc_with_smp=" withSMP
@@ -360,58 +351,3 @@ setTestSpeed :: TestSpeed -> String
setTestSpeed TestSlow = "0"
setTestSpeed TestNormal = "1"
setTestSpeed TestFast = "2"
-
--- | The purpose of this function is, given a compiler
--- (stage 1, 2, 3 or an external one), to infer the ways
--- that the libraries have been built in.
---
--- While we have this data readily available for in-tree compilers
--- that we build (through the 'Flavour'), that is not the case for
--- out-of-tree compilers that we may want to test, as is the case when
--- we are running './validate --hadrian' (it packages up a binary
--- distribution, installs it somewhere near and tests it).
---
--- We therefore proceed in a way that works regardless of whether we are
--- dealing with an in-tree compiler or not: we ask the GHC's install
--- ghc-pkg to give us the library directory of its @ghc-prim@ package and
--- look at what ways are available for the interface file of the
--- @GHC.PrimopWrappers@ module, like the Make build system does in
--- @testsuite\/mk\/test.mk@ to compute @HAVE_DYNAMIC@, @HAVE_VANILLA@
--- and @HAVE_PROFILING@:
---
--- - if we find @PrimopWrappers.hi@, we have the vanilla way;
--- - if we find @PrimopWrappers.dyn_hi@, we have the dynamic way;
--- - if we find @PrimopWrappers.p_hi@, we have the profiling way.
-inferLibraryWays :: String -> Action (Set.Set Way)
-inferLibraryWays compiler = do
- bindir <- getBinaryDirectory compiler
- Stdout ghcPrimLibdirDirty <- cmd
- [bindir </> "ghc-pkg" <.> exe]
- ["field", "ghc-prim", "library-dirs", "--simple-output"]
- let ghcPrimLibdir = fixup ghcPrimLibdirDirty
- ways <- Set.fromList . catMaybes <$> traverse (lookForWay ghcPrimLibdir) candidateWays
- return ways
-
- where lookForWay dir (hifile, w) = do
- exists <- doesFileExist (dir -/- hifile)
- if exists then return (Just w) else return Nothing
-
- candidateWays =
- [ ("GHC/PrimopWrappers.hi", vanilla)
- , ("GHC/PrimopWrappers.dyn_hi", dynamic)
- , ("GHC/PrimopWrappers.p_hi", profiling)
- ]
-
- -- If the ghc is in a directory with spaces in a path component,
- -- 'dir' is prefixed and suffixed with double quotes.
- -- In all cases, there is a \n at the end.
- -- This function cleans it all up.
- fixup = removeQuotes . removeNewline
-
- removeNewline path
- | "\n" `isSuffixOf` path = init path
- | otherwise = path
-
- removeQuotes path
- | "\"" `isPrefixOf` path && "\"" `isSuffixOf` path = tail (init path)
- | otherwise = path
diff --git a/testsuite/config/ghc b/testsuite/config/ghc
index d33101fef802..79dd1b02946d 100644
--- a/testsuite/config/ghc
+++ b/testsuite/config/ghc
@@ -37,10 +37,6 @@ if ghc_with_native_codegen:
config.compile_ways.append('optasm')
config.run_ways.append('optasm')
-if config.have_profiling:
- config.compile_ways.append('profasm')
- config.run_ways.append('profasm')
-
if config.have_interp:
config.run_ways.append('ghci')
@@ -60,9 +56,6 @@ if windows:
config.supports_dynamic_hs = False
config.stdcxx_impl = 'c++'
-if (config.have_profiling and ghc_with_threaded_rts):
- config.run_ways.append('profthreaded')
-
# WinIO I/O manager for Windows
if windows:
winio_ways = ['winio', 'winio_threaded']
@@ -210,6 +203,40 @@ def get_compiler_info():
# See Note [Replacing backward slashes in config.libdir].
config.libdir = config.libdir.replace('\\', '/')
+ def test_compile(flags) -> bool:
+ """
+ Check whether GHC can compile in the given way.
+ This is used as a proxy to determine, e.g., whether
+ profiled libraries were built.
+ """
+ import tempfile
+ import textwrap
+ with tempfile.TemporaryDirectory() as d:
+ src = Path(d) / 'test.hs'
+ src.write_text(textwrap.dedent('''
+ module Main where
+ main = putStrLn "Hello World!"
+ '''))
+ p = subprocess.run(
+ '{} -v0 {} -o test '.format(config.compiler, src) + ' '.join(flags),
+ shell=True,
+ cwd=d,
+ stderr=None if config.verbose >= 2 else subprocess.DEVNULL)
+ res = p.returncode
+ return res == 0
+
+ config.have_vanilla = test_compile([])
+ config.have_dynamic = test_compile(['-dynamic'])
+ config.have_profiling = test_compile(['-prof'])
+
+ if config.have_profiling:
+ config.compile_ways.append('profasm')
+ config.run_ways.append('profasm')
+
+ if config.have_profiling and ghc_with_threaded_rts:
+ config.run_ways.append('profthreaded')
+ ghc_env['HAVE_PROFILING'] = 'YES'
+
# See Note [WayFlags]
if config.ghc_dynamic:
config.ghc_th_way_flags = "-dynamic"
diff --git a/testsuite/mk/test.mk b/testsuite/mk/test.mk
index dbe03286cedc..4728ab400e59 100644
--- a/testsuite/mk/test.mk
+++ b/testsuite/mk/test.mk
@@ -96,10 +96,6 @@ else
RUNTEST_OPTS += -e "config.leading_underscore=False"
endif
-GHC_PRIM_LIBDIR := $(subst library-dirs: ,,"$(shell "$(GHC_PKG)" field ghc-prim library-dirs --simple-output)")
-HAVE_VANILLA := $(shell if [ -f "$(subst \,/,$(GHC_PRIM_LIBDIR))/GHC/PrimopWrappers.hi" ]; then echo YES; else echo NO; fi)
-HAVE_DYNAMIC := $(shell if [ -f "$(subst \,/,$(GHC_PRIM_LIBDIR))/GHC/PrimopWrappers.dyn_hi" ]; then echo YES; else echo NO; fi)
-HAVE_PROFILING := $(shell if [ -f "$(subst \,/,$(GHC_PRIM_LIBDIR))/GHC/PrimopWrappers.p_hi" ]; then echo YES; else echo NO; fi)
HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi)
HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi)
@@ -107,24 +103,6 @@ HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo
# used
BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP)
-ifeq "$(HAVE_VANILLA)" "YES"
-RUNTEST_OPTS += -e config.have_vanilla=True
-else
-RUNTEST_OPTS += -e config.have_vanilla=False
-endif
-
-ifeq "$(HAVE_DYNAMIC)" "YES"
-RUNTEST_OPTS += -e config.have_dynamic=True
-else
-RUNTEST_OPTS += -e config.have_dynamic=False
-endif
-
-ifeq "$(HAVE_PROFILING)" "YES"
-RUNTEST_OPTS += -e config.have_profiling=True
-else
-RUNTEST_OPTS += -e config.have_profiling=False
-endif
-
ifeq "$(filter thr, $(GhcRTSWays))" "thr"
RUNTEST_OPTS += -e ghc_with_threaded_rts=True
else
--
GitLab