Commit 48927a9a authored by Alp Mestanogullari's avatar Alp Mestanogullari Committed by Marge Bot

Hadrian: various improvements around the 'test' rule

- introduce a -k/--keep-test-files flag to prevent cleanup
- add -dstg-lint to the options that are always passed to tests
- infer library ways from the compiler to be tested instead of getting them
  from the flavour (like make)
- likewise for figuring out whether the compiler to be tested is "debugged"
- specify config.exeext
- correctly specify config.in_tree_compiler, instead of always passing True
- fix formatting of how we pass a few test options
- add (potential) extensions to check-* program names
- build check-* programs with the compiler to be tested
- set TEST_HC_OPTS_INTERACTIVE and PYTHON env vars when running tests
parent 1675d40a
Pipeline #3242 passed with stages
in 376 minutes and 32 seconds
...@@ -15,7 +15,7 @@ import System.Environment ...@@ -15,7 +15,7 @@ import System.Environment
import qualified Data.Set as Set import qualified Data.Set as Set
data TestSpeed = Slow | Average | Fast deriving (Show, Eq) data TestSpeed = TestSlow | TestNormal | TestFast deriving (Show, Eq)
-- | All arguments that can be passed to Hadrian via the command line. -- | All arguments that can be passed to Hadrian via the command line.
data CommandLineArgs = CommandLineArgs data CommandLineArgs = CommandLineArgs
...@@ -45,7 +45,8 @@ defaultCommandLineArgs = CommandLineArgs ...@@ -45,7 +45,8 @@ defaultCommandLineArgs = CommandLineArgs
-- | These arguments are used by the `test` target. -- | These arguments are used by the `test` target.
data TestArgs = TestArgs data TestArgs = TestArgs
{ testCompiler :: String { testKeepFiles :: Bool
, testCompiler :: String
, testConfigFile :: String , testConfigFile :: String
, testConfigs :: [String] , testConfigs :: [String]
, testJUnit :: Maybe FilePath , testJUnit :: Maybe FilePath
...@@ -61,14 +62,15 @@ data TestArgs = TestArgs ...@@ -61,14 +62,15 @@ data TestArgs = TestArgs
-- | Default value for `TestArgs`. -- | Default value for `TestArgs`.
defaultTestArgs :: TestArgs defaultTestArgs :: TestArgs
defaultTestArgs = TestArgs defaultTestArgs = TestArgs
{ testCompiler = "stage2" { testKeepFiles = False
, testCompiler = "stage2"
, testConfigFile = "testsuite/config/ghc" , testConfigFile = "testsuite/config/ghc"
, testConfigs = [] , testConfigs = []
, testJUnit = Nothing , testJUnit = Nothing
, testOnly = [] , testOnly = []
, testOnlyPerf = False , testOnlyPerf = False
, testSkipPerf = False , testSkipPerf = False
, testSpeed = Fast , testSpeed = TestNormal
, testSummary = Nothing , testSummary = Nothing
, testVerbosity = Nothing , testVerbosity = Nothing
, testWays = [] } , testWays = [] }
...@@ -119,6 +121,9 @@ readProgressInfo ms = ...@@ -119,6 +121,9 @@ readProgressInfo ms =
set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
set flag flags = flags { progressInfo = flag } set flag flags = flags { progressInfo = flag }
readTestKeepFiles :: Either String (CommandLineArgs -> CommandLineArgs)
readTestKeepFiles = Right $ \flags -> flags { testArgs = (testArgs flags) { testKeepFiles = True } }
readTestCompiler :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs) readTestCompiler :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestCompiler compiler = maybe (Left "Cannot parse compiler") (Right . set) compiler readTestCompiler compiler = maybe (Left "Cannot parse compiler") (Right . set) compiler
where where
...@@ -158,9 +163,9 @@ readTestSpeed ms = ...@@ -158,9 +163,9 @@ readTestSpeed ms =
maybe (Left "Cannot parse test-speed") (Right . set) (go =<< lower <$> ms) maybe (Left "Cannot parse test-speed") (Right . set) (go =<< lower <$> ms)
where where
go :: String -> Maybe TestSpeed go :: String -> Maybe TestSpeed
go "fast" = Just Fast go "fast" = Just TestFast
go "slow" = Just Slow go "slow" = Just TestSlow
go "average" = Just Average go "normal" = Just TestNormal
go _ = Nothing go _ = Nothing
set :: TestSpeed -> CommandLineArgs -> CommandLineArgs set :: TestSpeed -> CommandLineArgs -> CommandLineArgs
set flag flags = flags { testArgs = (testArgs flags) {testSpeed = flag} } set flag flags = flags { testArgs = (testArgs flags) {testSpeed = flag} }
...@@ -217,6 +222,8 @@ optDescrs = ...@@ -217,6 +222,8 @@ optDescrs =
"Progress info style (None, Brief, Normal or Unicorn)." "Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["docs"] (OptArg readDocsArg "TARGET") , Option [] ["docs"] (OptArg readDocsArg "TARGET")
"Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]." "Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
, Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
"Keep all the files generated when running the testsuite."
, Option [] ["test-compiler"] (OptArg readTestCompiler "TEST_COMPILER") , Option [] ["test-compiler"] (OptArg readTestCompiler "TEST_COMPILER")
"Use given compiler [Default=stage2]." "Use given compiler [Default=stage2]."
, Option [] ["test-config-file"] (OptArg readTestConfigFile "CONFIG_FILE") , Option [] ["test-config-file"] (OptArg readTestConfigFile "CONFIG_FILE")
......
...@@ -2,10 +2,16 @@ ...@@ -2,10 +2,16 @@
-- | compiler. We need to search this file for required keys and setting -- | compiler. We need to search this file for required keys and setting
-- | required for testsuite e.g. WORDSIZE, HOSTOS etc. -- | required for testsuite e.g. WORDSIZE, HOSTOS etc.
module Oracles.TestSettings (TestSetting (..), testSetting, testRTSSettings) where module Oracles.TestSettings
( TestSetting (..), testSetting, testRTSSettings
, getCompilerPath, getBinaryDirectory
) where
import Base import Base
import Hadrian.Oracles.TextFile import Hadrian.Oracles.TextFile
import Oracles.Setting (topDirectory, setting, Setting(..))
import Settings (programContext)
import Packages
testConfigFile :: Action FilePath testConfigFile :: Action FilePath
testConfigFile = buildRoot <&> (-/- "test/ghcconfig") testConfigFile = buildRoot <&> (-/- "test/ghcconfig")
...@@ -67,3 +73,23 @@ testRTSSettings :: Action [String] ...@@ -67,3 +73,23 @@ testRTSSettings :: Action [String]
testRTSSettings = do testRTSSettings = do
file <- testConfigFile file <- testConfigFile
words <$> lookupValueOrError file "GhcRTSWays" words <$> lookupValueOrError file "GhcRTSWays"
-- | 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 "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
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 "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
getCompilerPath compiler = pure compiler
-- | Get the full path to the given program.
fullPath :: Stage -> Package -> Action FilePath
fullPath stage pkg = programPath =<< programContext stage pkg
...@@ -3,8 +3,11 @@ module Rules.Test (testRules) where ...@@ -3,8 +3,11 @@ module Rules.Test (testRules) where
import System.Environment import System.Environment
import Base import Base
import CommandLine
import Expression import Expression
import Flavour
import Oracles.Setting import Oracles.Setting
import Oracles.TestSettings
import Packages import Packages
import Settings import Settings
import Settings.Default import Settings.Default
...@@ -16,7 +19,21 @@ ghcConfigHsPath :: FilePath ...@@ -16,7 +19,21 @@ ghcConfigHsPath :: FilePath
ghcConfigHsPath = "testsuite/mk/ghc-config.hs" ghcConfigHsPath = "testsuite/mk/ghc-config.hs"
ghcConfigProgPath :: FilePath ghcConfigProgPath :: FilePath
ghcConfigProgPath = "test/bin/ghc-config" ghcConfigProgPath = "test/bin/ghc-config" <.> exe
checkPprProgPath, checkPprSourcePath :: FilePath
checkPprProgPath = "test/bin/check-ppr" <.> exe
checkPprSourcePath = "utils/check-ppr/Main.hs"
checkApiAnnotationsProgPath, checkApiAnnotationsSourcePath :: FilePath
checkApiAnnotationsProgPath = "test/bin/check-api-annotations" <.> exe
checkApiAnnotationsSourcePath = "utils/check-api-annotations/Main.hs"
checkPrograms :: [(FilePath, FilePath)]
checkPrograms =
[ (checkPprProgPath, checkPprSourcePath)
, (checkApiAnnotationsProgPath, checkApiAnnotationsSourcePath)
]
ghcConfigPath :: FilePath ghcConfigPath :: FilePath
ghcConfigPath = "test/ghcconfig" ghcConfigPath = "test/ghcconfig"
...@@ -27,23 +44,35 @@ testRules = do ...@@ -27,23 +44,35 @@ testRules = do
root <- buildRootRules root <- buildRootRules
-- Using program shipped with testsuite to generate ghcconfig file. -- Using program shipped with testsuite to generate ghcconfig file.
root -/- ghcConfigProgPath ~> do root -/- ghcConfigProgPath %> \_ -> do
ghc <- builderPath $ Ghc CompileHs Stage0 ghc0Path <- (<.> exe) <$> getCompilerPath "stage0"
createDirectory $ takeDirectory (root -/- ghcConfigProgPath) cmd [ghc0Path] [ghcConfigHsPath, "-o" , root -/- ghcConfigProgPath]
cmd ghc [ghcConfigHsPath, "-o" , root -/- ghcConfigProgPath]
-- Rules for building check-ppr and check-ppr-annotations with the compiler
-- TODO : Use input test compiler and not just stage2 compiler. -- we are going to test (in-tree or out-of-tree).
root -/- ghcConfigPath ~> do forM_ checkPrograms $ \(progPath, sourcePath) ->
ghcPath <- needFile Stage1 ghc root -/- progPath %> \path -> do
testGhc <- testCompiler <$> userSetting defaultTestArgs
top <- topDirectory
when (testGhc `elem` ["stage1", "stage2", "stage3"]) $ do
let stg = stageOf testGhc
need . (:[]) =<< programPath (Context stg ghc vanilla)
bindir <- getBinaryDirectory testGhc
cmd [bindir </> "ghc" <.> exe]
["-package", "ghc", "-o", top -/- path, top -/- sourcePath]
root -/- ghcConfigPath %> \_ -> do
args <- userSetting defaultTestArgs
let testGhc = testCompiler args
stg = stageOf testGhc
ghcPath <- getCompilerPath testGhc
when (testGhc `elem` ["stage1", "stage2", "stage3"]) $
need . (:[]) =<< programPath (Context stg ghc vanilla)
need [root -/- ghcConfigProgPath] need [root -/- ghcConfigProgPath]
cmd [FileStdout $ root -/- ghcConfigPath] (root -/- ghcConfigProgPath) cmd [FileStdout $ root -/- ghcConfigPath] (root -/- ghcConfigProgPath)
[ghcPath] [ghcPath]
root -/- timeoutPath ~> timeoutProgBuilder root -/- timeoutPath %> \_ -> timeoutProgBuilder
"validate" ~> do
needTestBuilders
build $ target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] []
"test" ~> do "test" ~> do
needTestBuilders needTestBuilders
...@@ -52,6 +81,9 @@ testRules = do ...@@ -52,6 +81,9 @@ testRules = do
-- Prepare Ghc configuration file for input compiler. -- Prepare Ghc configuration file for input compiler.
need [root -/- ghcConfigPath, root -/- timeoutPath] need [root -/- ghcConfigPath, root -/- timeoutPath]
args <- userSetting defaultTestArgs
ghcPath <- getCompilerPath (testCompiler args)
-- TODO This approach doesn't work. -- TODO This approach doesn't work.
-- Set environment variables for test's Makefile. -- Set environment variables for test's Makefile.
env <- sequence env <- sequence
...@@ -61,18 +93,28 @@ testRules = do ...@@ -61,18 +93,28 @@ testRules = do
makePath <- builderPath $ Make "" makePath <- builderPath $ Make ""
top <- topDirectory top <- topDirectory
ghcPath <- (top -/-) <$> builderPath (Ghc CompileHs Stage2)
ghcFlags <- runTestGhcFlags ghcFlags <- runTestGhcFlags
checkPprPath <- (top -/-) <$> needFile Stage1 checkPpr let ghciFlags = ghcFlags ++ unwords
annotationsPath <- (top -/-) <$> needFile Stage1 checkApiAnnotations [ "--interactive", "-v0", "-ignore-dot-ghci"
, "-fno-ghci-history"
]
pythonPath <- builderPath Python
need [ root -/- checkPprProgPath, root -/- checkApiAnnotationsProgPath ]
-- Set environment variables for test's Makefile. -- 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 liftIO $ do
setEnv "MAKE" makePath setEnv "MAKE" makePath
setEnv "PYTHON" pythonPath
setEnv "TEST_HC" ghcPath setEnv "TEST_HC" ghcPath
setEnv "TEST_HC_OPTS" ghcFlags setEnv "TEST_HC_OPTS" ghcFlags
setEnv "CHECK_PPR" checkPprPath setEnv "TEST_HC_OPTS_INTERACTIVE" ghciFlags
setEnv "CHECK_API_ANNOTATIONS" annotationsPath setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath)
setEnv "CHECK_API_ANNOTATIONS"
(top -/- root -/- checkApiAnnotationsProgPath)
-- Execute the test target. -- Execute the test target.
-- We override the verbosity setting to make sure the user can see -- We override the verbosity setting to make sure the user can see
...@@ -80,15 +122,6 @@ testRules = do ...@@ -80,15 +122,6 @@ testRules = do
withVerbosity Loud $ buildWithCmdOptions env $ withVerbosity Loud $ buildWithCmdOptions env $
target (vanillaContext Stage2 compiler) RunTest [] [] target (vanillaContext Stage2 compiler) RunTest [] []
-- | Build extra programs and libraries required by testsuite
needTestsuitePackages :: Action ()
needTestsuitePackages = do
targets <- mapM (needFile Stage1) =<< testsuitePackages
-- iserv is not supported under Windows
windows <- windowsHost
when (not windows) needIservBins
need targets
-- | Build the timeout program. -- | Build the timeout program.
-- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23 -- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23
timeoutProgBuilder :: Action () timeoutProgBuilder :: Action ()
...@@ -108,27 +141,47 @@ timeoutProgBuilder = do ...@@ -108,27 +141,47 @@ timeoutProgBuilder = do
writeFile' (root -/- timeoutPath) script writeFile' (root -/- timeoutPath) script
makeExecutable (root -/- timeoutPath) makeExecutable (root -/- timeoutPath)
needIservBins :: Action ()
needIservBins = do
rtsways <- interpretInContext (vanillaContext Stage1 ghc) getRtsWays
need =<< traverse programPath
[ Context Stage1 iserv w
| w <- [vanilla, profiling, dynamic]
, w `elem` rtsways
]
needTestBuilders :: Action () needTestBuilders :: Action ()
needTestBuilders = do needTestBuilders = do
needBuilder $ Ghc CompileHs Stage2 testGhc <- testCompiler <$> userSetting defaultTestArgs
needBuilder $ GhcPkg Update Stage1 when (testGhc `elem` ["stage1", "stage2", "stage3"]) needTestsuitePackages
needBuilder Hpc
needBuilder $ Hsc2Hs Stage1 -- | Build extra programs and libraries required by testsuite
needTestsuitePackages needTestsuitePackages :: Action ()
needTestsuitePackages = do
testGhc <- testCompiler <$> userSetting defaultTestArgs
when (testGhc `elem` ["stage1", "stage2", "stage3"]) $ do
let stg = stageOf testGhc
allpkgs <- packages <$> flavour
stgpkgs <- allpkgs (succ stg)
testpkgs <- testsuitePackages
targets <- mapM (needFile stg) (stgpkgs ++ testpkgs)
needIservBins
need targets
-- 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
-- iserv is not supported under Windows
windows <- windowsHost
when (not windows) $ do
testGhc <- testCompiler <$> userSetting defaultTestArgs
let stg = stageOf testGhc
rtsways <- interpretInContext (vanillaContext stg ghc) getRtsWays
need =<< traverse programPath
[ Context stg iserv w
| w <- [vanilla, profiling, dynamic]
, w `elem` rtsways
]
needFile :: Stage -> Package -> Action FilePath needFile :: Stage -> Package -> Action FilePath
needFile stage pkg needFile stage pkg
-- TODO (Alp): we might sometimes need more than vanilla!
-- This should therefore depend on what test ways
-- we are going to use, I suppose?
| isLibrary pkg = pkgConfFile (Context stage pkg profilingDynamic) | isLibrary pkg = pkgConfFile (Context stage pkg profilingDynamic)
| otherwise = programPath =<< programContext stage pkg | otherwise = programPath =<< programContext stage pkg
...@@ -37,6 +37,6 @@ validateBuilderArgs = builder (Make "testsuite/tests") ? do ...@@ -37,6 +37,6 @@ validateBuilderArgs = builder (Make "testsuite/tests") ? do
-- | Support for speed of validation -- | Support for speed of validation
setTestSpeed :: TestSpeed -> String setTestSpeed :: TestSpeed -> String
setTestSpeed Fast = "fasttest" setTestSpeed TestFast = "fasttest"
setTestSpeed Average = "test" setTestSpeed TestNormal = "test"
setTestSpeed Slow = "slowtest" setTestSpeed TestSlow = "slowtest"
...@@ -39,7 +39,7 @@ runTestGhcFlags = do ...@@ -39,7 +39,7 @@ runTestGhcFlags = do
-- Take flags to send to the Haskell compiler from test.mk. -- Take flags to send to the Haskell compiler from test.mk.
-- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37 -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37
unwords <$> sequence unwords <$> sequence
[ pure " -dcore-lint -dcmm-lint -no-user-package-db -rtsopts" [ pure " -dcore-lint -dstg-lint -dcmm-lint -no-user-package-db -rtsopts"
, pure ghcOpts , pure ghcOpts
, pure ghcExtraFlags , pure ghcExtraFlags
, ifMinGhcVer "711" "-fno-warn-missed-specialisations" , ifMinGhcVer "711" "-fno-warn-missed-specialisations"
...@@ -59,18 +59,19 @@ runTestBuilderArgs = builder RunTest ? do ...@@ -59,18 +59,19 @@ runTestBuilderArgs = builder RunTest ? do
[ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ] [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
| pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ] | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
flav <- expr flavour testGhc <- expr (testCompiler <$> userSetting defaultTestArgs)
rtsWays <- expr testRTSSettings rtsWays <- expr testRTSSettings
libWays <- libraryWays flav libWays <- expr (inferLibraryWays testGhc)
let hasRtsWay w = elem w rtsWays let hasRtsWay w = elem w rtsWays
hasLibWay w = elem w libWays hasLibWay w = elem w libWays
debugged = ghcDebugged flav
hasDynamic <- getBooleanSetting TestGhcDynamic hasDynamic <- getBooleanSetting TestGhcDynamic
hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault
withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen
withInterpreter <- getBooleanSetting TestGhcWithInterpreter withInterpreter <- getBooleanSetting TestGhcWithInterpreter
unregisterised <- getBooleanSetting TestGhcUnregisterised unregisterised <- getBooleanSetting TestGhcUnregisterised
withSMP <- getBooleanSetting TestGhcWithSMP withSMP <- getBooleanSetting TestGhcWithSMP
debugged <- read <$> getTestSetting TestGhcDebugged
keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs)
windows <- expr windowsHost windows <- expr windowsHost
darwin <- expr osxHost darwin <- expr osxHost
...@@ -94,8 +95,9 @@ runTestBuilderArgs = builder RunTest ? do ...@@ -94,8 +95,9 @@ runTestBuilderArgs = builder RunTest ? do
, pure ["--rootdir=" ++ test | test <- libTests] , pure ["--rootdir=" ++ test | test <- libTests]
, arg "-e", arg $ "windows=" ++ show windows , arg "-e", arg $ "windows=" ++ show windows
, arg "-e", arg $ "darwin=" ++ show darwin , arg "-e", arg $ "darwin=" ++ show darwin
, arg "-e", arg $ "config.local=True" , arg "-e", arg $ "config.local=False"
, arg "-e", arg $ "config.cleanup=False" -- Don't clean up. , arg "-e", arg $ "config.cleanup=" ++ show (not keepFiles)
, arg "-e", arg $ "config.exeext=" ++ quote exe
, arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged) , arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged) , arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen , arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen
...@@ -116,9 +118,6 @@ runTestBuilderArgs = builder RunTest ? do ...@@ -116,9 +118,6 @@ runTestBuilderArgs = builder RunTest ? do
, arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
, arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm , arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm
-- Use default value, see:
-- https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
, arg "-e", arg $ "config.in_tree_compiler=True"
, arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite") , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
, arg "-e", arg $ "config.wordsize=" ++ show wordsize , arg "-e", arg $ "config.wordsize=" ++ show wordsize
, arg "-e", arg $ "config.os=" ++ show os , arg "-e", arg $ "config.os=" ++ show os
...@@ -137,8 +136,8 @@ getTestArgs = do ...@@ -137,8 +136,8 @@ getTestArgs = do
-- targets specified in the TEST env var -- targets specified in the TEST env var
testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST") testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
args <- expr $ userSetting defaultTestArgs args <- expr $ userSetting defaultTestArgs
bindir <- expr $ setBinaryDirectory (testCompiler args) bindir <- expr $ getBinaryDirectory (testCompiler args)
compiler <- expr $ setCompiler (testCompiler args) compiler <- expr $ getCompilerPath (testCompiler args)
globalVerbosity <- shakeVerbosity <$> expr getShakeOptions globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
let configFileArg= ["--config-file=" ++ (testConfigFile args)] let configFileArg= ["--config-file=" ++ (testConfigFile args)]
testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets) testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets)
...@@ -150,10 +149,10 @@ getTestArgs = do ...@@ -150,10 +149,10 @@ getTestArgs = do
else Nothing else Nothing
speedArg = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)] speedArg = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
summaryArg = case testSummary args of summaryArg = case testSummary args of
Just filepath -> Just $ "--summary-file" ++ quote filepath Just filepath -> Just $ "--summary-file " ++ show filepath
Nothing -> Just $ "--summary-file=testsuite_summary.txt" Nothing -> Just $ "--summary-file=testsuite_summary.txt"
junitArg = case testJUnit args of junitArg = case testJUnit args of
Just filepath -> Just $ "--junit " ++ quote filepath Just filepath -> Just $ "--junit=" ++ filepath
Nothing -> Nothing Nothing -> Nothing
configArgs = concat [["-e", configArg] | configArg <- testConfigs args] configArgs = concat [["-e", configArg] | configArg <- testConfigs args]
verbosityArg = case testVerbosity args of verbosityArg = case testVerbosity args of
...@@ -165,46 +164,72 @@ getTestArgs = do ...@@ -165,46 +164,72 @@ getTestArgs = do
haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")] haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")] hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")] hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
inTreeArg = [ "-e", "config.in_tree_compiler=" ++
show (testCompiler args `elem` ["stage1", "stage2", "stage3"]) ]
pure $ configFileArg ++ testOnlyArg ++ speedArg pure $ configFileArg ++ testOnlyArg ++ speedArg
++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
, junitArg, verbosityArg ] , junitArg, verbosityArg ]
++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg ++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
++ haddockArg ++ hp2psArg ++ hpcArg ++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
-- | 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.
-- | QUESTION : packages can be named different from their conventional names.
-- | For example, ghc-pkg can be named as ghc-pkg-version. In such cases, it will
-- | be impossible to search the binary. Only possible way will be to take user
-- | inputs for these directory also. boilerplate soes not account for this
-- | problem, but simply returns an error. How should we handle such cases?
setBinaryDirectory :: String -> Action FilePath
setBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc
setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
setBinaryDirectory compiler = pure $ parentPath compiler
-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
-- | Set Test Compiler.
setCompiler :: String -> Action FilePath
setCompiler "stage0" = setting SystemGhc
setCompiler "stage1" = liftM2 (-/-) topDirectory (fullPath Stage0 ghc)
setCompiler "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
setCompiler compiler = pure compiler
-- | Set speed for test -- | Set speed for test
setTestSpeed :: TestSpeed -> String setTestSpeed :: TestSpeed -> String
setTestSpeed Slow = "0" setTestSpeed TestSlow = "0"
setTestSpeed Average = "1" setTestSpeed TestNormal = "1"
setTestSpeed Fast = "2" setTestSpeed TestFast = "2"
-- | Returns parent path of test compiler -- | The purpose of this function is, given a compiler
-- | TODO: Is there a simpler way to find parent directory? -- (stage 1, 2, 3 or an external one), to infer the ways
parentPath :: String -> String -- that the libraries have been built in.
parentPath path = intercalate "/" $ init $ splitOn "/" path --
-- While we have this data readily available for in-tree compilers
-- | TODO: Move to Hadrian utilities. -- that we build (through the 'Flavour'), that is not the case for
fullPath :: Stage -> Package -> Action FilePath -- out-of-tree compilers that we may want to test, as is the case when
fullPath stage pkg = programPath =<< programContext stage pkg -- we are running './validate --hadrian' (it packages up a binary
-- distribution, installs it somewhere near and tests it).
--
-- We therefore proceed in a way that works regardless of whether we are
-- dealing with an in-tree compiler or not: we ask the GHC's install
-- ghc-pkg to give us the library directory of its @ghc-prim@ package and
-- look at what ways are available for the interface file of the
-- @GHC.PrimopWrappers@ module, like the Make build system does in
-- @testsuite\/mk\/test.mk@ to compute @HAVE_DYNAMIC@, @HAVE_VANILLA@
-- and @HAVE_PROFILING@:
--
-- - if we find @PrimopWrappers.hi@, we have the vanilla way;
-- - if we find @PrimopWrappers.dyn_hi@, we have the dynamic way;
-- - if we find @PrimopWrappers.p_hi@, we have the profiling way.
inferLibraryWays :: String -> Action [Way]
inferLibraryWays compiler = do
bindir <- getBinaryDirectory compiler
Stdout ghcPrimLibdirDirty <- cmd
[bindir </> "ghc-pkg" <.> exe]
["field", "ghc-prim", "library-dirs", "--simple-output"]
let ghcPrimLibdir = fixup ghcPrimLibdirDirty
ways <- catMaybes <$> traverse (lookForWay ghcPrimLibdir) candidateWays
return ways
where lookForWay dir (hifile, w) = do
exists <- doesFileExist (dir -/- hifile)
if exists then return (Just w) else return Nothing
candidateWays =
[ ("GHC/PrimopWrappers.hi", vanilla)
, ("GHC/PrimopWrappers.dyn_hi", dynamic)
, ("GHC/PrimopWrappers.p_hi", profiling)
]
-- If the ghc is in a directory with spaces in a path component,
-- 'dir' is prefixed and suffixed with double quotes.
-- In all cases, there is a \n at the end.
-- This function cleans it all up.
fixup = removeQuotes . removeNewline
removeNewline path
| "\n" `isSuffixOf` path = init path
| otherwise = path
removeQuotes path
| "\"" `isPrefixOf` path && "\"" `isSuffixOf` path = tail (init path)
| otherwise = path
...@@ -100,6 +100,7 @@ stage1Packages = do ...@@ -100,6 +100,7 @@ stage1Packages = do
, ghcPkg , ghcPkg
, ghcPrim , ghcPrim
, haskeline , haskeline
, hp2ps
, hsc2hs , hsc2hs
, intLib , intLib
, pretty , pretty
...@@ -132,7 +133,7 @@ testsuitePackages = do ...@@ -132,7 +133,7 @@ testsuitePackages = do
, ghci , ghci
, ghcCompact , ghcCompact
, ghcPkg , ghcPkg
, hp2ps , hpcBin
, hsc2hs , hsc2hs
, iserv , iserv
, runGhc , runGhc
......
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