Add test compiler option to test (#621)
authorChitrak Raj Gupta <chitrak711988@gmail.com>
Thu, 14 Jun 2018 21:53:24 +0000 (03:23 +0530)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 14 Jun 2018 21:53:24 +0000 (22:53 +0100)
* Rule for testsuite dependencies

* Added RunTest config options

* added support to set test speed with runtest

* Added support for more testing features

* Rectified Merge Errors

* using all available threads

* Minor Revision

* Removed TestThread argument

* Update Utilities.hs

* Added support to choose test compiler

* Minor Revision

* Added comments

* Update RunTest.hs

* Update CommandLine.hs

* Update RunTest.hs

src/CommandLine.hs
src/Oracles/Setting.hs
src/Rules/Test.hs
src/Settings/Builders/RunTest.hs

index b86b448..18ddbbc 100644 (file)
@@ -45,7 +45,8 @@ defaultCommandLineArgs = CommandLineArgs
 
 -- | These arguments are used by the `test` target.
 data TestArgs = TestArgs
-    { testConfigs  :: [String]
+    { testCompiler :: String
+    , testConfigs  :: [String]
     , testJUnit    :: Maybe FilePath
     , testOnly     :: Maybe String
     , testOnlyPerf :: Bool
@@ -59,7 +60,8 @@ data TestArgs = TestArgs
 -- | Default value for `TestArgs`.
 defaultTestArgs :: TestArgs
 defaultTestArgs = TestArgs
-    { testConfigs  = []
+    { testCompiler = "stage2"
+    , testConfigs  = []
     , testJUnit    = Nothing
     , testOnly     = Nothing
     , testOnlyPerf = False
@@ -121,6 +123,11 @@ readProgressInfo ms =
 readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
 readSplitObjects = Right $ \flags -> flags { splitObjects = True }
 
+readTestCompiler :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestCompiler compiler = maybe (Left "Cannot parse compiler") (Right . set) compiler  
+  where
+     set compiler  = \flags -> flags { testArgs = (testArgs flags) { testCompiler = compiler } }
+
 readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
 readTestConfig config =
     case config of
@@ -160,8 +167,8 @@ readTestVerbose :: Maybe String -> Either String (CommandLineArgs -> CommandLine
 readTestVerbose verbose = Right $ \flags -> flags { testArgs = (testArgs flags) { testVerbosity = verbose } }
 
 readTestWay :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readTestWay ways = 
-    case ways of
+readTestWay way = 
+    case way of
         Nothing -> Right id
         Just way -> Right $ \flags -> 
             let newWays = way : testWays (testArgs flags)
@@ -188,6 +195,8 @@ optDescrs =
       "Progress info style (None, Brief, Normal or Unicorn)."
     , Option [] ["split-objects"] (NoArg readSplitObjects)
       "Generate split objects (requires a full clean rebuild)."
+    , Option [] ["test-compiler"] (OptArg readTestCompiler "TEST_COMPILER")
+      "Use given compiler [Default=stage2]."
     , Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG")
       "Configurations to run test, in key=value format."
     , Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT")
index aa49011..52840c7 100644 (file)
@@ -41,6 +41,7 @@ data Setting = BuildArch
              | ProjectPatchLevel
              | ProjectPatchLevel1
              | ProjectPatchLevel2
+             | SystemGhc
              | TargetArch
              | TargetOs
              | TargetPlatform
@@ -100,6 +101,7 @@ setting key = lookupValueOrError configFile $ case key of
     ProjectPatchLevel  -> "project-patch-level"
     ProjectPatchLevel1 -> "project-patch-level1"
     ProjectPatchLevel2 -> "project-patch-level2"
+    SystemGhc          -> "system-ghc"
     TargetArch         -> "target-arch"
     TargetOs           -> "target-os"
     TargetPlatform     -> "target-platform"
index dac2b2a..c74cf58 100644 (file)
@@ -73,7 +73,6 @@ needTestsuiteBuilders = do
     needfile :: Stage -> Package -> Action FilePath
     needfile stage pkg = programPath =<< programContext stage pkg
 
-
 needTestBuilders :: Action ()
 needTestBuilders = do
     needBuilder $ Ghc CompileHs Stage2
index f8d2705..53cf4ef 100644 (file)
@@ -2,8 +2,7 @@ module Settings.Builders.RunTest (runTestBuilderArgs) where
 
 import CommandLine (TestArgs(..), defaultTestArgs, TestSpeed(..))
 import Flavour
-import GHC.Packages
-import Hadrian.Builder (getBuilderPath)
+import GHC
 import Hadrian.Utilities
 import Oracles.Setting (setting)
 import Rules.Test
@@ -26,19 +25,11 @@ runTestBuilderArgs = builder RunTest ? do
 
     windows  <- expr windowsHost
     darwin   <- expr osxHost
-
     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
-    haddock  <- getBuilderPath $ Haddock BuildPackage
-    hp2ps    <- getBuilderPath $ Hp2Ps
-    hpc      <- getBuilderPath $ Hpc
-
     ghcFlags    <- expr runTestGhcFlags
     timeoutProg <- expr buildRoot <&> (-/- timeoutProgPath)
 
@@ -81,49 +72,71 @@ runTestBuilderArgs = builder RunTest ? do
             , 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)
-            , arg "--config", arg $ "haddock="      ++ show (top -/- haddock)
-            , arg "--config", arg $ "hp2ps="        ++ show (top -/- hp2ps)
-            , arg "--config", arg $ "hpc="          ++ show (top -/- hpc)
             , 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
-            , arg $ "--verbose=" ++ show (fromEnum verbose)
             , getTestArgs -- User-provided arguments from command line.
             ]
 
 -- | Prepare the command-line arguments to run GHC's test script.
 getTestArgs :: Args
 getTestArgs = do
-    args <- expr $ userSetting defaultTestArgs
-    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 = concat [["-e", configArg] | configArg <- testConfigs args]
+    args            <- expr $ userSetting defaultTestArgs
+    bindir          <- expr $ setBinaryDirectory (testCompiler args)
+    compiler        <- expr $ setCompiler (testCompiler args)
+    globalVerbosity <- shakeVerbosity <$> expr getShakeOptions 
+    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   = 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
+                           Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
+                           Just verbosity -> Just $ "--verbose=" ++ verbosity
+        wayArgs      = map ("--way=" ++) (testWays args) 
+        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")]
+        hpcArg       = ["--config", "hpc=" ++ show (bindir -/- "hpc")]   
+    pure $  testOnlyArg ++ speedArg 
          ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
-                      , junitArg, verbosityArg  ]
-         ++ configArgs
-         ++ wayArgs
+                      , junitArg, verbosityArg  ] 
+         ++ configArgs ++ wayArgs ++  compilerArg ++ ghcPkgArg
+         ++ haddockArg ++ hp2psArg ++ hpcArg
+
+-- | Directory to look for Binaries
+-- | We assume that required programs are present in the same binary directory 
+-- | 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
+-- | 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 
+-- | problem, but simply returns an error. How should we handle such cases?
+setBinaryDirectory :: String -> Action FilePath
+setBinaryDirectory "stage0" = setting InstallBinDir
+setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0) 
+setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1) 
+setBinaryDirectory compiler = pure $ parentPath compiler
+
+-- | Set Test Compiler
+setCompiler :: String -> Action FilePath
+setCompiler "stage0" = setting SystemGhc
+setCompiler "stage1" = liftM2 (-/-) topDirectory (fullpath Stage0 ghc)
+setCompiler "stage2" = liftM2 (-/-) topDirectory (fullpath Stage1 ghc)
+setCompiler compiler = pure compiler 
 
 -- | Set speed for test
 setTestSpeed :: TestSpeed -> String
@@ -131,3 +144,13 @@ setTestSpeed Fast    = "2"
 setTestSpeed Average = "1"
 setTestSpeed Slow    = "0"
 
+-- | Returns parent path of test compiler 
+-- | TODO : Is there a simpler way to find parent directory?
+parentPath :: String -> String
+parentPath path = let upPath = init $ splitOn "/" path
+                  in  intercalate "/" upPath
+
+-- | TODO: move to hadrian utilities.
+fullpath :: Stage -> Package -> Action FilePath
+fullpath stage pkg = programPath =<< programContext stage pkg
+