RunTest.hs 9.82 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
    let asZeroOne s b = s ++ zeroOne b
86

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

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

            , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
103 104 105 106 107 108
            , 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
109
            , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
110

111 112
            , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
            , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
113

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

123 124 125 126 127 128
            , 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.
            ]

129
-- | Command line arguments for running GHC's test script.
130 131
getTestArgs :: Args
getTestArgs = do
132 133 134
    args            <- expr $ userSetting defaultTestArgs
    bindir          <- expr $ setBinaryDirectory (testCompiler args)
    compiler        <- expr $ setCompiler (testCompiler args)
135
    globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
136 137
    let configFileArg= ["--config-file=" ++ (testConfigFile args)]
        testOnlyArg  = case testOnly args of
138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
                           Just cases -> map ("--only=" ++) (words cases)
                           Nothing -> []
        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]
154
        verbosityArg = case testVerbosity args of
155 156
                           Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
                           Just verbosity -> Just $ "--verbose=" ++ verbosity
157
        wayArgs      = map ("--way=" ++) (testWays args)
158 159 160 161
        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")]
162 163
        hpcArg       = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
    pure $  configFileArg ++ testOnlyArg ++ speedArg
164
         ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
165
                      , junitArg, verbosityArg  ]
166 167 168
         ++ configArgs ++ wayArgs ++  compilerArg ++ ghcPkgArg
         ++ haddockArg ++ hp2psArg ++ hpcArg

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

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

-- | Set speed for test
setTestSpeed :: TestSpeed -> String
setTestSpeed Slow    = "0"
195 196
setTestSpeed Average = "1"
setTestSpeed Fast    = "2"
197

198
-- | Returns parent path of test compiler
199
-- | TODO: Is there a simpler way to find parent directory?
200
parentPath :: String -> String
201
parentPath path = intercalate "/" $ init $ splitOn "/" path
202

203 204 205
-- | TODO: Move to Hadrian utilities.
fullPath :: Stage -> Package -> Action FilePath
fullPath stage pkg = programPath =<< programContext stage pkg