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
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
|
module Rules.Test (testRules) where
import System.Environment
import Base
import CommandLine
import Expression
import Flavour
import Hadrian.Haskell.Cabal.Type (packageDependencies)
import Hadrian.Oracles.Cabal (readPackageData)
import Oracles.Setting
import Oracles.TestSettings
import Packages
import Settings
import Settings.Builders.RunTest
import Settings.Program (programContext)
import Target
import Utilities
import Context.Type
import qualified System.Directory as IO
ghcConfigHsPath :: FilePath
ghcConfigHsPath = "testsuite/mk/ghc-config.hs"
ghcConfigProgPath :: FilePath
ghcConfigProgPath = "test/bin/ghc-config" <.> exe
checkPprProgPath, checkPprSourcePath :: FilePath
checkPprProgPath = "test/bin/check-ppr" <.> exe
checkPprSourcePath = "utils/check-ppr/Main.hs"
checkPprExtra :: Maybe String
checkPprExtra = Nothing
checkExactProgPath, checkExactSourcePath :: FilePath
checkExactProgPath = "test/bin/check-exact" <.> exe
checkExactSourcePath = "utils/check-exact/Main.hs"
checkExactExtra :: Maybe String
checkExactExtra = Just "-iutils/check-exact"
countDepsProgPath, countDepsSourcePath :: FilePath
countDepsProgPath = "test/bin/count-deps" <.> exe
countDepsSourcePath = "utils/count-deps/Main.hs"
countDepsExtra :: Maybe String
countDepsExtra = Just "-iutils/count-deps"
noteLinterProgPath, noteLinterSourcePath :: FilePath
noteLinterProgPath = "test/bin/notes-util" <.> exe
noteLinterSourcePath = "utils/notes-util/Main.hs"
noteLinterExtra :: Maybe String
noteLinterExtra = Just "-iutils/notes-util"
checkPrograms :: [(String,FilePath, FilePath, Maybe String, Package, Stage -> Stage)]
checkPrograms =
[ ("test:check-ppr",checkPprProgPath, checkPprSourcePath, checkPprExtra, checkPpr, id)
, ("test:check-exact",checkExactProgPath, checkExactSourcePath, checkExactExtra, checkExact, id)
, ("test:count-deps",countDepsProgPath, countDepsSourcePath, countDepsExtra, countDeps, id)
, ("lint:notes-util", noteLinterProgPath, noteLinterSourcePath, noteLinterExtra, noteLinter, const Stage0)
]
inTreeOutTree :: (Stage -> Action b) -> Action b -> Action b
inTreeOutTree inTree outTree = do
args <- userSetting defaultTestArgs
let testCompilerArg = testCompiler args
case stageOf testCompilerArg of
Just stg -> inTree stg
Nothing -> outTree
testsuiteDeps :: Rules ()
testsuiteDeps = do
root <- buildRootRules
"test:ghc" ~> inTreeOutTree
(\stg -> do
needTestsuitePackages stg
need [(root -/- ghcConfigPath)])
(return ())
ghcConfigPath :: FilePath
ghcConfigPath = "test/ghcconfig"
-- TODO: clean up after testing
testRules :: Rules ()
testRules = do
root <- buildRootRules
testsuiteDeps
-- Using program shipped with testsuite to generate ghcconfig file.
root -/- ghcConfigProgPath %> \_ -> do
ghc0Path <- getCompilerPath "stage0"
-- Invoke via bash to work around #17362.
-- Reasons why this is required are not entirely clear.
cmd ["bash"] ["-c", ghc0Path ++ " " ++ ghcConfigHsPath ++ " -o " ++ (root -/- ghcConfigProgPath)]
-- we need to create wrappers to test the stage1 compiler
-- as the stage1 compiler needs the stage2 libraries
-- to have any hope of passing tests.
root -/- "stage1-test/bin/*" %> \path -> do
let prog = takeBaseName path
stage0prog = root -/- "stage0/bin" -/- prog <.> exe
need [stage0prog]
abs_prog_path <- liftIO (IO.canonicalizePath stage0prog)
-- Use the stage1 package database
pkgDb <- liftIO . IO.makeAbsolute =<< packageDbPath Stage1
if prog `elem` ["ghc","runghc"] then do
let flags = [ "-no-user-package-db", "-hide-package", "ghc" , "-package-env","-","-package-db",pkgDb]
writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
makeExecutable path
else if prog == "ghc-pkg" then do
let flags = ["--no-user-package-db", "--global-package-db", pkgDb]
writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
makeExecutable path
else createFileLink abs_prog_path path
-- Rules for building check-ppr, check-exact and
-- check-ppr-annotations with the compiler we are going to test
-- (in-tree or out-of-tree).
forM_ checkPrograms $ \(name, progPath, sourcePath, mextra, progPkg, mod_stage) -> do
name ~> need [root -/- progPath]
root -/- progPath %> \path -> do
need [ sourcePath ]
testGhc <- testCompiler <$> userSetting defaultTestArgs
-- when we're about to test an in-tree compiler, just build the package
-- normally, NOT stage3, as there are no rules for stage4 yet
case stageOf testGhc of
Just stg -> do
fs <- pkgFile (mod_stage stg) progPkg
need [fs]
prog_path <- programPath =<< programContext (mod_stage stg) progPkg
abs_prog_path <- liftIO (IO.canonicalizePath prog_path)
createFileLink abs_prog_path path
-- otherwise, build it by directly invoking ghc
Nothing -> do
top <- topDirectory
depsPkgs <- packageDependencies <$> readPackageData progPkg
bindir <- getBinaryDirectory testGhc
debugged <- ghcDebugged <$> flavour
dynPrograms <- dynamicGhcPrograms =<< flavour
cmd [bindir </> "ghc" <.> exe] $
concatMap (\p -> ["-package", pkgName p]) depsPkgs ++
["-o", top -/- path, top -/- sourcePath] ++
(maybe [] (\e -> [e]) mextra) ++
-- If GHC is build with debug options, then build check-ppr
-- also with debug options. This allows, e.g., to print debug
-- messages of various RTS subsystems while using check-ppr.
(if debugged then ["-debug"] else []) ++
-- If GHC is build dynamic, then build check-ppr also dynamic.
(if dynPrograms then ["-dynamic"] else [])
root -/- ghcConfigPath %> \_ -> do
alwaysRerun
args <- userSetting defaultTestArgs
let testGhc = testCompiler args
ghcPath <- getCompilerPath testGhc
whenJust (stageOf testGhc) $ \stg ->
need . (:[]) =<< programPath (Context stg ghc vanilla)
cwd <- liftIO $ IO.getCurrentDirectory
need [makeRelative cwd ghcPath]
need [root -/- ghcConfigProgPath]
cmd [FileStdout $ root -/- ghcConfigPath] (root -/- ghcConfigProgPath)
[ghcPath]
root -/- timeoutPath %> \_ -> timeoutProgBuilder
"test" ~> do
args <- userSetting defaultTestArgs
let testCompilerArg = testCompiler args
let stg = fromMaybe Stage2 $ stageOf testCompilerArg
let test_target tt = target (vanillaContext stg compiler) (Testsuite tt) [] []
-- We need to ask the testsuite if it needs any extra hadrian dependencies for the
-- tests it is going to run,
-- for example "docs_haddock"
-- We then need to go and build these dependencies
extra_targets <- words <$> askWithResources [] (test_target GetExtraDeps)
need $ filter (isOkToBuild args) extra_targets
-- Prepare Ghc configuration file for input compiler.
need [root -/- timeoutPath]
ghcPath <- getCompilerPath testCompilerArg
makePath <- builderPath $ Make ""
top <- topDirectory
ghcFlags <- runTestGhcFlags
let ghciFlags = ghcFlags ++ unwords
[ "--interactive", "-v0", "-ignore-dot-ghci"
, "-fno-ghci-history"
]
ccPath <- settingsFileSetting SettingsFileSetting_CCompilerCommand
ccFlags <- settingsFileSetting SettingsFileSetting_CCompilerFlags
pythonPath <- builderPath Python
-- Set environment variables for test's Makefile.
-- TODO: Ideally we would define all those env vars in 'env', so that
-- Shake can keep track of them, but it is not as easy as it seems
-- to get that to work.
liftIO $ do
-- Many of those env vars are used by Makefiles in the
-- test infrastructure, or from tests or their
-- Makefiles.
setEnv "MAKE" makePath
setEnv "PYTHON" pythonPath
setEnv "TEST_HC" ghcPath
setEnv "TEST_HC_OPTS" ghcFlags
setEnv "TEST_HC_OPTS_INTERACTIVE" ghciFlags
setEnv "TEST_CC" ccPath
setEnv "TEST_CC_OPTS" ccFlags
setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath)
setEnv "CHECK_EXACT" (top -/- root -/- checkExactProgPath)
setEnv "COUNT_DEPS" (top -/- root -/- countDepsProgPath)
setEnv "NOTES_UTIL" (top -/- root -/- noteLinterProgPath)
-- This lets us bypass the need to generate a config
-- through Make, which happens in testsuite/mk/boilerplate.mk
-- which is in turn included by all test 'Makefile's.
setEnv "ghc_config_mk" (top -/- root -/- ghcConfigPath)
-- Execute the test target.
-- We override the verbosity setting to make sure the user can see
-- the test output: https://gitlab.haskell.org/ghc/ghc/issues/15951.
withVerbosity Diagnostic $ buildWithCmdOptions [] $ test_target RunTest
-- | Given a test compiler and a hadrian dependency (target), check if we
-- can build the target with the compiler
--
-- We can always build a target with an intree compiler But we can only build
-- targets with special support (checkPrograms) with arbitrary compilers.
--
-- We need to build the dependencies if --test-have-intree-files is set.
-- We should have built them already by this point, but
isOkToBuild :: TestArgs -> String -> Bool
isOkToBuild args target
= stageOf (testCompiler args) `elem` [Just Stage1, Just Stage2]
|| testHasInTreeFiles args
|| target `elem` map fst6 checkPrograms
where
fst6 (a,_,_,_,_, _) = a
-- | Build the timeout program.
-- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23
timeoutProgBuilder :: Action ()
timeoutProgBuilder = do
root <- buildRoot
if windowsHost
then do
prog <- programPath =<< programContext Stage0 timeout
copyFile prog (root -/- timeoutPath)
else do
python <- builderPath Python
copyFile "testsuite/timeout/timeout.py" (root -/- timeoutPath <.> "py")
let script = unlines
[ "#!/bin/sh"
, "exec " ++ python ++ " $0.py \"$@\"" ]
writeFile' (root -/- timeoutPath) script
makeExecutable (root -/- timeoutPath)
-- | Build extra programs and libraries required by testsuite
needTestsuitePackages :: Stage -> Action ()
needTestsuitePackages stg = do
allpkgs <- packages <$> flavour
-- We need the libraries of the successor stage
libpkgs <- map (Stage1,) . filter isLibrary <$> allpkgs (succ stg)
-- And the executables of the current stage
exepkgs <- map (stg,) . filter isProgram <$> allpkgs stg
-- Don't require lib:ghc or lib:cabal when testing the stage1 compiler
-- This is a hack, but a major usecase for testing the stage1 compiler is
-- so that we can use it even if ghc stage2 fails to build
-- Unfortunately, we still need the liba
let pkgs = filter (\(_,p) -> not $ "iserv" `isInfixOf` pkgName p || ((pkgName p `elem` ["ghc", "Cabal"]) && stg == Stage0))
(libpkgs ++ exepkgs ++ [ (stg,timeout) | windowsHost ])
need =<< mapM (uncurry pkgFile) pkgs
needIservBins stg
root <- buildRoot
-- require the shims for testing stage1
need =<< sequence [(\f -> root -/- "stage1-test/bin" -/- takeFileName f) <$> (pkgFile Stage0 p) | (Stage0,p) <- exepkgs]
-- stage 1 ghc lives under stage0/bin,
-- stage 2 ghc lives under stage1/bin, etc
stageOf :: String -> Maybe Stage
stageOf "stage1" = Just Stage0
stageOf "stage2" = Just Stage1
stageOf "stage3" = Just Stage2
stageOf _ = Nothing
needIservBins :: Stage -> Action ()
needIservBins stg = do
let ws = [vanilla, profiling, dynamic]
progs <- catMaybes <$> mapM (canBuild stg) ws
need progs
where
-- Only build iserv binaries if all dependencies are built the right
-- way already. In particular this fixes the case of no_profiled_libs
-- not working with the testsuite, see #19624
canBuild Stage0 _ = pure Nothing
canBuild stg w = do
contextDeps <- contextDependencies (Context stg iserv w)
ws <- forM contextDeps $ \c ->
interpretInContext c (getLibraryWays <>
if Context.Type.package c == rts
then getRtsWays
else mempty)
if (all (w `elem`) ws)
then Just <$> programPath (Context stg iserv w)
else return Nothing
pkgFile :: Stage -> Package -> Action FilePath
pkgFile stage pkg
| isLibrary pkg = pkgConfFile (Context stage pkg profilingDynamic)
| otherwise = programPath =<< programContext stage pkg
|