diff --git a/cfg/system.config.in b/cfg/system.config.in index b007581330..c983ae4a50 100644 --- a/cfg/system.config.in +++ b/cfg/system.config.in @@ -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: #============================ diff --git a/hadrian.cabal b/hadrian.cabal index 2b6b9f9fb9..efc1251e41 100644 --- a/hadrian.cabal +++ b/hadrian.cabal @@ -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 diff --git a/src/Builder.hs b/src/Builder.hs index 2b99c03992..4adeeef0e1 100644 --- a/src/Builder.hs +++ b/src/Builder.hs @@ -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" diff --git a/src/CommandLine.hs b/src/CommandLine.hs index 2344dcc99c..e747a52a53 100644 --- a/src/CommandLine.hs +++ b/src/CommandLine.hs @@ -1,7 +1,7 @@ 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 diff --git a/src/Hadrian/Utilities.hs b/src/Hadrian/Utilities.hs index 7c3510fb19..b775be2e89 100644 --- a/src/Hadrian/Utilities.hs +++ b/src/Hadrian/Utilities.hs @@ -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. -- diff --git a/src/Rules/Test.hs b/src/Rules/Test.hs index ae37343432..0f28106ce0 100644 --- a/src/Rules/Test.hs +++ b/src/Rules/Test.hs @@ -1,17 +1,37 @@ -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 diff --git a/src/Settings/Builders/RunTest.hs b/src/Settings/Builders/RunTest.hs new file mode 100644 index 0000000000..1f70a0305a --- /dev/null +++ b/src/Settings/Builders/RunTest.hs @@ -0,0 +1,107 @@ +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 diff --git a/src/Settings/Default.hs b/src/Settings/Default.hs index dc58f22160..5658d000ab 100644 --- a/src/Settings/Default.hs +++ b/src/Settings/Default.hs @@ -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