RunTest.hs 10.1 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
    integerLib  <- expr (integerLibrary flav)
85

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

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

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

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

            , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
107 108 109 110 111 112
            , 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
113
            , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
114

115 116
            , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
            , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
117
            , arg "-e", arg $ "config.integer_backend=" ++ show (pkgName integerLib)
118
            , arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm
119

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

129 130 131 132 133 134
            , 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.
            ]

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

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

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

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

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

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