Hadrian: use the testsuite driver's config.haddock arg more correctly
[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 #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 <- readBool <$> getTestSetting TestGhcDebugged
72 keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs)
73
74 accept <- expr (testAccept <$> userSetting defaultTestArgs)
75 (acceptPlatform, acceptOS) <- expr . liftIO $
76 (,) <$> (maybe False (=="YES") <$> lookupEnv "PLATFORM")
77 <*> (maybe False (=="YES") <$> lookupEnv "OS")
78
79 windows <- expr windowsHost
80 darwin <- expr osxHost
81 threads <- shakeThreads <$> expr getShakeOptions
82 os <- getTestSetting TestHostOS
83 arch <- getTestSetting TestTargetARCH_CPP
84 platform <- getTestSetting TestTARGETPLATFORM
85 wordsize <- getTestSetting TestWORDSIZE
86 top <- expr $ topDirectory
87 ghcFlags <- expr runTestGhcFlags
88 timeoutProg <- expr buildRoot <&> (-/- timeoutPath)
89
90 -- See #16087
91 let ghcBuiltByLlvm = False -- TODO: Implement this check
92
93 let asZeroOne s b = s ++ zeroOne b
94
95 -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
96 mconcat [ arg $ "testsuite/driver/runtests.py"
97 , arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
98 , pure ["--rootdir=" ++ test | test <- libTests]
99 , arg "-e", arg $ "windows=" ++ show windows
100 , arg "-e", arg $ "darwin=" ++ show darwin
101 , arg "-e", arg $ "config.local=False"
102 , arg "-e", arg $ "config.cleanup=" ++ show (not keepFiles)
103 , arg "-e", arg $ "config.accept=" ++ show accept
104 , arg "-e", arg $ "config.accept_platform=" ++ show acceptPlatform
105 , arg "-e", arg $ "config.accept_os=" ++ show acceptOS
106 , arg "-e", arg $ "config.exeext=" ++ quote exe
107 , arg "-e", arg $ "config.compiler_debugged=" ++
108 show debugged
109 , arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen
110
111 , arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
112 , arg "-e", arg $ "config.unregisterised=" ++ show unregisterised
113
114 , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
115 , arg "-e", arg $ asZeroOne "ghc_with_dynamic_rts=" (hasRtsWay "dyn")
116 , arg "-e", arg $ asZeroOne "ghc_with_threaded_rts=" (hasRtsWay "thr")
117 , arg "-e", arg $ asZeroOne "config.have_vanilla=" (hasLibWay vanilla)
118 , arg "-e", arg $ asZeroOne "config.have_dynamic=" (hasLibWay dynamic)
119 , arg "-e", arg $ asZeroOne "config.have_profiling=" (hasLibWay profiling)
120 , arg "-e", arg $ asZeroOne "ghc_with_smp=" withSMP
121 , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
122
123 , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
124 , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
125 , arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm
126
127 , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
128 , arg "-e", arg $ "config.wordsize=" ++ show wordsize
129 , arg "-e", arg $ "config.os=" ++ show os
130 , arg "-e", arg $ "config.arch=" ++ show arch
131 , arg "-e", arg $ "config.platform=" ++ show platform
132
133 , arg "--config", arg $ "gs=gs" -- Use the default value as in test.mk
134 , arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg)
135 , arg $ "--threads=" ++ show threads
136 , getTestArgs -- User-provided arguments from command line.
137 ]
138
139 where readBool x = read x :: Bool
140
141 -- | Command line arguments for running GHC's test script.
142 getTestArgs :: Args
143 getTestArgs = do
144 -- targets specified in the TEST env var
145 testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
146 args <- expr $ userSetting defaultTestArgs
147 bindir <- expr $ getBinaryDirectory (testCompiler args)
148 compiler <- expr $ getCompilerPath (testCompiler args)
149 globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
150 haveDocs <- areDocsPresent
151 let configFileArg= ["--config-file=" ++ (testConfigFile args)]
152 testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets)
153 onlyPerfArg = if testOnlyPerf args
154 then Just "--only-perf-tests"
155 else Nothing
156 skipPerfArg = if testSkipPerf args
157 then Just "--skip-perf-tests"
158 else Nothing
159 speedArg = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
160 summaryArg = case testSummary args of
161 Just filepath -> Just $ "--summary-file " ++ show filepath
162 Nothing -> Just $ "--summary-file=testsuite_summary.txt"
163 junitArg = case testJUnit args of
164 Just filepath -> Just $ "--junit=" ++ filepath
165 Nothing -> Nothing
166 configArgs = concat [["-e", configArg] | configArg <- testConfigs args]
167 verbosityArg = case testVerbosity args of
168 Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
169 Just verbosity -> Just $ "--verbose=" ++ verbosity
170 wayArgs = map ("--way=" ++) (testWays args)
171 compilerArg = ["--config", "compiler=" ++ show (compiler)]
172 ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
173 haddockArg = if haveDocs
174 then [ "--config", "haddock=" ++ show (bindir -/- "haddock") ]
175 else [ "--config", "haddock=" ]
176 hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
177 hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
178 inTreeArg = [ "-e", "config.in_tree_compiler=" ++
179 show (testCompiler args `elem` ["stage1", "stage2", "stage3"]) ]
180
181 pure $ configFileArg ++ testOnlyArg ++ speedArg
182 ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
183 , junitArg, verbosityArg ]
184 ++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
185 ++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
186
187 where areDocsPresent = expr $ do
188 root <- buildRoot
189 and <$> traverse doesFileExist (docFiles root)
190
191 docFiles root =
192 [ root -/- "docs" -/- "html" -/- "libraries" -/- p -/- (p ++ ".haddock")
193 -- list of packages from
194 -- utils/haddock/haddock-test/src/Test/Haddock/Config.hs
195 | p <- [ "array", "base", "ghc-prim", "process", "template-haskell" ]
196 ]
197
198 -- | Set speed for test
199 setTestSpeed :: TestSpeed -> String
200 setTestSpeed TestSlow = "0"
201 setTestSpeed TestNormal = "1"
202 setTestSpeed TestFast = "2"
203
204 -- | The purpose of this function is, given a compiler
205 -- (stage 1, 2, 3 or an external one), to infer the ways
206 -- that the libraries have been built in.
207 --
208 -- While we have this data readily available for in-tree compilers
209 -- that we build (through the 'Flavour'), that is not the case for
210 -- out-of-tree compilers that we may want to test, as is the case when
211 -- we are running './validate --hadrian' (it packages up a binary
212 -- distribution, installs it somewhere near and tests it).
213 --
214 -- We therefore proceed in a way that works regardless of whether we are
215 -- dealing with an in-tree compiler or not: we ask the GHC's install
216 -- ghc-pkg to give us the library directory of its @ghc-prim@ package and
217 -- look at what ways are available for the interface file of the
218 -- @GHC.PrimopWrappers@ module, like the Make build system does in
219 -- @testsuite\/mk\/test.mk@ to compute @HAVE_DYNAMIC@, @HAVE_VANILLA@
220 -- and @HAVE_PROFILING@:
221 --
222 -- - if we find @PrimopWrappers.hi@, we have the vanilla way;
223 -- - if we find @PrimopWrappers.dyn_hi@, we have the dynamic way;
224 -- - if we find @PrimopWrappers.p_hi@, we have the profiling way.
225 inferLibraryWays :: String -> Action [Way]
226 inferLibraryWays compiler = do
227 bindir <- getBinaryDirectory compiler
228 Stdout ghcPrimLibdirDirty <- cmd
229 [bindir </> "ghc-pkg" <.> exe]
230 ["field", "ghc-prim", "library-dirs", "--simple-output"]
231 let ghcPrimLibdir = fixup ghcPrimLibdirDirty
232 ways <- catMaybes <$> traverse (lookForWay ghcPrimLibdir) candidateWays
233 return ways
234
235 where lookForWay dir (hifile, w) = do
236 exists <- doesFileExist (dir -/- hifile)
237 if exists then return (Just w) else return Nothing
238
239 candidateWays =
240 [ ("GHC/PrimopWrappers.hi", vanilla)
241 , ("GHC/PrimopWrappers.dyn_hi", dynamic)
242 , ("GHC/PrimopWrappers.p_hi", profiling)
243 ]
244
245 -- If the ghc is in a directory with spaces in a path component,
246 -- 'dir' is prefixed and suffixed with double quotes.
247 -- In all cases, there is a \n at the end.
248 -- This function cleans it all up.
249 fixup = removeQuotes . removeNewline
250
251 removeNewline path
252 | "\n" `isSuffixOf` path = init path
253 | otherwise = path
254
255 removeQuotes path
256 | "\"" `isPrefixOf` path && "\"" `isSuffixOf` path = tail (init path)
257 | otherwise = path