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

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

import CommandLine
7
import Oracles.TestSettings
8
import Packages
9 10
import Settings.Builders.Common

11 12
getTestSetting :: TestSetting -> Expr String
getTestSetting key = expr $ testSetting key
13

14 15 16 17 18
-- | 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)
19

20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
-- | 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
40
        [ pure " -dcore-lint -dstg-lint -dcmm-lint -no-user-package-db -rtsopts"
41 42 43 44 45 46
        , 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"
47
        , pure "-Werror=compat" -- See #15278
48 49 50
        , pure "-dno-debug-output"
        ]

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

60
    testGhc <- expr (testCompiler <$> userSetting defaultTestArgs)
61
    rtsWays <- expr testRTSSettings
62
    libWays <- expr (inferLibraryWays testGhc)
63 64 65 66 67 68 69 70
    let hasRtsWay w = elem w rtsWays
        hasLibWay w = elem w libWays
    hasDynamic          <- getBooleanSetting TestGhcDynamic
    hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault
    withNativeCodeGen   <- getBooleanSetting TestGhcWithNativeCodeGen
    withInterpreter     <- getBooleanSetting TestGhcWithInterpreter
    unregisterised      <- getBooleanSetting TestGhcUnregisterised
    withSMP             <- getBooleanSetting TestGhcWithSMP
71
    debugged            <- getBooleanSetting TestGhcDebugged
72
    keepFiles           <- expr (testKeepFiles <$> userSetting defaultTestArgs)
73

74 75 76 77
    accept <- expr (testAccept <$> userSetting defaultTestArgs)
    (acceptPlatform, acceptOS) <- expr . liftIO $
        (,) <$> (maybe False (=="YES") <$> lookupEnv "PLATFORM")
            <*> (maybe False (=="YES") <$> lookupEnv "OS")
78 79
    (testEnv, testMetricsFile) <- expr . liftIO $
        (,) <$> lookupEnv "TEST_ENV" <*> lookupEnv "METRICS_FILE"
80

81 82 83 84 85 86
    threads     <- shakeThreads <$> expr getShakeOptions
    os          <- getTestSetting TestHostOS
    arch        <- getTestSetting TestTargetARCH_CPP
    platform    <- getTestSetting TestTARGETPLATFORM
    wordsize    <- getTestSetting TestWORDSIZE
    top         <- expr $ topDirectory
87
    ghcFlags    <- expr runTestGhcFlags
88 89 90 91
    cmdrootdirs <- expr (testRootDirs <$> userSetting defaultTestArgs)
    let defaultRootdirs = ("testsuite" -/- "tests") : libTests
        rootdirs | null cmdrootdirs = defaultRootdirs
                 | otherwise        = cmdrootdirs
92 93 94 95
    root        <- expr buildRoot
    let timeoutProg = root -/- timeoutPath
    statsFilesDir <- expr haddockStatsFilesDir

96 97 98
    -- See #16087
    let ghcBuiltByLlvm = False -- TODO: Implement this check

99 100
    let asBool :: String -> Bool -> String
        asBool s b = s ++ show b
101

102
    -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
103
    mconcat [ arg $ "testsuite/driver/runtests.py"
104
            , pure [ "--rootdir=" ++ testdir | testdir <- rootdirs ]
105 106
            , arg "-e", arg $ "windows=" ++ show windowsHost
            , arg "-e", arg $ "darwin=" ++ show osxHost
107 108
            , arg "-e", arg $ "config.local=False"
            , arg "-e", arg $ "config.cleanup=" ++ show (not keepFiles)
109 110 111
            , arg "-e", arg $ "config.accept=" ++ show accept
            , arg "-e", arg $ "config.accept_platform=" ++ show acceptPlatform
            , arg "-e", arg $ "config.accept_os=" ++ show acceptOS
112
            , arg "-e", arg $ "config.exeext=" ++ quote exe
113 114
            , arg "-e", arg $ "config.compiler_debugged=" ++
              show debugged
115
            , arg "-e", arg $ asBool "ghc_with_native_codegen=" withNativeCodeGen
116 117 118 119 120

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

            , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
121 122 123 124 125 126
            , arg "-e", arg $ asBool "ghc_with_dynamic_rts="  (hasRtsWay "dyn")
            , arg "-e", arg $ asBool "ghc_with_threaded_rts=" (hasRtsWay "thr")
            , arg "-e", arg $ asBool "config.have_vanilla="   (hasLibWay vanilla)
            , arg "-e", arg $ asBool "config.have_dynamic="   (hasLibWay dynamic)
            , arg "-e", arg $ asBool "config.have_profiling=" (hasLibWay profiling)
            , arg "-e", arg $ asBool "ghc_with_smp=" withSMP
127
            , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
128

129 130
            , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
            , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
131
            , arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm
132

133
            , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
134
            , arg "-e", arg $ "config.wordsize=" ++ show wordsize
135 136
            , arg "-e", arg $ "config.os="       ++ show os
            , arg "-e", arg $ "config.arch="     ++ show arch
Andrey Mokhov's avatar
Andrey Mokhov committed
137 138
            , arg "-e", arg $ "config.platform=" ++ show platform

139 140
            , arg "--config", arg $ "gs=gs"                           -- Use the default value as in test.mk
            , arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg)
141
            , arg "--config", arg $ "stats_files_dir=" ++ statsFilesDir
142
            , arg $ "--threads=" ++ show threads
143 144 145
            , emitWhenSet testEnv $ \env -> arg ("--test-env=" ++ show env)
            , emitWhenSet testMetricsFile $ \file -> mconcat
                [ arg "--metrics-file", arg (show file) ]
146 147 148
            , getTestArgs -- User-provided arguments from command line.
            ]

149 150 151
      where emitWhenSet Nothing  _ = mempty
            emitWhenSet (Just v) f = f v

152
-- | Command line arguments for running GHC's test script.
153 154
getTestArgs :: Args
getTestArgs = do
155 156
    -- targets specified in the TEST env var
    testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
157
    args            <- expr $ userSetting defaultTestArgs
158 159
    bindir          <- expr $ getBinaryDirectory (testCompiler args)
    compiler        <- expr $ getCompilerPath (testCompiler args)
160
    globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
161
    haveDocs        <- areDocsPresent
162
    let configFileArg= ["--config-file=" ++ (testConfigFile args)]
163
        testOnlyArg  =  map ("--only=" ++) (testOnly args ++ testEnvTargets)
164 165 166 167 168 169 170 171
        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
172
                           Just filepath -> Just $ "--summary-file " ++ show filepath
173 174
                           Nothing -> Just $ "--summary-file=testsuite_summary.txt"
        junitArg     = case testJUnit args of
175
                           Just filepath -> Just $ "--junit=" ++ filepath
176 177
                           Nothing -> Nothing
        configArgs   = concat [["-e", configArg] | configArg <- testConfigs args]
178
        verbosityArg = case testVerbosity args of
179 180
                           Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
                           Just verbosity -> Just $ "--verbose=" ++ verbosity
181
        wayArgs      = map ("--way=" ++) (testWays args)
182 183
        compilerArg  = ["--config", "compiler=" ++ show (compiler)]
        ghcPkgArg    = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
184 185 186
        haddockArg   = if haveDocs
          then [ "--config", "haddock=" ++ show (bindir -/- "haddock") ]
          else [ "--config", "haddock=" ]
187
        hp2psArg     = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
188
        hpcArg       = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
189 190 191
        inTreeArg    = [ "-e", "config.in_tree_compiler=" ++
          show (testCompiler args `elem` ["stage1", "stage2", "stage3"]) ]

192
    pure $  configFileArg ++ testOnlyArg ++ speedArg
193
         ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
194
                      , junitArg, verbosityArg  ]
195
         ++ configArgs ++ wayArgs ++  compilerArg ++ ghcPkgArg
196
         ++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
197

198 199 200 201 202 203 204 205 206 207 208
  where areDocsPresent = expr $ do
          root <- buildRoot
          and <$> traverse doesFileExist (docFiles root)

        docFiles root =
          [ root -/- "docs" -/- "html" -/- "libraries" -/- p -/- (p ++ ".haddock")
          -- list of packages from
          -- utils/haddock/haddock-test/src/Test/Haddock/Config.hs
          | p <- [ "array", "base", "ghc-prim", "process", "template-haskell" ]
          ]

209 210
-- | Set speed for test
setTestSpeed :: TestSpeed -> String
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
setTestSpeed TestSlow   = "0"
setTestSpeed TestNormal = "1"
setTestSpeed TestFast   = "2"

-- | The purpose of this function is, given a compiler
--   (stage 1, 2, 3 or an external one), to infer the ways
--   that the libraries have been built in.
--
--   While we have this data readily available for in-tree compilers
--   that we build (through the 'Flavour'), that is not the case for
--   out-of-tree compilers that we may want to test, as is the case when
--   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