testsuite: Run testsuite dependency calculation before GHC is built

The main motivation for this patch is to allow tests to be added to the
testsuite which test things about the source tree without needing to
build GHC. In particular the notes linter can easily start failing and
by integrating it into the testsuite the  process of observing these
changes is caught by normal validation procedures rather than having to
run the linter specially.

With this patch I can run

```
./hadrian/build test --flavour=devel2  --only="uniques"
```

In a clean tree to run the checkUniques linter without having to build
GHC.

Fixes #21029

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)