diff options
Diffstat (limited to 'hadrian/src')
| -rw-r--r-- | hadrian/src/Oracles/Setting.hs | 4 | ||||
| -rw-r--r-- | hadrian/src/Oracles/TestSettings.hs | 20 | ||||
| -rw-r--r-- | hadrian/src/Rules/Test.hs | 45 | ||||
| -rw-r--r-- | hadrian/src/Settings/Builders/RunTest.hs | 147 |
4 files changed, 175 insertions, 41 deletions
diff --git a/hadrian/src/Oracles/Setting.hs b/hadrian/src/Oracles/Setting.hs index d006439646..0931c6f99f 100644 --- a/hadrian/src/Oracles/Setting.hs +++ b/hadrian/src/Oracles/Setting.hs @@ -77,6 +77,8 @@ data Setting = BuildArch | TargetArchHaskell | TargetOsHaskell | TargetArmVersion + | TargetWordSize + | TargetHasRtsLinker | BourneShell -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). @@ -176,6 +178,8 @@ setting key = lookupValueOrError configFile $ case key of TargetVendor -> "target-vendor" TargetArchHaskell -> "target-arch-haskell" TargetOsHaskell -> "target-os-haskell" + TargetWordSize -> "target-word-size" + TargetHasRtsLinker -> "target-has-rts-linker" BourneShell -> "bourne-shell" -- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the diff --git a/hadrian/src/Oracles/TestSettings.hs b/hadrian/src/Oracles/TestSettings.hs index d59819187f..7541ab628f 100644 --- a/hadrian/src/Oracles/TestSettings.hs +++ b/hadrian/src/Oracles/TestSettings.hs @@ -5,6 +5,7 @@ module Oracles.TestSettings ( TestSetting (..), testSetting, testRTSSettings , getCompilerPath, getBinaryDirectory, isInTreeCompiler + , stageOfTestCompiler ) where import Base @@ -28,6 +29,7 @@ data TestSetting = TestHostOS | TestGhcDebugged | TestGhcWithNativeCodeGen | TestGhcWithInterpreter + | TestGhcWithRtsLinker | TestGhcUnregisterised | TestGhcWithSMP | TestGhcDynamic @@ -40,6 +42,9 @@ data TestSetting = TestHostOS | TestGhcPackageDbFlag | TestMinGhcVersion711 | TestMinGhcVersion801 + | TestLeadingUnderscore + | TestGhcPackageDb + | TestGhcLibDir deriving (Show) -- | Lookup a test setting in @ghcconfig@ file. @@ -57,6 +62,7 @@ testSetting key = do TestGhcDebugged -> "GhcDebugged" TestGhcWithNativeCodeGen -> "GhcWithNativeCodeGen" TestGhcWithInterpreter -> "GhcWithInterpreter" + TestGhcWithRtsLinker -> "GhcWithRtsLinker" TestGhcUnregisterised -> "GhcUnregisterised" TestGhcWithSMP -> "GhcWithSMP" TestGhcDynamic -> "GhcDynamic" @@ -69,6 +75,9 @@ testSetting key = do TestGhcPackageDbFlag -> "GhcPackageDbFlag" TestMinGhcVersion711 -> "MinGhcVersion711" TestMinGhcVersion801 -> "MinGhcVersion801" + TestLeadingUnderscore -> "LeadingUnderscore" + TestGhcPackageDb -> "GhcGlobalPackageDb" + TestGhcLibDir -> "GhcLibdir" -- | Get the RTS ways of the test compiler testRTSSettings :: Action [String] @@ -92,7 +101,7 @@ getBinaryDirectory compiler = pure $ takeDirectory compiler -- | Get the path to the given @--test-compiler@. getCompilerPath :: String -> Action FilePath getCompilerPath "stage0" = setting SystemGhc -getCompilerPath "stage1" = liftM2 (-/-) absoluteBuildRoot (pure "stage1-test/bin/ghc") +getCompilerPath "stage1" = liftM2 (-/-) absoluteBuildRoot (pure ("stage1-test/bin/ghc" <.> exe)) getCompilerPath "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc) getCompilerPath "stage3" = liftM2 (-/-) topDirectory (fullPath Stage2 ghc) getCompilerPath compiler = pure compiler @@ -103,3 +112,12 @@ isInTreeCompiler c = c `elem` ["stage1","stage2","stage3"] -- | Get the full path to the given program. fullPath :: Stage -> Package -> Action FilePath fullPath stage pkg = programPath =<< programContext stage pkg + +-- stage 1 ghc lives under stage0/bin, +-- stage 2 ghc lives under stage1/bin, etc +stageOfTestCompiler :: String -> Maybe Stage +stageOfTestCompiler "stage1" = Just Stage0 +stageOfTestCompiler "stage2" = Just Stage1 +stageOfTestCompiler "stage3" = Just Stage2 +stageOfTestCompiler _ = Nothing + diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs index 5115b4d462..27e3cc9176 100644 --- a/hadrian/src/Rules/Test.hs +++ b/hadrian/src/Rules/Test.hs @@ -50,6 +50,15 @@ checkPrograms = , ("test:count-deps",countDepsProgPath, countDepsSourcePath, countDepsExtra, countDeps) ] +testsuiteDeps :: Rules () +testsuiteDeps = + "test:ghc" ~> do + args <- userSetting defaultTestArgs + let testCompilerArg = testCompiler args + case stageOf testCompilerArg of + Just stg -> needTestsuitePackages stg + Nothing -> return () + ghcConfigPath :: FilePath ghcConfigPath = "test/ghcconfig" @@ -58,6 +67,8 @@ testRules :: Rules () testRules = do root <- buildRootRules + testsuiteDeps + -- Using program shipped with testsuite to generate ghcconfig file. root -/- ghcConfigProgPath %> \_ -> do ghc0Path <- getCompilerPath "stage0" @@ -135,15 +146,22 @@ testRules = do root -/- timeoutPath %> \_ -> timeoutProgBuilder "test" ~> do - needTestBuilders - - -- TODO : Should we remove the previously generated config file? - -- Prepare Ghc configuration file for input compiler. - need [root -/- ghcConfigPath, root -/- timeoutPath] args <- userSetting defaultTestArgs - let testCompilerArg = testCompiler args + let stg = fromMaybe Stage2 $ stageOf testCompilerArg + let test_target tt = target (vanillaContext stg compiler) (Testsuite tt) [] [] + + -- We need to ask the testsuite if it needs any extra hadrian dependencies for the + -- tests it is going to run, + -- for example "docs_haddock" + -- We then need to go and build these dependencies + extra_targets <- words <$> askWithResources [] (test_target GetExtraDeps) + need $ filter (isOkToBuild args) extra_targets + + -- Prepare Ghc configuration file for input compiler. + need [root -/- timeoutPath] + ghcPath <- getCompilerPath testCompilerArg @@ -184,15 +202,6 @@ testRules = do -- which is in turn included by all test 'Makefile's. setEnv "ghc_config_mk" (top -/- root -/- ghcConfigPath) - let stg = fromMaybe Stage2 $ stageOf testCompilerArg - let test_target tt = target (vanillaContext stg compiler) (Testsuite tt) [] [] - - -- We need to ask the testsuite if it needs any extra hadrian dependencies for the - -- tests it is going to run, - -- for example "docs_haddock" - -- We then need to go and build these dependencies - extra_targets <- words <$> askWithResources [] (test_target GetExtraDeps) - need $ filter (isOkToBuild args) extra_targets -- Execute the test target. -- We override the verbosity setting to make sure the user can see @@ -234,12 +243,6 @@ timeoutProgBuilder = do writeFile' (root -/- timeoutPath) script makeExecutable (root -/- timeoutPath) -needTestBuilders :: Action () -needTestBuilders = do - testGhc <- testCompiler <$> userSetting defaultTestArgs - whenJust (stageOf testGhc) - needTestsuitePackages - -- | Build extra programs and libraries required by testsuite needTestsuitePackages :: Stage -> Action () needTestsuitePackages stg = do diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs index 168e64e217..86bd6c7b6f 100644 --- a/hadrian/src/Settings/Builders/RunTest.hs +++ b/hadrian/src/Settings/Builders/RunTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags) where import Hadrian.Utilities @@ -10,6 +11,7 @@ import Settings.Builders.Common import qualified Data.Set as Set import Flavour import qualified Context.Type as C +import System.Directory (findExecutable) getTestSetting :: TestSetting -> Expr String getTestSetting key = expr $ testSetting key @@ -51,6 +53,106 @@ runTestGhcFlags = do , pure "-dno-debug-output" ] + +data TestCompilerArgs = TestCompilerArgs{ + hasDynamicRts, hasThreadedRts :: Bool + , libWays :: [Way] + , hasDynamic :: Bool + , leadingUnderscore :: Bool + , withNativeCodeGen :: Bool + , withInterpreter :: Bool + , unregisterised :: Bool + , withSMP :: Bool + , debugged :: Bool + , profiled :: Bool + , os,arch, platform, wordsize :: String + , libdir :: FilePath + , have_llvm :: Bool + , rtsLinker :: Bool + , pkgConfCacheFile :: FilePath } + + +-- | If the tree is in-compiler then we already know how we will build it so +-- don't build anything in order to work out what we will build. +-- +inTreeCompilerArgs :: Stage -> Expr TestCompilerArgs +inTreeCompilerArgs stg = expr $ do + + + (hasDynamicRts, hasThreadedRts) <- do + ways <- interpretInContext (Context stg rts vanilla) getRtsWays + return (dynamic `elem` ways, threaded `elem` ways) + libWays <- interpretInContext (Context stg compiler vanilla) getLibraryWays + -- MP: We should be able to vary if stage1/stage2 is dynamic, ie a dynamic stage1 + -- should be able to built a static stage2? + hasDynamic <- flavour >>= dynamicGhcPrograms + -- LeadingUnderscore is a property of the system so if cross-compiling stage1/stage2 could + -- have different values? Currently not possible to express. + leadingUnderscore <- flag LeadingUnderscore + -- MP: This setting seems to only dictate whether we turn on optasm as a compiler + -- way, but a lot of tests which use only_ways(optasm) seem to not test the NCG? + withNativeCodeGen <- return True + withInterpreter <- ghcWithInterpreter + unregisterised <- flag GhcUnregisterised + withSMP <- targetSupportsSMP + debugged <- ghcDebugged <$> flavour + profiled <- ghcProfiled <$> flavour + + os <- setting HostOs + arch <- setting TargetArch + platform <- setting TargetPlatform + wordsize <- (show @Int . (*8) . read) <$> setting TargetWordSize + + llc_cmd <- settingsFileSetting SettingsFileSetting_LlcCommand + have_llvm <- liftIO (isJust <$> findExecutable llc_cmd) + + pkgConfCacheFile <- packageDbPath stg <&> (-/- "package.cache") + libdir <- stageLibPath stg + + rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker + + return TestCompilerArgs{..} + +ghcConfigPath :: FilePath +ghcConfigPath = "test/ghcconfig" + +-- | If the compiler is out-of-tree then we have to query the compiler to work out +-- facts about it. +outOfTreeCompilerArgs :: String -> Expr TestCompilerArgs +outOfTreeCompilerArgs testGhc = do + + expr (do + root <- buildRoot + need [root -/- ghcConfigPath]) + (hasDynamicRts, hasThreadedRts) <- do + ways <- expr testRTSSettings + return ("dyn" `elem` ways, "thr" `elem` ways) + libWays <- expr (inferLibraryWays testGhc) + hasDynamic <- getBooleanSetting TestGhcDynamic + leadingUnderscore <- getBooleanSetting TestLeadingUnderscore + withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen + withInterpreter <- getBooleanSetting TestGhcWithInterpreter + unregisterised <- getBooleanSetting TestGhcUnregisterised + withSMP <- getBooleanSetting TestGhcWithSMP + debugged <- getBooleanSetting TestGhcDebugged + + + os <- getTestSetting TestHostOS + arch <- getTestSetting TestTargetARCH_CPP + platform <- getTestSetting TestTARGETPLATFORM + wordsize <- getTestSetting TestWORDSIZE + + llc_cmd <- getTestSetting TestLLC + have_llvm <- expr (liftIO (isJust <$> findExecutable llc_cmd)) + profiled <- getBooleanSetting TestGhcProfiled + + pkgConfCacheFile <- getTestSetting TestGhcPackageDb <&> (-/- "package.cache") + libdir <- getTestSetting TestGhcLibDir + + rtsLinker <- getBooleanSetting TestGhcWithRtsLinker + return TestCompilerArgs{..} + + -- Command line arguments for invoking the @runtest.py@ script. A lot of this -- mirrors @testsuite/mk/test.mk@. runTestBuilderArgs :: Args @@ -62,17 +164,16 @@ runTestBuilderArgs = builder Testsuite ? do | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ] testGhc <- expr (testCompiler <$> userSetting defaultTestArgs) - rtsWays <- expr testRTSSettings - libWays <- expr (inferLibraryWays testGhc) - let hasRtsWay w = elem w rtsWays - hasLibWay w = elem w libWays - hasDynamic <- getBooleanSetting TestGhcDynamic - leadingUnderscore <- getFlag LeadingUnderscore - withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen - withInterpreter <- getBooleanSetting TestGhcWithInterpreter - unregisterised <- getBooleanSetting TestGhcUnregisterised - withSMP <- getBooleanSetting TestGhcWithSMP - debugged <- getBooleanSetting TestGhcDebugged + + TestCompilerArgs{..} <- + case stageOfTestCompiler testGhc of + Just stg -> inTreeCompilerArgs stg + Nothing -> outOfTreeCompilerArgs testGhc + + -- MP: TODO, these should be queried from the test compiler? + bignumBackend <- getBignumBackend + bignumCheck <- getBignumCheck + keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs) accept <- expr (testAccept <$> userSetting defaultTestArgs) @@ -84,15 +185,9 @@ runTestBuilderArgs = builder Testsuite ? do perfBaseline <- expr . liftIO $ lookupEnv "PERF_BASELINE_COMMIT" threads <- shakeThreads <$> expr getShakeOptions - os <- getTestSetting TestHostOS - arch <- getTestSetting TestTargetARCH_CPP - platform <- getTestSetting TestTARGETPLATFORM - wordsize <- getTestSetting TestWORDSIZE top <- expr $ topDirectory ghcFlags <- expr runTestGhcFlags cmdrootdirs <- expr (testRootDirs <$> userSetting defaultTestArgs) - bignumBackend <- getBignumBackend - bignumCheck <- getBignumCheck let defaultRootdirs = ("testsuite" -/- "tests") : libTests rootdirs | null cmdrootdirs = defaultRootdirs | otherwise = cmdrootdirs @@ -103,6 +198,8 @@ runTestBuilderArgs = builder Testsuite ? do let asBool :: String -> Bool -> String asBool s b = s ++ show b + hasLibWay w = elem w libWays + -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD mconcat [ arg $ "testsuite/driver/runtests.py" , pure [ "--rootdir=" ++ testdir | testdir <- rootdirs ] @@ -117,14 +214,26 @@ runTestBuilderArgs = builder Testsuite ? do , arg "-e", arg $ "config.exeext=" ++ quote (if null exe then "" else "."<>exe) , arg "-e", arg $ "config.compiler_debugged=" ++ show debugged + -- MP: TODO, we do not need both, they get aliased to the same thing. , arg "-e", arg $ asBool "ghc_with_native_codegen=" withNativeCodeGen + , arg "-e", arg $ asBool "config.have_ncg=" withNativeCodeGen + , arg "-e", arg $ asBool "config.have_llvm=" have_llvm + + , arg "-e", arg $ asBool "config.compiler_profiled=" profiled + + , arg "-e", arg $ asBool "config.have_RTS_linker=" rtsLinker + + , arg "-e", arg $ "config.package_conf_cache_file=" ++ show pkgConfCacheFile + + , arg "-e", arg $ "config.libdir=" ++ show libdir + , arg "-e", arg $ "config.have_interp=" ++ show withInterpreter , arg "-e", arg $ "config.unregisterised=" ++ show unregisterised , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags - , arg "-e", arg $ asBool "ghc_with_dynamic_rts=" (hasRtsWay "dyn") - , arg "-e", arg $ asBool "ghc_with_threaded_rts=" (hasRtsWay "thr") + , arg "-e", arg $ asBool "ghc_with_dynamic_rts=" (hasDynamicRts) + , arg "-e", arg $ asBool "ghc_with_threaded_rts=" (hasThreadedRts) , 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) |