1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags) where
import Hadrian.Utilities hiding (Normal)
import System.Environment
import CommandLine
import Flavour
import Oracles.TestSettings
import Packages
import Settings.Builders.Common hiding (Normal)
getTestSetting :: TestSetting -> Expr String
getTestSetting key = expr $ testSetting key
-- | Parse the value of a Boolean test setting or report an error.
getBooleanSetting :: TestSetting -> Expr Bool
getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key
where
msg = "Cannot parse test setting " ++ quote (show key)
-- | Extra flags to send to the Haskell compiler to run tests.
runTestGhcFlags :: Action String
runTestGhcFlags = do
unregisterised <- flag GhcUnregisterised
let ifMinGhcVer ver opt = do v <- ghcCanonVersion
if ver <= v then pure opt
else pure ""
-- Read extra argument for test from command line, like `-fvectorize`.
ghcOpts <- fromMaybe "" <$> (liftIO $ lookupEnv "EXTRA_HC_OPTS")
-- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L28
let ghcExtraFlags = if unregisterised
then "-optc-fno-builtin"
else ""
-- Take flags to send to the Haskell compiler from test.mk.
-- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37
unwords <$> sequence
[ pure "-dcore-lint -dstg-lint -dcmm-lint"
, pure "-no-user-package-db -rtsopts"
, pure ghcOpts
, pure ghcExtraFlags
, ifMinGhcVer "711" "-fno-warn-missed-specialisations"
, ifMinGhcVer "711" "-fshow-warning-groups"
, ifMinGhcVer "801" "-fdiagnostics-color=never"
, ifMinGhcVer "801" "-fno-diagnostics-show-caret"
, pure "-Werror=compat"
, pure "-dno-debug-output"
]
-- Command line arguments for invoking the @runtest.py@ script. A lot of this
-- mirrors @testsuite/mk/test.mk@.
runTestBuilderArgs :: Args
runTestBuilderArgs = builder RunTest ? do
pkgs <- expr $ stagePackages Stage1
libTests <- expr $ filterM doesDirectoryExist $ concat
[ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
| pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
testGhc <- expr (testCompiler <$> userSetting defaultTestArgs)
flav <- expr flavour
rtsWays <- expr testRTSSettings
libWays <- expr (inferLibraryWays testGhc)
let hasRtsWay w = elem w rtsWays
hasLibWay w = elem w libWays
hasDynamic <- getBooleanSetting TestGhcDynamic
hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault
withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen
withInterpreter <- getBooleanSetting TestGhcWithInterpreter
unregisterised <- getBooleanSetting TestGhcUnregisterised
withSMP <- getBooleanSetting TestGhcWithSMP
debugged <- read <$> getTestSetting TestGhcDebugged
windows <- expr windowsHost
darwin <- expr osxHost
threads <- shakeThreads <$> expr getShakeOptions
os <- getTestSetting TestHostOS
arch <- getTestSetting TestTargetARCH_CPP
platform <- getTestSetting TestTARGETPLATFORM
wordsize <- getTestSetting TestWORDSIZE
top <- expr $ topDirectory
ghcFlags <- expr runTestGhcFlags
timeoutProg <- expr buildRoot <&> (-/- timeoutPath)
-- See #16087
let ghcBuiltByLlvm = False -- TODO: Implement this check
let asZeroOne s b = s ++ zeroOne b
-- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
mconcat [ arg $ "testsuite/driver/runtests.py"
, arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
, pure ["--rootdir=" ++ test | test <- libTests]
, arg "-e", arg $ "windows=" ++ show windows
, arg "-e", arg $ "darwin=" ++ show darwin
, arg "-e", arg $ "config.local=False"
, arg "-e", arg $ "config.exeext=" ++
show (if windows then "exe" else "")
, arg "-e", arg $ "config.cleanup=False" -- Don't clean up for now.
, arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen
, arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
, arg "-e", arg $ "config.unregisterised=" ++ show unregisterised
, arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
, arg "-e", arg $ asZeroOne "ghc_with_dynamic_rts=" (hasRtsWay "dyn")
, arg "-e", arg $ asZeroOne "ghc_with_threaded_rts=" (hasRtsWay "thr")
, arg "-e", arg $ asZeroOne "config.have_vanilla=" (hasLibWay vanilla)
, arg "-e", arg $ asZeroOne "config.have_dynamic=" (hasLibWay dynamic)
, arg "-e", arg $ asZeroOne "config.have_profiling=" (hasLibWay profiling)
, arg "-e", arg $ asZeroOne "ghc_with_smp=" withSMP
, arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
, arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
, arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
, arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm
, arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
, arg "-e", arg $ "config.wordsize=" ++ show wordsize
, arg "-e", arg $ "config.os=" ++ show os
, arg "-e", arg $ "config.arch=" ++ show arch
, arg "-e", arg $ "config.platform=" ++ show platform
, arg "--config", arg $ "gs=gs" -- Use the default value as in test.mk
, arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg)
, arg $ "--threads=" ++ show threads
, getTestArgs -- User-provided arguments from command line.
]
-- | Command line arguments for running GHC's test script.
getTestArgs :: Args
getTestArgs = do
-- targets specified in the TEST env var
testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
args <- expr $ userSetting defaultTestArgs
bindir <- expr $ getBinaryDirectory (testCompiler args)
compiler <- expr $ getCompilerPath (testCompiler args)
globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
let configFileArg= ["--config-file=" ++ (testConfigFile args)]
testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets)
onlyPerfArg = if testOnlyPerf args
then Just "--only-perf-tests"
else Nothing
skipPerfArg = if testSkipPerf args
then Just "--skip-perf-tests"
else Nothing
speedArg = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
summaryArg = case testSummary args of
Just filepath -> Just $ "--summary-file \"" ++ filepath ++ "\""
Nothing -> Just $ "--summary-file=testsuite_summary.txt"
junitArg = case testJUnit args of
Just filepath -> Just $ "--junit=" ++ filepath
Nothing -> Nothing
configArgs = concat [["-e", configArg] | configArg <- testConfigs args]
verbosityArg = case testVerbosity args of
Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
Just verbosity -> Just $ "--verbose=" ++ verbosity
wayArgs = map ("--way=" ++) (testWays args)
compilerArg = ["--config", "compiler=" ++ show (compiler)]
ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
inTreeArg = [ "-e", "config.in_tree_compiler="
++ show (testCompiler args `elem` ["stage1", "stage2"]) ]
pure $ configFileArg ++ testOnlyArg ++ speedArg
++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
, junitArg, verbosityArg ]
++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
-- | Set speed for test
setTestSpeed :: TestSpeed -> String
setTestSpeed Slow = "0"
setTestSpeed Normal = "1"
setTestSpeed Fast = "2"
inferLibraryWays :: String -> Action [Way]
inferLibraryWays compiler = do
bindir <- getBinaryDirectory compiler
Stdout ghcPrimLibdir <- cmd [Cwd bindir]
("ghc-pkg")
["field", "ghc-prim", "library-dirs", "--simple-output"]
catMaybes <$> traverse (lookForWay ghcPrimLibdir) candidateWays
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)
]
|
