ae85cf57a863e4d038ee5f46e16a83b4cdf3f61d
[ghc.git] / hadrian / src / Settings / Builders / RunTest.hs
1 module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags) where
2
3 import Hadrian.Utilities
4 import System.Environment
5
6 import CommandLine
7 import Flavour
8 import Oracles.Setting (setting)
9 import Oracles.TestSettings
10 import Packages
11 import Settings.Builders.Common
12
13 getTestSetting :: TestSetting -> Expr String
14 getTestSetting key = expr $ testSetting key
15
16 -- | Parse the value of a Boolean test setting or report an error.
17 getBooleanSetting :: TestSetting -> Expr Bool
18 getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key
19 where
20 msg = "Cannot parse test setting " ++ quote (show key)
21
22 -- | Extra flags to send to the Haskell compiler to run tests.
23 runTestGhcFlags :: Action String
24 runTestGhcFlags = do
25 unregisterised <- flag GhcUnregisterised
26
27 let ifMinGhcVer ver opt = do v <- ghcCanonVersion
28 if ver <= v then pure opt
29 else pure ""
30
31 -- Read extra argument for test from command line, like `-fvectorize`.
32 ghcOpts <- fromMaybe "" <$> (liftIO $ lookupEnv "EXTRA_HC_OPTS")
33
34 -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L28
35 let ghcExtraFlags = if unregisterised
36 then "-optc-fno-builtin"
37 else ""
38
39 -- Take flags to send to the Haskell compiler from test.mk.
40 -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37
41 unwords <$> sequence
42 [ pure " -dcore-lint -dstg-lint -dcmm-lint -no-user-package-db -rtsopts"
43 , pure ghcOpts
44 , pure ghcExtraFlags
45 , ifMinGhcVer "711" "-fno-warn-missed-specialisations"
46 , ifMinGhcVer "711" "-fshow-warning-groups"
47 , ifMinGhcVer "801" "-fdiagnostics-color=never"
48 , ifMinGhcVer "801" "-fno-diagnostics-show-caret"
49 , pure "-Werror=compat" -- See Trac #15278
50 , pure "-dno-debug-output"
51 ]
52
53 -- Command line arguments for invoking the @runtest.py@ script. A lot of this
54 -- mirrors @testsuite/mk/test.mk@.
55 runTestBuilderArgs :: Args
56 runTestBuilderArgs = builder RunTest ? do
57 pkgs <- expr $ stagePackages Stage1
58 libTests <- expr $ filterM doesDirectoryExist $ concat
59 [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
60 | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
61
62 testGhc <- expr (testCompiler <$> userSetting defaultTestArgs)
63 rtsWays <- expr testRTSSettings
64 libWays <- expr (inferLibraryWays testGhc)
65 let hasRtsWay w = elem w rtsWays
66 hasLibWay w = elem w libWays
67 hasDynamic <- getBooleanSetting TestGhcDynamic
68 hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault
69 withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen
70 withInterpreter <- getBooleanSetting TestGhcWithInterpreter
71 unregisterised <- getBooleanSetting TestGhcUnregisterised
72 withSMP <- getBooleanSetting TestGhcWithSMP
73 debugged <- read <$> getTestSetting TestGhcDebugged
74 keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs)
75
76 windows <- expr windowsHost
77 darwin <- expr osxHost
78 threads <- shakeThreads <$> expr getShakeOptions
79 os <- getTestSetting TestHostOS
80 arch <- getTestSetting TestTargetARCH_CPP
81 platform <- getTestSetting TestTARGETPLATFORM
82 wordsize <- getTestSetting TestWORDSIZE
83 top <- expr $ topDirectory
84 ghcFlags <- expr runTestGhcFlags
85 timeoutProg <- expr buildRoot <&> (-/- timeoutPath)
86
87 -- See #16087
88 let ghcBuiltByLlvm = False -- TODO: Implement this check
89
90 let asZeroOne s b = s ++ zeroOne b
91
92 -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
93 mconcat [ arg $ "testsuite/driver/runtests.py"
94 , arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
95 , pure ["--rootdir=" ++ test | test <- libTests]
96 , arg "-e", arg $ "windows=" ++ show windows
97 , arg "-e", arg $ "darwin=" ++ show darwin
98 , arg "-e", arg $ "config.local=False"
99 , arg "-e", arg $ "config.cleanup=" ++ show (not keepFiles)
100 , arg "-e", arg $ "config.exeext=" ++ quote exe
101 , arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
102 , arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
103 , arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen
104
105 , arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
106 , arg "-e", arg $ "config.unregisterised=" ++ show unregisterised
107
108 , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
109 , arg "-e", arg $ asZeroOne "ghc_with_dynamic_rts=" (hasRtsWay "dyn")
110 , arg "-e", arg $ asZeroOne "ghc_with_threaded_rts=" (hasRtsWay "thr")
111 , arg "-e", arg $ asZeroOne "config.have_vanilla=" (hasLibWay vanilla)
112 , arg "-e", arg $ asZeroOne "config.have_dynamic=" (hasLibWay dynamic)
113 , arg "-e", arg $ asZeroOne "config.have_profiling=" (hasLibWay profiling)
114 , arg "-e", arg $ asZeroOne "ghc_with_smp=" withSMP
115 , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
116
117 , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
118 , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
119 , arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm
120
121 , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
122 , arg "-e", arg $ "config.wordsize=" ++ show wordsize
123 , arg "-e", arg $ "config.os=" ++ show os
124 , arg "-e", arg $ "config.arch=" ++ show arch
125 , arg "-e", arg $ "config.platform=" ++ show platform
126
127 , arg "--config", arg $ "gs=gs" -- Use the default value as in test.mk
128 , arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg)
129 , arg $ "--threads=" ++ show threads
130 , getTestArgs -- User-provided arguments from command line.
131 ]
132
133 -- | Command line arguments for running GHC's test script.
134 getTestArgs :: Args
135 getTestArgs = do
136 -- targets specified in the TEST env var
137 testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
138 args <- expr $ userSetting defaultTestArgs
139 bindir <- expr $ getBinaryDirectory (testCompiler args)
140 compiler <- expr $ getCompilerPath (testCompiler args)
141 globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
142 let configFileArg= ["--config-file=" ++ (testConfigFile args)]
143 testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets)
144 onlyPerfArg = if testOnlyPerf args
145 then Just "--only-perf-tests"
146 else Nothing
147 skipPerfArg = if testSkipPerf args
148 then Just "--skip-perf-tests"
149 else Nothing
150 speedArg = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
151 summaryArg = case testSummary args of
152 Just filepath -> Just $ "--summary-file " ++ show filepath
153 Nothing -> Just $ "--summary-file=testsuite_summary.txt"
154 junitArg = case testJUnit args of
155 Just filepath -> Just $ "--junit=" ++ filepath
156 Nothing -> Nothing
157 configArgs = concat [["-e", configArg] | configArg <- testConfigs args]
158 verbosityArg = case testVerbosity args of
159 Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
160 Just verbosity -> Just $ "--verbose=" ++ verbosity
161 wayArgs = map ("--way=" ++) (testWays args)
162 compilerArg = ["--config", "compiler=" ++ show (compiler)]
163 ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
164 haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
165 hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
166 hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
167 inTreeArg = [ "-e", "config.in_tree_compiler=" ++
168 show (testCompiler args `elem` ["stage1", "stage2", "stage3"]) ]
169
170 pure $ configFileArg ++ testOnlyArg ++ speedArg
171 ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
172 , junitArg, verbosityArg ]
173 ++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
174 ++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
175
176 -- | Set speed for test
177 setTestSpeed :: TestSpeed -> String
178 setTestSpeed TestSlow = "0"
179 setTestSpeed TestNormal = "1"
180 setTestSpeed TestFast = "2"
181
182 -- | The purpose of this function is, given a compiler
183 -- (stage 1, 2, 3 or an external one), to infer the ways
184 -- that the libraries have been built in.
185 --
186 -- While we have this data readily available for in-tree compilers
187 -- that we build (through the 'Flavour'), that is not the case for
188 -- out-of-tree compilers that we may want to test, as is the case when
189 -- we are running './validate --hadrian' (it packages up a binary
190 -- distribution, installs it somewhere near and tests it).
191 --
192 -- We therefore proceed in a way that works regardless of whether we are
193 -- dealing with an in-tree compiler or not: we ask the GHC's install
194 -- ghc-pkg to give us the library directory of its @ghc-prim@ package and
195 -- look at what ways are available for the interface file of the
196 -- @GHC.PrimopWrappers@ module, like the Make build system does in
197 -- @testsuite\/mk\/test.mk@ to compute @HAVE_DYNAMIC@, @HAVE_VANILLA@
198 -- and @HAVE_PROFILING@:
199 --
200 -- - if we find @PrimopWrappers.hi@, we have the vanilla way;
201 -- - if we find @PrimopWrappers.dyn_hi@, we have the dynamic way;
202 -- - if we find @PrimopWrappers.p_hi@, we have the profiling way.
203 inferLibraryWays :: String -> Action [Way]
204 inferLibraryWays compiler = do
205 bindir <- getBinaryDirectory compiler
206 Stdout ghcPrimLibdirDirty <- cmd
207 [bindir </> "ghc-pkg" <.> exe]
208 ["field", "ghc-prim", "library-dirs", "--simple-output"]
209 let ghcPrimLibdir = fixup ghcPrimLibdirDirty
210 ways <- catMaybes <$> traverse (lookForWay ghcPrimLibdir) candidateWays
211 return ways
212
213 where lookForWay dir (hifile, w) = do
214 exists <- doesFileExist (dir -/- hifile)
215 if exists then return (Just w) else return Nothing
216
217 candidateWays =
218 [ ("GHC/PrimopWrappers.hi", vanilla)
219 , ("GHC/PrimopWrappers.dyn_hi", dynamic)
220 , ("GHC/PrimopWrappers.p_hi", profiling)
221 ]
222
223 -- If the ghc is in a directory with spaces in a path component,
224 -- 'dir' is prefixed and suffixed with double quotes.
225 -- In all cases, there is a \n at the end.
226 -- This function cleans it all up.
227 fixup = removeQuotes . removeNewline
228
229 removeNewline path
230 | "\n" `isSuffixOf` path = init path
231 | otherwise = path
232
233 removeQuotes path
234 | "\"" `isPrefixOf` path && "\"" `isSuffixOf` path = tail (init path)
235 | otherwise = path