summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorZubin Duggal <zubin.duggal@gmail.com>2021-12-14 18:11:18 +0530
committerMatthew Pickering <matthewtpickering@gmail.com>2022-01-10 12:18:47 +0000
commitd3a155232c924db5fc84c042e4ef0368d1b33980 (patch)
tree032f77381c21e956bfedce312100fc72f103398d
parent741d5e8a3e2f3a3ca0d3a9f78c1ecc85a191209b (diff)
downloadhaskell-wip/hadrian-stage1.tar.gz
hadrian: Allow testing of the stage1 compiler (#20755)wip/hadrian-stage1
-rwxr-xr-x.gitlab/ci.sh6
-rw-r--r--hadrian/src/Oracles/TestSettings.hs9
-rw-r--r--hadrian/src/Rules/Program.hs2
-rw-r--r--hadrian/src/Rules/Test.hs97
-rw-r--r--hadrian/src/Settings/Builders/RunTest.hs4
-rw-r--r--hadrian/src/Settings/Default.hs4
6 files changed, 79 insertions, 43 deletions
diff --git a/.gitlab/ci.sh b/.gitlab/ci.sh
index 054e429042..9a7101f17f 100755
--- a/.gitlab/ci.sh
+++ b/.gitlab/ci.sh
@@ -521,6 +521,12 @@ function test_hadrian() {
run_hadrian \
test \
+ --test-root-dirs=testsuite/tests/stage1 \
+ --test-compiler=stage1 \
+ "runtest.opts+=${RUNTEST_ARGS:-}"
+
+ run_hadrian \
+ test \
--summary-junit=./junit.xml \
--test-have-intree-files \
--test-compiler="$TOP/_build/install/bin/ghc$exe" \
diff --git a/hadrian/src/Oracles/TestSettings.hs b/hadrian/src/Oracles/TestSettings.hs
index 116bf95789..d59819187f 100644
--- a/hadrian/src/Oracles/TestSettings.hs
+++ b/hadrian/src/Oracles/TestSettings.hs
@@ -12,6 +12,8 @@ import Hadrian.Oracles.TextFile
import Oracles.Setting (topDirectory, setting, Setting(..))
import Packages
import Settings.Program (programContext)
+import Hadrian.Oracles.Path
+import System.Directory (makeAbsolute)
testConfigFile :: Action FilePath
testConfigFile = buildRoot <&> (-/- "test/ghcconfig")
@@ -74,12 +76,15 @@ testRTSSettings = do
file <- testConfigFile
words <$> lookupValueOrError file "GhcRTSWays"
+absoluteBuildRoot :: Action FilePath
+absoluteBuildRoot = (fixAbsolutePathOnWindows =<< liftIO . makeAbsolute =<< buildRoot)
+
-- | Directory to look for binaries.
-- We assume that required programs are present in the same binary directory
-- in which ghc is stored and that they have their conventional name.
getBinaryDirectory :: String -> Action FilePath
getBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc
-getBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
+getBinaryDirectory "stage1" = liftM2 (-/-) absoluteBuildRoot (pure "stage1-test/bin/")
getBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
getBinaryDirectory "stage3" = liftM2 (-/-) topDirectory (stageBinPath Stage2)
getBinaryDirectory compiler = pure $ takeDirectory compiler
@@ -87,7 +92,7 @@ getBinaryDirectory compiler = pure $ takeDirectory compiler
-- | Get the path to the given @--test-compiler@.
getCompilerPath :: String -> Action FilePath
getCompilerPath "stage0" = setting SystemGhc
-getCompilerPath "stage1" = liftM2 (-/-) topDirectory (fullPath Stage0 ghc)
+getCompilerPath "stage1" = liftM2 (-/-) absoluteBuildRoot (pure "stage1-test/bin/ghc")
getCompilerPath "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
getCompilerPath "stage3" = liftM2 (-/-) topDirectory (fullPath Stage2 ghc)
getCompilerPath compiler = pure compiler
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
index 04a3bf3aaa..683f308bfc 100644
--- a/hadrian/src/Rules/Program.hs
+++ b/hadrian/src/Rules/Program.hs
@@ -50,7 +50,7 @@ getProgramContexts stage = do
tPackages <- testsuitePackages
-- TODO: Shall we use Stage2 for testsuite packages instead?
let allPackages = sPackages
- ++ if stage == Stage1 then tPackages else []
+ ++ tPackages
fmap concat . forM allPackages $ \pkg -> do
-- the iserv pkg results in three different programs at
-- the moment, ghc-iserv (built the vanilla way),
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index bab8417924..5115b4d462 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -65,6 +65,26 @@ testRules = do
-- 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).
@@ -76,16 +96,15 @@ testRules = do
-- 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
- if (testGhc `elem` ["stage1", "stage2"])
- then do
- let stg = stageOf testGhc
+ case stageOf testGhc of
+ Just stg -> do
fs <- pkgFile stg progPkg
need [fs]
prog_path <- programPath =<< programContext stg progPkg
abs_prog_path <- liftIO (IO.canonicalizePath prog_path)
createFileLink abs_prog_path path
-- otherwise, build it by directly invoking ghc
- else do
+ Nothing -> do
top <- topDirectory
depsPkgs <- packageDependencies <$> readPackageData progPkg
bindir <- getBinaryDirectory testGhc
@@ -106,9 +125,8 @@ testRules = do
alwaysRerun
args <- userSetting defaultTestArgs
let testGhc = testCompiler args
- stg = stageOf testGhc
ghcPath <- getCompilerPath testGhc
- when (testGhc `elem` ["stage1", "stage2", "stage3"]) $
+ whenJust (stageOf testGhc) $ \stg ->
need . (:[]) =<< programPath (Context stg ghc vanilla)
need [root -/- ghcConfigProgPath]
cmd [FileStdout $ root -/- ghcConfigPath] (root -/- ghcConfigProgPath)
@@ -126,14 +144,9 @@ testRules = do
args <- userSetting defaultTestArgs
let testCompilerArg = testCompiler args
+
ghcPath <- getCompilerPath testCompilerArg
- -- TODO This approach doesn't work.
- -- Set environment variables for test's Makefile.
- env <- sequence
- [ builderEnvironment "MAKE" $ Make ""
- , builderEnvironment "TEST_HC" $ Ghc CompileHs Stage2
- , AddEnv "TEST_HC_OPTS" <$> runTestGhcFlags ]
makePath <- builderPath $ Make ""
top <- topDirectory
@@ -171,7 +184,8 @@ testRules = do
-- which is in turn included by all test 'Makefile's.
setEnv "ghc_config_mk" (top -/- root -/- ghcConfigPath)
- let test_target tt = target (vanillaContext Stage2 compiler) (Testsuite tt) [] []
+ 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,
@@ -183,7 +197,7 @@ testRules = do
-- 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 env $ test_target RunTest
+ 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
@@ -195,7 +209,7 @@ testRules = do
-- We should have built them already by this point, but
isOkToBuild :: TestArgs -> String -> Bool
isOkToBuild args target
- = isInTreeCompiler (testCompiler args)
+ = stageOf (testCompiler args) `elem` [Just Stage1, Just Stage2]
|| testHasInTreeFiles args
|| target `elem` map fst5 checkPrograms
where
@@ -223,40 +237,47 @@ timeoutProgBuilder = do
needTestBuilders :: Action ()
needTestBuilders = do
testGhc <- testCompiler <$> userSetting defaultTestArgs
- when (isInTreeCompiler testGhc)
- (needTestsuitePackages testGhc)
+ whenJust (stageOf testGhc)
+ needTestsuitePackages
-- | Build extra programs and libraries required by testsuite
--- 'testGhc' has to be one of "stage1", "stage2" or "stage3"
-needTestsuitePackages :: String -> Action ()
-needTestsuitePackages testGhc = do
- let stg = stageOf testGhc
- allpkgs <- packages <$> flavour
- stgpkgs <- allpkgs (succ stg)
- let pkgs = filter (\p -> not $ "iserv" `isInfixOf` pkgName p)
- (stgpkgs ++ [ timeout | windowsHost ])
- need =<< mapM (pkgFile stg) pkgs
- needIservBins
+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 -> Stage
-stageOf "stage1" = Stage0
-stageOf "stage2" = Stage1
-stageOf "stage3" = Stage2
-stageOf _ = error "unexpected stage argument"
-
-needIservBins :: Action ()
-needIservBins = do
- testGhc <- testCompiler <$> userSetting defaultTestArgs
- let stg = stageOf testGhc
- ws = [vanilla, profiling, dynamic]
+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 ->
diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs
index 19d22a394f..168e64e217 100644
--- a/hadrian/src/Settings/Builders/RunTest.hs
+++ b/hadrian/src/Settings/Builders/RunTest.hs
@@ -9,6 +9,7 @@ import Packages
import Settings.Builders.Common
import qualified Data.Set as Set
import Flavour
+import qualified Context.Type as C
getTestSetting :: TestSetting -> Expr String
getTestSetting key = expr $ testSetting key
@@ -54,7 +55,8 @@ runTestGhcFlags = do
-- mirrors @testsuite/mk/test.mk@.
runTestBuilderArgs :: Args
runTestBuilderArgs = builder Testsuite ? do
- pkgs <- expr $ stagePackages Stage1
+ ctx <- getContext
+ pkgs <- expr $ stagePackages (C.stage ctx)
libTests <- expr $ filterM doesDirectoryExist $ concat
[ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
| pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index a20a1d821d..5ecdf3bc09 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -1,6 +1,6 @@
module Settings.Default (
-- * Packages that are build by default and for the testsuite
- defaultPackages, testsuitePackages,
+ defaultPackages, testsuitePackages, stage0Packages,
-- * Default build ways
defaultLibraryWays, defaultRtsWays,
@@ -68,6 +68,7 @@ stage0Packages = do
, genapply
, genprimopcode
, ghc
+ , runGhc
, ghcBoot
, ghcBootTh
, ghcHeap
@@ -76,6 +77,7 @@ stage0Packages = do
, haddock
, hsc2hs
, hpc
+ , hpcBin
, mtl
, parsec
, templateHaskell