RunTest.hs 10 KB
Newer Older
1
module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags) where
2

3
import Hadrian.Utilities
4 5 6 7
import System.Environment

import CommandLine
import Flavour
8
import Oracles.Setting (setting)
9
import Oracles.TestSettings
10
import Packages
11 12
import Settings.Builders.Common

13 14
getTestSetting :: TestSetting -> Expr String
getTestSetting key = expr $ testSetting key
15

16 17 18 19 20
-- | Parse the value of a Boolean test setting or report an error.
getBooleanSetting :: TestSetting -> Expr Bool
getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key
  where
    msg = "Cannot parse test setting " ++ quote (show key)
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
-- | 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"
        ]

52 53
-- Command line arguments for invoking the @runtest.py@ script. A lot of this
-- mirrors @testsuite/mk/test.mk@.
54 55 56 57 58 59 60
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 ]

61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
    flav    <- expr flavour
    rtsWays <- expr testRTSSettings
    libWays <- libraryWays flav
    let hasRtsWay w = elem w rtsWays
        hasLibWay w = elem w libWays
        debugged    = ghcDebugged flav
    hasDynamic          <- getBooleanSetting TestGhcDynamic
    hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault
    withNativeCodeGen   <- getBooleanSetting TestGhcWithNativeCodeGen
    withInterpreter     <- getBooleanSetting TestGhcWithInterpreter
    unregisterised      <- getBooleanSetting TestGhcUnregisterised
    withSMP             <- getBooleanSetting TestGhcWithSMP

    windows     <- expr windowsHost
    darwin      <- expr osxHost
    threads     <- shakeThreads <$> expr getShakeOptions
    os          <- getTestSetting TestHostOS
    arch        <- getTestSetting TestTargetARCH_CPP
    platform    <- getTestSetting TestTARGETPLATFORM
    wordsize    <- getTestSetting TestWORDSIZE
    top         <- expr $ topDirectory
82
    ghcFlags    <- expr runTestGhcFlags
83
    timeoutProg <- expr buildRoot <&> (-/- timeoutPath)
84

85 86 87
    -- See #16087
    let ghcBuiltByLlvm = False -- TODO: Implement this check

88
    let asZeroOne s b = s ++ zeroOne b
89

90
    -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
91 92 93 94 95 96
    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.local=True"
97
            , arg "-e", arg $ "config.cleanup=False" -- Don't clean up.
98 99
            , arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
            , arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
100
            , arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen
101 102 103 104 105

            , arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
            , arg "-e", arg $ "config.unregisterised=" ++ show unregisterised

            , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
106 107 108 109 110 111
            , arg "-e", arg $ asZeroOne "ghc_with_dynamic_rts="  (hasRtsWay "dyn")
            , arg "-e", arg $ asZeroOne "ghc_with_threaded_rts=" (hasRtsWay "thr")
            , arg "-e", arg $ asZeroOne "config.have_vanilla="   (hasLibWay vanilla)
            , arg "-e", arg $ asZeroOne "config.have_dynamic="   (hasLibWay dynamic)
            , arg "-e", arg $ asZeroOne "config.have_profiling=" (hasLibWay profiling)
            , arg "-e", arg $ asZeroOne "ghc_with_smp=" withSMP
112
            , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
113

114 115
            , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
            , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
116
            , arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm
117

118 119 120
            -- Use default value, see:
            -- https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
            , arg "-e", arg $ "config.in_tree_compiler=True"
121
            , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
122
            , arg "-e", arg $ "config.wordsize=" ++ show wordsize
123 124
            , arg "-e", arg $ "config.os="       ++ show os
            , arg "-e", arg $ "config.arch="     ++ show arch
Andrey Mokhov's avatar
Andrey Mokhov committed
125 126
            , arg "-e", arg $ "config.platform=" ++ show platform

127 128 129 130 131 132
            , 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
            , getTestArgs -- User-provided arguments from command line.
            ]

133
-- | Command line arguments for running GHC's test script.
134 135
getTestArgs :: Args
getTestArgs = do
136 137
    -- targets specified in the TEST env var
    testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
138 139 140
    args            <- expr $ userSetting defaultTestArgs
    bindir          <- expr $ setBinaryDirectory (testCompiler args)
    compiler        <- expr $ setCompiler (testCompiler args)
141
    globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
142
    let configFileArg= ["--config-file=" ++ (testConfigFile args)]
143
        testOnlyArg  =  map ("--only=" ++) (testOnly args ++ testEnvTargets)
144 145 146 147 148 149 150 151 152 153 154 155 156 157
        onlyPerfArg  = if testOnlyPerf args
                           then Just "--only-perf-tests"
                           else Nothing
        skipPerfArg  = if testSkipPerf args
                           then Just "--skip-perf-tests"
                           else Nothing
        speedArg     = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
        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   = concat [["-e", configArg] | configArg <- testConfigs args]
158
        verbosityArg = case testVerbosity args of
159 160
                           Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
                           Just verbosity -> Just $ "--verbose=" ++ verbosity
161
        wayArgs      = map ("--way=" ++) (testWays args)
162 163 164 165
        compilerArg  = ["--config", "compiler=" ++ show (compiler)]
        ghcPkgArg    = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
        haddockArg   = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
        hp2psArg     = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
166 167
        hpcArg       = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
    pure $  configFileArg ++ testOnlyArg ++ speedArg
168
         ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
169
                      , junitArg, verbosityArg  ]
170 171 172
         ++ configArgs ++ wayArgs ++  compilerArg ++ ghcPkgArg
         ++ haddockArg ++ hp2psArg ++ hpcArg

173
-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
174
-- | Directory to look for Binaries
175
-- | We assume that required programs are present in the same binary directory
176 177 178
-- | 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
179 180
-- | 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
181 182
-- | problem, but simply returns an error. How should we handle such cases?
setBinaryDirectory :: String -> Action FilePath
183
setBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc
184 185
setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
186 187
setBinaryDirectory compiler = pure $ parentPath compiler

188 189
-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
-- | Set Test Compiler.
190 191
setCompiler :: String -> Action FilePath
setCompiler "stage0" = setting SystemGhc
192 193
setCompiler "stage1" = liftM2 (-/-) topDirectory (fullPath Stage0 ghc)
setCompiler "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
194
setCompiler compiler = pure compiler
195 196 197 198

-- | Set speed for test
setTestSpeed :: TestSpeed -> String
setTestSpeed Slow    = "0"
199 200
setTestSpeed Average = "1"
setTestSpeed Fast    = "2"
201

202
-- | Returns parent path of test compiler
203
-- | TODO: Is there a simpler way to find parent directory?
204
parentPath :: String -> String
205
parentPath path = intercalate "/" $ init $ splitOn "/" path
206

207 208 209
-- | TODO: Move to Hadrian utilities.
fullPath :: Stage -> Package -> Action FilePath
fullPath stage pkg = programPath =<< programContext stage pkg