hadrian: Add assertion that in/out tree args are the same

There have been a few instances where this calculation was incorrect, so
we add a non-terminal assertion when now checks they the two
computations indeed compute the same thing.

Fixes #21285

2 files changed, 37 insertions, 23 deletions

diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index cafe0960d8..f7d3a6c883 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -90,7 +90,13 @@ testsuiteDeps = do
   "test:ghc" ~> inTreeOutTree
                     (\stg -> do
                       needTestsuitePackages stg
-                      need [(root -/- ghcConfigPath)])
+                      need [(root -/- ghcConfigPath)]
+                      -- This is here because it's the one place we know that GHC is
+                      -- up-to-date. Later when we compute the in/out tree arguments
+                      -- we can't be sure whether checking this assertion will trigger
+                      -- a rebuild.
+                      assertSameCompilerArgs stg)
+
                     (return ())
 
 ghcConfigPath :: FilePath
diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs
index fcc4f1816d..2360a2205d 100644
--- a/hadrian/src/Settings/Builders/RunTest.hs
+++ b/hadrian/src/Settings/Builders/RunTest.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE TypeApplications #-}
-module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags) where
+module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags, assertSameCompilerArgs) where
 
 import Hadrian.Utilities
 import qualified System.FilePath
@@ -14,11 +14,11 @@ import Flavour
 import qualified Context.Type as C
 import System.Directory (findExecutable)
 
-getTestSetting :: TestSetting -> Expr String
-getTestSetting key = expr $ testSetting key
+getTestSetting :: TestSetting -> Action String
+getTestSetting key = testSetting key
 
 -- | Parse the value of a Boolean test setting or report an error.
-getBooleanSetting :: TestSetting -> Expr Bool
+getBooleanSetting :: TestSetting -> Action Bool
 getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key
   where
     msg = "Cannot parse test setting " ++ quote (show key)
@@ -79,8 +79,8 @@ data TestCompilerArgs = TestCompilerArgs{
 -- | 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
+inTreeCompilerArgs :: Stage -> Action TestCompilerArgs
+inTreeCompilerArgs stg = do
 
 
     (hasDynamicRts, hasThreadedRts) <- do
@@ -126,16 +126,14 @@ 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 :: String -> Action TestCompilerArgs
 outOfTreeCompilerArgs testGhc = do
-
-    expr (do
-      root <- buildRoot
-      need [root -/- ghcConfigPath])
+    root <- buildRoot
+    need [root -/- ghcConfigPath]
     (hasDynamicRts, hasThreadedRts) <- do
-      ways <- expr testRTSSettings
+      ways <- testRTSSettings
       return ("dyn" `elem` ways, "thr" `elem` ways)
-    libWays <- expr (inferLibraryWays testGhc)
+    libWays <- inferLibraryWays testGhc
     hasDynamic          <- getBooleanSetting TestGhcDynamic
     leadingUnderscore   <- getBooleanSetting TestLeadingUnderscore
     withNativeCodeGen   <- getBooleanSetting TestGhcWithNativeCodeGen
@@ -150,7 +148,7 @@ outOfTreeCompilerArgs testGhc = do
     wordsize    <- getTestSetting TestWORDSIZE
 
     llc_cmd   <- getTestSetting TestLLC
-    have_llvm <- expr (liftIO (isJust <$> findExecutable llc_cmd))
+    have_llvm <- liftIO (isJust <$> findExecutable llc_cmd)
     profiled <- getBooleanSetting TestGhcProfiled
 
     pkgConfCacheFile <- getTestSetting TestGhcPackageDb <&> (</> "package.cache")
@@ -160,6 +158,23 @@ outOfTreeCompilerArgs testGhc = do
     return TestCompilerArgs{..}
 
 
+-- | Assert that the inTree and outOfTree compiler args compute to the same
+-- thing
+assertSameCompilerArgs :: Stage -> Action ()
+assertSameCompilerArgs stg = do
+  test_ghc <- testCompiler <$> userSetting defaultTestArgs
+  in_args  <- inTreeCompilerArgs stg
+  out_args <- outOfTreeCompilerArgs test_ghc
+  -- The assertion to check we calculated the right thing
+  when (in_args /= out_args) $ putFailure $ unlines $
+    [ "Hadrian assertion failure: in-tree arguments don't match out-of-tree arguments."
+    , "Please report this bug on the GHC issue tracker. Continuing with in-tree arguments."
+        -- NB: we always use the in-tree arguments whenever they are available.
+    , "in-tree arguments:\n" ++ show in_args
+    , "out-of-tree arguments:\n" ++ show out_args
+    ]
+
+
 -- Command line arguments for invoking the @runtest.py@ script. A lot of this
 -- mirrors @testsuite/mk/test.mk@.
 runTestBuilderArgs :: Args
@@ -172,16 +187,9 @@ runTestBuilderArgs = builder Testsuite ? do
 
     testGhc <- expr (testCompiler <$> userSetting defaultTestArgs)
 
-    TestCompilerArgs{..} <-
+    TestCompilerArgs{..} <- expr $
       case stageOfTestCompiler testGhc of
         Just stg -> inTreeCompilerArgs stg
-                 {- do { in_args  <- inTreeCompilerArgs stg
-                       ; out_args <- outOfTreeCompilerArgs testGhc
-                       ; when (in_args /= out_args) $ error $
-                          "in-tree arguments don't match out-of-tree arguments:\n\
-                          \in-tree arguments:\n" ++ show in_args ++ "\n\
-                          \out-of-tree arguments:\n" ++ show out_args
-                       ; return in_args } -}
         Nothing  -> outOfTreeCompilerArgs testGhc
 
     -- MP: TODO, these should be queried from the test compiler?