testsuite: Mark th tests as broken in ext-interp way in LLVM build flavours
[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 -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 "-dno-debug-output"
50 ]
51
52 -- Command line arguments for invoking the @runtest.py@ script. A lot of this
53 -- mirrors @testsuite/mk/test.mk@.
54 runTestBuilderArgs :: Args
55 runTestBuilderArgs = builder RunTest ? do
56 pkgs <- expr $ stagePackages Stage1
57 libTests <- expr $ filterM doesDirectoryExist $ concat
58 [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
59 | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
60
61 flav <- expr flavour
62 rtsWays <- expr testRTSSettings
63 libWays <- libraryWays flav
64 let hasRtsWay w = elem w rtsWays
65 hasLibWay w = elem w libWays
66 debugged = ghcDebugged flav
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
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 integerLib <- expr (integerLibrary flav)
85
86 -- See #16087
87 let ghcBuiltByLlvm = False -- TODO: Implement this check
88
89 let asZeroOne s b = s ++ zeroOne b
90
91 -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
92 mconcat [ arg $ "testsuite/driver/runtests.py"
93 , arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
94 , pure ["--rootdir=" ++ test | test <- libTests]
95 , arg "-e", arg $ "windows=" ++ show windows
96 , arg "-e", arg $ "darwin=" ++ show darwin
97 , arg "-e", arg $ "config.local=True"
98 , arg "-e", arg $ "config.cleanup=False" -- Don't clean up.
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.integer_backend=" ++ show (pkgName integerLib)
118 , arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm
119
120 -- Use default value, see:
121 -- https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
122 , arg "-e", arg $ "config.in_tree_compiler=True"
123 , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
124 , arg "-e", arg $ "config.wordsize=" ++ show wordsize
125 , arg "-e", arg $ "config.os=" ++ show os
126 , arg "-e", arg $ "config.arch=" ++ show arch
127 , arg "-e", arg $ "config.platform=" ++ show platform
128
129 , arg "--config", arg $ "gs=gs" -- Use the default value as in test.mk
130 , arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg)
131 , arg $ "--threads=" ++ show threads
132 , getTestArgs -- User-provided arguments from command line.
133 ]
134
135 -- | Command line arguments for running GHC's test script.
136 getTestArgs :: Args
137 getTestArgs = do
138 -- targets specified in the TEST env var
139 testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
140 args <- expr $ userSetting defaultTestArgs
141 bindir <- expr $ setBinaryDirectory (testCompiler args)
142 compiler <- expr $ setCompiler (testCompiler args)
143 globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
144 let configFileArg= ["--config-file=" ++ (testConfigFile args)]
145 testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets)
146 onlyPerfArg = if testOnlyPerf args
147 then Just "--only-perf-tests"
148 else Nothing
149 skipPerfArg = if testSkipPerf args
150 then Just "--skip-perf-tests"
151 else Nothing
152 speedArg = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
153 summaryArg = case testSummary args of
154 Just filepath -> Just $ "--summary-file" ++ quote filepath
155 Nothing -> Just $ "--summary-file=testsuite_summary.txt"
156 junitArg = case testJUnit args of
157 Just filepath -> Just $ "--junit " ++ quote filepath
158 Nothing -> Nothing
159 configArgs = concat [["-e", configArg] | configArg <- testConfigs args]
160 verbosityArg = case testVerbosity args of
161 Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
162 Just verbosity -> Just $ "--verbose=" ++ verbosity
163 wayArgs = map ("--way=" ++) (testWays args)
164 compilerArg = ["--config", "compiler=" ++ show (compiler)]
165 ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
166 haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
167 hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
168 hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
169 pure $ configFileArg ++ testOnlyArg ++ speedArg
170 ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
171 , junitArg, verbosityArg ]
172 ++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
173 ++ haddockArg ++ hp2psArg ++ hpcArg
174
175 -- TODO: Switch to 'Stage' as the first argument instead of 'String'.
176 -- | Directory to look for Binaries
177 -- | We assume that required programs are present in the same binary directory
178 -- | in which ghc is stored and that they have their conventional name.
179 -- | QUESTION : packages can be named different from their conventional names.
180 -- | For example, ghc-pkg can be named as ghc-pkg-version. In such cases, it will
181 -- | be impossible to search the binary. Only possible way will be to take user
182 -- | inputs for these directory also. boilerplate soes not account for this
183 -- | problem, but simply returns an error. How should we handle such cases?
184 setBinaryDirectory :: String -> Action FilePath
185 setBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc
186 setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
187 setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
188 setBinaryDirectory compiler = pure $ parentPath compiler
189
190 -- TODO: Switch to 'Stage' as the first argument instead of 'String'.
191 -- | Set Test Compiler.
192 setCompiler :: String -> Action FilePath
193 setCompiler "stage0" = setting SystemGhc
194 setCompiler "stage1" = liftM2 (-/-) topDirectory (fullPath Stage0 ghc)
195 setCompiler "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
196 setCompiler compiler = pure compiler
197
198 -- | Set speed for test
199 setTestSpeed :: TestSpeed -> String
200 setTestSpeed Slow = "0"
201 setTestSpeed Average = "1"
202 setTestSpeed Fast = "2"
203
204 -- | Returns parent path of test compiler
205 -- | TODO: Is there a simpler way to find parent directory?
206 parentPath :: String -> String
207 parentPath path = intercalate "/" $ init $ splitOn "/" path
208
209 -- | TODO: Move to Hadrian utilities.
210 fullPath :: Stage -> Package -> Action FilePath
211 fullPath stage pkg = programPath =<< programContext stage pkg