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