Commit 63a55638 authored by Tao He's avatar Tao He Committed by Andrey Mokhov

[WIP] Support run GHC's test from hadrian. (#495)

* Support run GHC's test from hadrian.

1. Necessary command line arguments to run test driver.
   + `--test-only=<TEST_CASE>`
   + `--test-skip-perf`
   + `--test-summary=<SUMMARY_FILE>`
   + `--test-junit=<SUMMARY_FILE>`
   + `--test-config=<EXTRA_TEST_CONFIG>`
2. Synchronize configurations from test.mk.
3. Synchronize GHC's compilation flags from test.mk (that's very important).

* The `RunTest` builder and `test` rule to run GHC's test.
* Timeout rules.
* Reduce boilerplate.
* Fix warning.
* Move getTestArgs into Settings.Builders.RunTest.
* Drop `validate` related code to avoid confusion.
* Replace explicit `chmod +x` with `makeExecutable`.
* Fix executable's extension.
parent fdc35b18
......@@ -26,6 +26,10 @@ perl = @PerlCmd@
ln-s = @LN_S@
xelatex = @XELATEX@
# Python 3 is required to run test driver.
# See: https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk#L220
python = python3
# Information about builders:
#============================
......
......@@ -78,6 +78,7 @@ executable hadrian
, Settings.Builders.HsCpp
, Settings.Builders.Ld
, Settings.Builders.Make
, Settings.Builders.RunTest
, Settings.Builders.Xelatex
, Settings.Default
, Settings.Flavours.Development
......
......@@ -87,6 +87,7 @@ data Builder = Alex
| Haddock HaddockMode
| Happy
| Hpc
| Hp2Ps
| HsCpp
| Hsc2Hs
| Ld
......@@ -95,7 +96,9 @@ data Builder = Alex
| Objdump
| Patch
| Perl
| Python
| Ranlib
| RunTest
| Sphinx SphinxMode
| Tar TarMode
| Unlit
......@@ -121,6 +124,7 @@ builderProvenance = \case
GhcPkg _ _ -> context Stage0 ghcPkg
Haddock _ -> context Stage2 haddock
Hpc -> context Stage1 hpcBin
Hp2Ps -> context Stage0 hp2ps
Hsc2Hs -> context Stage0 hsc2hs
Unlit -> context Stage0 unlit
_ -> Nothing
......@@ -221,7 +225,9 @@ systemBuilderPath builder = case builder of
Objdump -> fromKey "objdump"
Patch -> fromKey "patch"
Perl -> fromKey "perl"
Python -> fromKey "python"
Ranlib -> fromKey "ranlib"
RunTest -> fromKey "python"
Sphinx _ -> fromKey "sphinx-build"
Tar _ -> fromKey "tar"
Xelatex -> fromKey "xelatex"
......
module CommandLine (
optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
cmdProgressColour, cmdProgressInfo, cmdConfigure, cmdSplitObjects,
cmdInstallDestDir
cmdInstallDestDir, TestArgs(..), defaultTestArgs
) where
import Data.Either
......@@ -21,7 +21,8 @@ data CommandLineArgs = CommandLineArgs
, integerSimple :: Bool
, progressColour :: UseColour
, progressInfo :: ProgressInfo
, splitObjects :: Bool }
, splitObjects :: Bool
, testArgs :: TestArgs }
deriving (Eq, Show)
-- | Default values for 'CommandLineArgs'.
......@@ -34,7 +35,26 @@ defaultCommandLineArgs = CommandLineArgs
, integerSimple = False
, progressColour = Auto
, progressInfo = Brief
, splitObjects = False }
, splitObjects = False
, testArgs = defaultTestArgs }
-- | These arguments are used by the `test` target.
data TestArgs = TestArgs
{ testOnly :: Maybe String
, testSkipPerf :: Bool
, testSummary :: Maybe FilePath
, testJUnit :: Maybe FilePath
, testConfigs :: [String] }
deriving (Eq, Show)
-- | Default value for `TestArgs`.
defaultTestArgs :: TestArgs
defaultTestArgs = TestArgs
{ testOnly = Nothing
, testSkipPerf = False
, testSummary = Nothing
, testJUnit = Nothing
, testConfigs = [] }
readConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
readConfigure = Right $ \flags -> flags { configure = True }
......@@ -79,6 +99,26 @@ readProgressInfo ms =
readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
readSplitObjects = Right $ \flags -> flags { splitObjects = True }
readTestOnly :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestOnly tests = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnly = tests } }
readTestSkipPerf :: Either String (CommandLineArgs -> CommandLineArgs)
readTestSkipPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testSkipPerf = True } }
readTestSummary :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestConfig config =
case config of
Nothing -> Right id
Just conf -> Right $ \flags ->
let configs = conf : testConfigs (testArgs flags)
in flags { testArgs = (testArgs flags) { testConfigs = configs } }
-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
optDescrs =
......@@ -97,7 +137,17 @@ optDescrs =
, Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
"Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["split-objects"] (NoArg readSplitObjects)
"Generate split objects (requires a full clean rebuild)." ]
"Generate split objects (requires a full clean rebuild)."
, Option [] ["only"] (OptArg readTestOnly "TESTS")
"Test cases to run."
, Option [] ["skip-perf"] (NoArg readTestSkipPerf)
"Skip performance tests."
, Option [] ["summary"] (OptArg readTestSummary "TEST_SUMMARY")
"Where to output the test summary file."
, Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT")
"Output testsuite summary in JUnit format."
, Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG")
"Configurations to run test, in key=value format." ]
-- | A type-indexed map containing Hadrian command line arguments to be passed
-- to Shake via 'shakeExtra'.
......@@ -107,6 +157,7 @@ cmdLineArgsMap = do
let args = foldl (flip id) defaultCommandLineArgs (rights opts)
return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
$ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
$ insertExtra args Map.empty
cmdLineArgs :: Action CommandLineArgs
......
......@@ -4,7 +4,7 @@ module Hadrian.Utilities (
fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
-- * String manipulation
quote, yesNo,
quote, yesNo, zeroOne,
-- * FilePath manipulation
unifyPath, (-/-),
......@@ -13,7 +13,7 @@ module Hadrian.Utilities (
insertExtra, lookupExtra, userSetting,
-- * Paths
BuildRoot (..), buildRoot, isGeneratedSource,
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
-- * File system operations
copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
......@@ -26,7 +26,6 @@ module Hadrian.Utilities (
ProgressInfo (..), putProgressInfo,
renderAction, renderProgram, renderLibrary, renderBox, renderUnicorn,
-- * Miscellaneous
(<&>), (%%>), cmdLineLengthLimit,
......@@ -115,6 +114,11 @@ yesNo :: Bool -> String
yesNo True = "YES"
yesNo False = "NO"
-- | Pretty-print a `Bool` as a @"1"@ or @"0"@ string
zeroOne :: Bool -> String
zeroOne True = "1"
zeroOne False = "0"
-- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx
......@@ -168,6 +172,13 @@ userSetting defaultValue = do
extra <- shakeExtra <$> getShakeOptions
return $ lookupExtra defaultValue extra
-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
-- setting is not found, return the provided default value instead.
userSettingRules :: Typeable a => a -> Rules a
userSettingRules defaultValue = do
extra <- shakeExtra <$> getShakeOptionsRules
return $ lookupExtra defaultValue extra
newtype BuildRoot = BuildRoot FilePath deriving Typeable
-- | All build results are put into the 'buildRoot' directory.
......@@ -176,6 +187,11 @@ buildRoot = do
BuildRoot path <- userSetting (BuildRoot "")
return path
buildRootRules :: Rules FilePath
buildRootRules = do
BuildRoot path <- userSettingRules (BuildRoot "")
return path
-- | A version of 'fmap' with flipped arguments. Useful for manipulating values
-- in context, e.g. 'buildRoot', as in the example below.
--
......
module Rules.Test (testRules) where
module Rules.Test (testRules, runTestGhcFlags, timeoutProgPath) where
import Base
import Expression
import Flavour
import Oracles.Flag
import Oracles.Setting
import Settings
import Target
import Utilities
import System.Environment
-- TODO: clean up after testing
testRules :: Rules ()
testRules = do
root <- buildRootRules
root -/- timeoutPyPath ~> do
copyFile "testsuite/timeout/timeout.py" (root -/- timeoutPyPath)
-- TODO windows is still not supported.
--
-- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23
root -/- timeoutProgPath ~> do
python <- builderPath Python
need [root -/- timeoutPyPath]
let script = unlines
[ "#!/usr/bin/env sh"
, "exec " ++ python ++ " $0.py \"$@\""
]
liftIO $ do
writeFile (root -/- timeoutProgPath) script
makeExecutable (root -/- timeoutProgPath)
"validate" ~> do
need inplaceLibCopyTargets
needBuilder $ Ghc CompileHs Stage2
......@@ -24,49 +44,62 @@ testRules = do
build $ target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] []
"test" ~> do
pkgs <- stagePackages Stage1
tests <- filterM doesDirectoryExist $ concat
[ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
| pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
windows <- windowsHost
top <- topDirectory
compiler <- builderPath $ Ghc CompileHs Stage2
ghcPkg <- builderPath $ GhcPkg Update Stage1
haddock <- builderPath (Haddock BuildPackage)
threads <- shakeThreads <$> getShakeOptions
debugged <- ghcDebugged <$> flavour
ghcWithNativeCodeGenInt <- fromEnum <$> ghcWithNativeCodeGen
ghcWithInterpreterInt <- fromEnum <$> ghcWithInterpreter
ghcUnregisterisedInt <- fromEnum <$> flag GhcUnregisterised
quietly . cmd "python2" $
[ "testsuite/driver/runtests.py" ]
++ map ("--rootdir="++) tests ++
[ "-e", "windows=" ++ show windows
, "-e", "config.speed=2"
, "-e", "ghc_compiler_always_flags=" ++ show "-fforce-recomp -dcore-lint -dcmm-lint -dno-debug-output -no-user-package-db -rtsopts"
, "-e", "ghc_with_native_codegen=" ++ show ghcWithNativeCodeGenInt
, "-e", "ghc_debugged=" ++ show (yesNo debugged)
, "-e", "ghc_with_vanilla=1" -- TODO: do we always build vanilla?
, "-e", "ghc_with_dynamic=0" -- TODO: support dynamic
, "-e", "ghc_with_profiling=0" -- TODO: support profiling
, "-e", "ghc_with_interpreter=" ++ show ghcWithInterpreterInt
, "-e", "ghc_unregisterised=" ++ show ghcUnregisterisedInt
, "-e", "ghc_with_threaded_rts=0" -- TODO: support threaded
, "-e", "ghc_with_dynamic_rts=0" -- TODO: support dynamic
, "-e", "ghc_dynamic_by_default=False" -- TODO: support dynamic
, "-e", "ghc_dynamic=0" -- TODO: support dynamic
, "-e", "ghc_with_llvm=0" -- TODO: support LLVM
, "-e", "in_tree_compiler=True" -- TODO: when is it equal to False?
, "-e", "clean_only=False" -- TODO: do we need to support True?
, "--configfile=testsuite/config/ghc"
, "--config", "compiler=" ++ show (top -/- compiler)
, "--config", "ghc_pkg=" ++ show (top -/- ghcPkg)
, "--config", "haddock=" ++ show (top -/- haddock)
, "--summary-file", "testsuite_summary.txt"
, "--threads=" ++ show threads
]
-- , "--config", "hp2ps=" ++ quote ("hp2ps")
-- , "--config", "hpc=" ++ quote ("hpc")
-- , "--config", "gs=$(call quote_path,$(GS))"
-- , "--config", "timeout_prog=$(call quote_path,$(TIMEOUT_PROGRAM))"
-- Prepare the timeout program.
need [ root -/- timeoutProgPath ]
-- 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
ghcPath <- (top -/-) <$> builderPath (Ghc CompileHs Stage2)
ghcFlags <- runTestGhcFlags
-- Set environment variables for test's Makefile.
liftIO $ do
setEnv "MAKE" makePath
setEnv "TEST_HC" ghcPath
setEnv "TEST_HC_OPTS" ghcFlags
-- Execute the test target.
buildWithCmdOptions env $ target (vanillaContext Stage2 compiler) RunTest [] []
-- | Extra flags to send to the Haskell compiler to run tests.
runTestGhcFlags :: Action String
runTestGhcFlags = do
unregisterised <- flag GhcUnregisterised
let ifMinGhcVer ver opt = do v <- ghcCanonVersion
if ver <= v then pure opt
else pure ""
-- Read extra argument for test from command line, like `-fvectorize`.
ghcOpts <- fromMaybe "" <$> (liftIO $ lookupEnv "EXTRA_HC_OPTS")
-- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L28
let ghcExtraFlags = if unregisterised
then "-optc-fno-builtin"
else ""
-- Take flags to send to the Haskell compiler from test.mk.
-- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37
unwords <$> sequence
[ pure " -dcore-lint -dcmm-lint -no-user-package-db -rtsopts"
, pure ghcOpts
, pure ghcExtraFlags
, ifMinGhcVer "711" "-fno-warn-missed-specialisations"
, ifMinGhcVer "711" "-fshow-warning-groups"
, ifMinGhcVer "801" "-fdiagnostics-color=never"
, ifMinGhcVer "801" "-fno-diagnostics-show-caret"
, pure "-dno-debug-output"
]
timeoutPyPath :: FilePath
timeoutPyPath = "test/bin/timeout.py"
timeoutProgPath :: FilePath
timeoutProgPath = "test/bin/timeout" <.> exe
module Settings.Builders.RunTest (runTestBuilderArgs) where
import Hadrian.Utilities
import Hadrian.Haskell.Cabal
import Flavour
import Rules.Test
import Settings.Builders.Common
import Settings.Builders.Ghc
import CommandLine ( TestArgs(..), defaultTestArgs )
-- Arguments to send to the runtest.py script.
runTestBuilderArgs :: Args
runTestBuilderArgs = builder RunTest ? do
pkgs <- expr $ stagePackages Stage1
libTests <- expr $ filterM doesDirectoryExist $ concat
[ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
| pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
debugged <- ghcDebugged <$> expr flavour
withNativeCodeGen <- expr ghcWithNativeCodeGen
withInterpreter <- expr ghcWithInterpreter
unregisterised <- expr $ flag GhcUnregisterised
withSMP <- expr ghcWithSMP
windows <- expr windowsHost
darwin <- expr osxHost
threads <- shakeThreads <$> expr getShakeOptions
verbose <- shakeVerbosity <$> expr getShakeOptions
top <- expr topDirectory
compiler <- expr $ builderPath $ Ghc CompileHs Stage2
ghcPkg <- expr $ builderPath $ GhcPkg Update Stage1
haddock <- expr $ builderPath $ Haddock BuildPackage
hp2ps <- expr $ builderPath $ Hp2Ps
hpc <- expr $ builderPath $ Hpc
ghcFlags <- expr runTestGhcFlags
timeoutProg <- expr buildRoot <&> (-/- timeoutProgPath)
mconcat [ arg $ "testsuite/driver/runtests.py"
, arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
, pure ["--rootdir=" ++ test | test <- libTests]
, arg "-e", arg $ "windows=" ++ show windows
, arg "-e", arg $ "darwin=" ++ show darwin
, arg "-e", arg $ "config.speed=2" -- Use default value in GHC's test.mk
, arg "-e", arg $ "config.local=True"
, arg "-e", arg $ "config.cleanup=False" -- Don't clean up.
, arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ "ghc_with_native_codegen=" ++ zeroOne withNativeCodeGen
, arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
, arg "-e", arg $ "config.unregisterised=" ++ show unregisterised
, arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
, arg "-e", arg $ "ghc_with_vanilla=1" -- TODO: do we always build vanilla?
, arg "-e", arg $ "ghc_with_dynamic=0" -- TODO: support dynamic
, arg "-e", arg $ "ghc_with_profiling=0" -- TODO: support profiling
, arg "-e", arg $ "config.have_vanilla=1" -- TODO: support other build context
, arg "-e", arg $ "config.have_dynamic=0" -- TODO: support dynamic
, arg "-e", arg $ "config.have_profiling=0" -- TODO: support profiling
, arg "-e", arg $ "ghc_with_smp=" ++ zeroOne withSMP
, arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
, arg "-e", arg $ "ghc_with_threaded_rts=0" -- TODO: support threaded
, arg "-e", arg $ "ghc_with_dynamic_rts=0" -- TODO: support dynamic
, arg "-e", arg $ "config.ghc_dynamic_by_default=False" -- TODO: support dynamic
, arg "-e", arg $ "config.ghc_dynamic=False" -- TODO: support dynamic
, arg "-e", arg $ "config.in_tree_compiler=True" -- Use default value, see https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
, arg "--config-file=testsuite/config/ghc"
, arg "--config", arg $ "compiler=" ++ show (top -/- compiler)
, arg "--config", arg $ "ghc_pkg=" ++ show (top -/- ghcPkg)
, arg "--config", arg $ "haddock=" ++ show (top -/- haddock)
, arg "--config", arg $ "hp2ps=" ++ show (top -/- hp2ps)
, arg "--config", arg $ "hpc=" ++ show (top -/- hpc)
, arg "--config", arg $ "gs=gs" -- Use the default value as in test.mk
, arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg)
, arg $ "--threads=" ++ show threads
, arg $ "--verbose=" ++ show (fromEnum verbose)
, getTestArgs -- User-provided arguments from command line.
]
-- | Prepare the command-line arguments to run GHC's test script.
getTestArgs :: Args
getTestArgs = do
args <- expr $ userSetting defaultTestArgs
let testOnlyArg = case testOnly args of
Just cases -> map ("--only=" ++) (words cases)
Nothing -> []
skipPerfArg = if testSkipPerf args
then Just "--skip-perf-tests"
else Nothing
summaryArg = case testSummary args of
Just filepath -> Just $ "--summary-file" ++ quote filepath
Nothing -> Just $ "--summary-file=testsuite_summary.txt"
junitArg = case testJUnit args of
Just filepath -> Just $ "--junit " ++ quote filepath
Nothing -> Nothing
configArgs = map ("-e " ++) (testConfigs args)
pure $ testOnlyArg ++ catMaybes [skipPerfArg, summaryArg, junitArg] ++ configArgs
......@@ -28,6 +28,7 @@ import Settings.Builders.Hsc2Hs
import Settings.Builders.HsCpp
import Settings.Builders.Ld
import Settings.Builders.Make
import Settings.Builders.RunTest
import Settings.Builders.Xelatex
import Settings.Packages.Base
import Settings.Packages.Cabal
......@@ -144,6 +145,7 @@ defaultBuilderArgs = mconcat
, hsCppBuilderArgs
, ldBuilderArgs
, makeBuilderArgs
, runTestBuilderArgs
, xelatexBuilderArgs
-- Generic builders from the Hadrian library:
, builder (Ar Pack ) ? Hadrian.Builder.Ar.args Pack
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment