Added support for testsuite (#602)

* Rule for testsuite dependencies

* Separated validate builder arguments

* Added RunTest config options

* added support to set test speed with runtest

* Fixed minor bug with testConfigs

Removed indentation error

* Added support for more testing features

* Rectified Merge Errors

* Removed need rule for Hp2ps

* using all available threads

* Minor Revision

* Removed TestThread argument

* Update Utilities.hs

src/CommandLine.hs

@@ -1,7 +1,8 @@
 module CommandLine (
     optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
     cmdProgressColour, cmdProgressInfo, cmdConfigure, cmdSplitObjects,
-    cmdInstallDestDir, lookupBuildRoot, TestArgs(..), defaultTestArgs
+    cmdInstallDestDir, lookupBuildRoot, TestArgs(..), TestSpeed(..), 
+    defaultTestArgs
     ) where
 
 import Data.Either
@@ -12,6 +13,8 @@ import Hadrian.Utilities hiding (buildRoot)
 import System.Console.GetOpt
 import System.Environment
 
+data TestSpeed = Slow | Average | Fast deriving (Show, Eq)
+
 -- | All arguments that can be passed to Hadrian via the command line.
 data CommandLineArgs = CommandLineArgs
     { configure      :: Bool
@@ -42,21 +45,29 @@ defaultCommandLineArgs = CommandLineArgs
 
 -- | These arguments are used by the `test` target.
 data TestArgs = TestArgs
-    { testOnly     :: Maybe String
+    { testConfigs  :: [String]
+    , testJUnit    :: Maybe FilePath
+    , testOnly     :: Maybe String
+    , testOnlyPerf :: Bool
     , testSkipPerf :: Bool
+    , testSpeed    :: TestSpeed
     , testSummary  :: Maybe FilePath
-    , testJUnit    :: Maybe FilePath
-    , testConfigs  :: [String] }
+    , testVerbosity:: Maybe String
+    , testWays     :: [String] }
     deriving (Eq, Show)
 
 -- | Default value for `TestArgs`.
 defaultTestArgs :: TestArgs
 defaultTestArgs = TestArgs
-    { testOnly     = Nothing
+    { testConfigs  = []
+    , testJUnit    = Nothing
+    , testOnly     = Nothing
+    , testOnlyPerf = False
     , testSkipPerf = False
+    , testSpeed    = Average
     , testSummary  = Nothing
-    , testJUnit    = Nothing
-    , testConfigs  = [] }
+    , testVerbosity= Nothing
+    , testWays     = [] }
 
 readConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
 readConfigure = Right $ \flags -> flags { configure = True }
@@ -110,26 +121,52 @@ readProgressInfo ms =
 readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
 readSplitObjects = Right $ \flags -> flags { splitObjects = True }
 
+readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestConfig config =
+    case config of
+         Nothing -> Right id
+         Just conf -> Right $ \flags ->
+                        let configs = conf : testConfigs (testArgs flags)
+                        in flags { testArgs = (testArgs flags) { testConfigs = configs } }
+
+readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
+
 readTestOnly :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
 readTestOnly tests = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnly = tests } }
 
+readTestOnlyPerf :: Either String (CommandLineArgs -> CommandLineArgs)
+readTestOnlyPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnlyPerf = True } }
+
 readTestSkipPerf :: Either String (CommandLineArgs -> CommandLineArgs)
 readTestSkipPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testSkipPerf = True } }
 
+readTestSpeed :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestSpeed ms =
+    maybe (Left "Cannot parse test-speed") (Right . set) (go =<< lower <$> ms)
+  where
+    go :: String -> Maybe TestSpeed
+    go "fast"    = Just Fast
+    go "slow"    = Just Slow
+    go "average" = Just Average
+    go _         = Nothing
+    set :: TestSpeed -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { testArgs = (testArgs flags) {testSpeed = flag} }
+
 readTestSummary :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
 readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
 
-readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
-
-readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readTestConfig config =
-    case config of
-         Nothing -> Right id
-         Just conf -> Right $ \flags ->
-                        let configs = conf : testConfigs (testArgs flags)
-                         in flags { testArgs = (testArgs flags) { testConfigs = configs } }
-
+readTestVerbose :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestVerbose verbose = Right $ \flags -> flags { testArgs = (testArgs flags) { testVerbosity = verbose } }
+
+readTestWay :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestWay ways = 
+    case ways of
+        Nothing -> Right id
+        Just way -> Right $ \flags -> 
+            let newWays = way : testWays (testArgs flags)
+            in flags { testArgs = (testArgs flags) {testWays = newWays} }
+ 
 -- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
 optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
 optDescrs =
@@ -151,17 +188,25 @@ optDescrs =
       "Progress info style (None, Brief, Normal or Unicorn)."
     , Option [] ["split-objects"] (NoArg readSplitObjects)
       "Generate split objects (requires a full clean rebuild)."
+    , Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG")
+      "Configurations to run test, in key=value format."
+    , Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT")
+      "Output testsuite summary in JUnit format."
     , Option [] ["only"] (OptArg readTestOnly "TESTS")
       "Test cases to run."
+    , Option [] ["only-perf"] (NoArg readTestOnlyPerf)
+      "Only run performance tests."
     , Option [] ["skip-perf"] (NoArg readTestSkipPerf)
       "Skip performance tests."
+    , Option [] ["test-speed"] (OptArg readTestSpeed "SPEED")
+      "fast, slow or normal. Normal by default"
     , Option [] ["summary"] (OptArg readTestSummary "TEST_SUMMARY")
       "Where to output the test summary file."
-    , Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT")
-      "Output testsuite summary in JUnit format."
-    , Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG")
-      "Configurations to run test, in key=value format." ]
-
+    , Option [] ["test-verbose"] (OptArg readTestVerbose "TEST_VERBOSE")
+      "A verbosity value between 0 and 5. 0 is silent, 4 and higher activates extra output."
+    , Option [] ["test-way"] (OptArg readTestWay "TEST_WAY")
+      "only run these ways" ]
+    
 -- | A type-indexed map containing Hadrian command line arguments to be passed
 -- to Shake via 'shakeExtra'.
 cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)

src/GHC.hs

@@ -1,14 +1,15 @@
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 module GHC (
     -- * GHC packages
-    array, base, binary, bytestring, cabal, checkPpr, compareSizes, compiler,
-    containers, deepseq, deriveConstants, directory, filepath, genapply,
-    genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCabal, ghcCompact, ghcHeap, ghci,
-    ghcPkg, ghcPrim, ghcTags, ghcSplit, haddock, haskeline, hsc2hs, hp2ps, hpc,
-    hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl, parsec,
-    parallel, pretty, process, rts, runGhc, stm, templateHaskell, terminfo,
-    text, time, touchy, transformers, unlit, unix, win32, xhtml, ghcPackages,
-    isGhcPackage, defaultPackages, testsuitePackages,
+    array, base, binary, bytestring, cabal, checkApiAnnotations, checkPpr, 
+    compareSizes, compiler, containers, deepseq, deriveConstants, directory,
+    filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCabal,
+    ghcCompact, ghcHeap, ghci, ghcPkg, ghcPrim, ghcTags, ghcSplit, haddock, 
+    haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, 
+    libffi, libiserv, mtl, parsec, parallel, pretty, primitive, process, rts, 
+    runGhc, stm, templateHaskell, terminfo, text, time, touchy, transformers, 
+    unlit, unix, win32, xhtml, ghcPackages, isGhcPackage, defaultPackages, 
+    testsuitePackages,
 
     -- * Package information
     programName, nonCabalContext, nonHsMainPackage, autogenPath, installStage,
@@ -103,7 +104,9 @@ stage2Packages = return [haddock]
 
 -- | Packages that are built only for the testsuite.
 testsuitePackages :: Action [Package]
-testsuitePackages = return [checkPpr]
+testsuitePackages = return [ checkApiAnnotations
+                           , checkPpr
+                           , hp2ps              ] 
 
 -- | Given a 'Context', compute the name of the program that is built in it
 -- assuming that the corresponding package's type is 'Program'. For example, GHC

src/GHC/Packages.hs

@@ -11,13 +11,13 @@ import Hadrian.Utilities
 -- modify build default build conditions in "UserSettings".
 ghcPackages :: [Package]
 ghcPackages =
-    [ array, base, binary, bytestring, cabal, checkPpr, compareSizes, compiler
-    , containers, deepseq, deriveConstants, directory, filepath, genapply
-    , genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCompact, ghcHeap, ghci, ghcPkg
-    , ghcPrim, ghcTags, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp
-    , integerSimple, iserv, libffi, libiserv, mtl, parsec, parallel, pretty
-    , process, rts, runGhc, stm, templateHaskell, terminfo, text, time, touchy
-    , transformers, unlit, unix, win32, xhtml ]
+    [ array, base, binary, bytestring, cabal, checkPpr, checkApiAnnotations
+    , compareSizes, compiler, containers, deepseq, deriveConstants, directory
+    , filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCompact
+    , ghcHeap, ghci, ghcPkg, ghcPrim, ghcTags, haddock, haskeline, hsc2hs, hp2ps
+    , hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl
+    , parsec, parallel, pretty, process, rts, runGhc, stm, templateHaskell
+    , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml ]
 
 -- TODO: Optimise by switching to sets of packages.
 isGhcPackage :: Package -> Bool
@@ -29,6 +29,7 @@ base                = hsLib  "base"
 binary              = hsLib  "binary"
 bytestring          = hsLib  "bytestring"
 cabal               = hsLib  "Cabal"           `setPath` "libraries/Cabal/Cabal"
+checkApiAnnotations = hsUtil "check-api-annotations"
 checkPpr            = hsUtil "check-ppr"
 compareSizes        = hsUtil "compareSizes"    `setPath` "utils/compare_sizes"
 compiler            = hsTop  "ghc"             `setPath` "compiler"

src/Rules/Test.hs

@@ -5,6 +5,7 @@ import Expression
 import GHC
 import Oracles.Flag
 import Oracles.Setting
+import Settings
 import Target
 import Utilities
 
@@ -63,13 +64,23 @@ testRules = do
         -- Execute the test target.
         buildWithCmdOptions env $ target (vanillaContext Stage2 compiler) RunTest [] []
 
+-- | Build extra programs required by testsuite
+needTestsuiteBuilders :: Action ()
+needTestsuiteBuilders = do
+    targets <- mapM (needfile Stage1) =<< testsuitePackages
+    need targets
+  where
+    needfile :: Stage -> Package -> Action FilePath
+    needfile stage pkg = programPath =<< programContext stage pkg
+
+
 needTestBuilders :: Action ()
 needTestBuilders = do
     needBuilder $ Ghc CompileHs Stage2
     needBuilder $ GhcPkg Update Stage1
-    needBuilder Hp2Ps
     needBuilder Hpc
     needBuilder (Hsc2Hs Stage1)
+    needTestsuiteBuilders
 
 -- | Extra flags to send to the Haskell compiler to run tests.
 runTestGhcFlags :: Action String

src/Settings/Builders/Make.hs

@@ -1,5 +1,7 @@
-module Settings.Builders.Make (makeBuilderArgs) where
+module Settings.Builders.Make (makeBuilderArgs, validateBuilderArgs) where
 
+import GHC
+import Oracles.Setting
 import Rules.Gmp
 import Rules.Libffi
 import Settings.Builders.Common
@@ -13,5 +15,22 @@ makeBuilderArgs = do
     mconcat
         [ builder (Make gmpPath          ) ? pure ["MAKEFLAGS=-j" ++ t]
         , builder (Make libffiPath       ) ? pure ["MAKEFLAGS=-j" ++ t, "install"]
-        , builder (Make "testsuite/tests") ? pure ["THREADS=" ++ t, "fast"]
         ]
+
+validateBuilderArgs :: Args
+validateBuilderArgs = builder (Make "testsuite/tests") ? do
+    threads             <- shakeThreads <$> expr getShakeOptions
+    top                 <- expr topDirectory
+    compiler            <- expr $ fullpath ghc
+    checkPpr            <- expr $ fullpath checkPpr
+    checkApiAnnotations <- expr $ fullpath checkApiAnnotations
+    return [ "fast"
+           , "THREADS=" ++ show threads
+           , "TEST_HC=" ++ (top -/- compiler)
+           , "CHECK_PPR=" ++ (top -/- checkPpr)
+           , "CHECK_API_ANNOTATIONS=" ++ (top -/- checkApiAnnotations)
+           ]
+  where
+    fullpath :: Package -> Action FilePath
+    fullpath pkg = programPath =<< programContext Stage1 pkg
+

src/Settings/Builders/RunTest.hs

@@ -1,10 +1,11 @@
 module Settings.Builders.RunTest (runTestBuilderArgs) where
 
-import CommandLine (TestArgs(..), defaultTestArgs)
+import CommandLine (TestArgs(..), defaultTestArgs, TestSpeed(..))
 import Flavour
 import GHC.Packages
 import Hadrian.Builder (getBuilderPath)
 import Hadrian.Utilities
+import Oracles.Setting (setting)
 import Rules.Test
 import Settings.Builders.Common
 
@@ -28,7 +29,9 @@ runTestBuilderArgs = builder RunTest ? do
 
     threads  <- shakeThreads <$> expr getShakeOptions
     verbose  <- shakeVerbosity <$> expr getShakeOptions
-
+    os       <- expr $ setting TargetOs
+    arch     <- expr $ setting TargetArch
+    platform <- expr $ setting TargetPlatform
     top      <- expr topDirectory
     compiler <- getBuilderPath $ Ghc CompileHs Stage2
     ghcPkg   <- getBuilderPath $ GhcPkg Update Stage1
@@ -71,7 +74,12 @@ runTestBuilderArgs = builder RunTest ? do
             , arg "-e", arg $ "config.ghc_dynamic=False"              -- TODO: support dynamic
 
             , arg "-e", arg $ "config.in_tree_compiler=True"          -- Use default value, see https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
-
+            , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
+            , arg "-e", arg $ "config.wordsize=\"64\""
+            , arg "-e", arg $ "config.os="       ++ show os
+            , arg "-e", arg $ "config.arch="     ++ show arch
+            , arg "-e", arg $ "config.platform=" ++ show platform 
+
             , arg "--config-file=testsuite/config/ghc"
             , arg "--config", arg $ "compiler="     ++ show (top -/- compiler)
             , arg "--config", arg $ "ghc_pkg="      ++ show (top -/- ghcPkg)
@@ -92,15 +100,34 @@ getTestArgs = do
     let testOnlyArg = case testOnly args of
                         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 = map ("-e " ++) (testConfigs args)
+        configArgs = concat [["-e", configArg] | configArg <- testConfigs args]
+        verbosityArg = case testVerbosity args of
+                         Nothing -> Nothing
+                         Just verbosity -> Just $ "--verbose=" ++ verbosity
+        wayArgs    = map ("--way=" ++) (testWays args) 
+    pure $  testOnlyArg
+         ++ speedArg 
+         ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
+                      , junitArg, verbosityArg  ] 
+         ++ configArgs
+         ++ wayArgs
+
+-- | Set speed for test
+setTestSpeed :: TestSpeed -> String
+setTestSpeed Fast    = "2"
+setTestSpeed Average = "1"
+setTestSpeed Slow    = "0"
 
-    pure $ testOnlyArg ++ catMaybes [skipPerfArg, summaryArg, junitArg] ++ configArgs

src/Settings/Default.hs

@@ -139,6 +139,7 @@ defaultBuilderArgs = mconcat
     , ldBuilderArgs
     , makeBuilderArgs
     , runTestBuilderArgs
+    , validateBuilderArgs
     , xelatexBuilderArgs
     -- Generic builders from the Hadrian library:
     , builder (Ar Pack     ) ? Hadrian.Builder.Ar.args Pack