From 4c8f179405394e9961b2a7c148f0c650dd24e1e3 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Mon, 4 Mar 2024 12:34:20 +0000
Subject: [PATCH] hadrian: Remove stage1 testsuite wrappers logic
Now instead of producing wrappers which pass the global package database
argument to ghc and ghc-pkg, we write the location of the correct
package database into the settings file so you can just use the intree
compiler directly.
---
hadrian/src/Oracles/TestSettings.hs | 9 ++------
hadrian/src/Rules/Generate.hs | 29 ++++++++++++++----------
hadrian/src/Rules/Test.hs | 34 -----------------------------
3 files changed, 19 insertions(+), 53 deletions(-)
diff --git a/hadrian/src/Oracles/TestSettings.hs b/hadrian/src/Oracles/TestSettings.hs
index a56e656d6d6c..9b2ddda99d06 100644
--- a/hadrian/src/Oracles/TestSettings.hs
+++ b/hadrian/src/Oracles/TestSettings.hs
@@ -13,8 +13,6 @@ import Hadrian.Oracles.TextFile
import Oracles.Setting (topDirectory, setting, Setting(..))
import Packages
import Settings.Program (programContext)
-import Hadrian.Oracles.Path
-import System.Directory (makeAbsolute)
testConfigFile :: Action FilePath
testConfigFile = buildRoot <&> (-/- "test/ghcconfig")
@@ -81,15 +79,12 @@ testRTSSettings = do
file <- testConfigFile
words <$> lookupValueOrError Nothing file "GhcRTSWays"
-absoluteBuildRoot :: Action FilePath
-absoluteBuildRoot = (fixAbsolutePathOnWindows =<< liftIO . makeAbsolute =<< buildRoot)
-
-- | 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.
getBinaryDirectory :: String -> Action FilePath
getBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc
-getBinaryDirectory "stage1" = liftM2 (-/-) absoluteBuildRoot (pure "stage1-test/bin/")
+getBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath stage0InTree)
getBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
getBinaryDirectory "stage3" = liftM2 (-/-) topDirectory (stageBinPath Stage2)
getBinaryDirectory "stage-cabal" = do
@@ -101,7 +96,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" <.> exe))
+getCompilerPath "stage1" = liftM2 (-/-) topDirectory (fullPath stage0InTree ghc)
getCompilerPath "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
getCompilerPath "stage3" = liftM2 (-/-) topDirectory (fullPath Stage2 ghc)
getCompilerPath "stage-cabal" = do
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index 3bcd1d8a6096..3314574684f6 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -235,8 +235,8 @@ generateRules = do
forM_ allStages $ \stage -> do
let prefix = root -/- stageString stage -/- "lib"
- go gen file = generate file (semiEmptyTarget stage) gen
- (prefix -/- "settings") %> go generateSettings
+ go gen file = generate file (semiEmptyTarget (succStage stage)) gen
+ (prefix -/- "settings") %> \out -> go (generateSettings out) out
where
file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out
@@ -356,21 +356,26 @@ templateRules = do
ghcWrapper :: Stage -> Expr String
ghcWrapper (Stage0 {}) = error "Stage0 GHC does not require a wrapper script to run."
ghcWrapper stage = do
- dbPath <- expr $ (</>) <$> topDirectory <*> packageDbPath (PackageDbLoc stage Final)
ghcPath <- expr $ (</>) <$> topDirectory
<*> programPath (vanillaContext (predStage stage) ghc)
return $ unwords $ map show $ [ ghcPath ]
- ++ (if stage == Stage1
- then ["-no-global-package-db"
- , "-package-env=-"
- , "-package-db " ++ dbPath
- ]
- else [])
++ [ "$@" ]
-generateSettings :: Expr String
-generateSettings = do
+generateSettings :: FilePath -> Expr String
+generateSettings settingsFile = do
ctx <- getContext
+ stage <- getStage
+
+ package_db_path <- expr $ do
+ let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final)
+ case stage of
+ Stage0 {} -> error "Unable to generate settings for stage0"
+ Stage1 -> get_pkg_db Stage1
+ Stage2 -> get_pkg_db Stage1
+ Stage3 -> get_pkg_db Stage2
+
+ let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path
+
settings <- traverse sequence $
[ ("C compiler command", queryTarget ccPath)
, ("C compiler flags", queryTarget ccFlags)
@@ -422,7 +427,7 @@ generateSettings = do
, ("Leading underscore", queryTarget (yesNo . tgtSymbolsHaveLeadingUnderscore))
, ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
, ("RTS expects libdw", yesNo <$> getFlag UseLibdw)
- , ("Relative Global Package DB", return "package.conf.d" )
+ , ("Relative Global Package DB", pure rel_pkg_db)
]
let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
pure $ case settings of
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index 5c1e23b77b47..e192bb5ae741 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -124,28 +124,6 @@ testRules = do
testsuiteDeps
- -- we need to create wrappers to test the stage1 compiler
- -- as the stage1 compiler needs the stage2 libraries
- -- to have any hope of passing tests.
- root -/- "stage1-test/bin/*" %> \path -> do
-
- bin_path <- stageBinPath stage0InTree
- let prog = takeBaseName path
- stage0prog = bin_path -/- prog <.> exe
- need [stage0prog]
- abs_prog_path <- liftIO (IO.canonicalizePath stage0prog)
- -- Use the stage1 package database
- pkgDb <- liftIO . IO.makeAbsolute =<< packageDbPath (PackageDbLoc Stage1 Final)
- if prog `elem` ["ghc","runghc"] then do
- let flags = [ "-no-global-package-db", "-no-user-package-db", "-hide-package", "ghc" , "-package-env","-","-package-db",pkgDb]
- writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
- makeExecutable path
- else if prog == "ghc-pkg" then do
- let flags = ["--no-user-package-db", "--global-package-db", pkgDb]
- writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
- makeExecutable path
- else createFileLink abs_prog_path path
-
-- Rules for building check-ppr, check-exact and
-- check-ppr-annotations with the compiler we are going to test
-- (in-tree or out-of-tree).
@@ -344,18 +322,6 @@ needTestsuitePackages stg = do
need =<< mapM (uncurry pkgFile) pkgs
cross <- flag CrossCompiling
when (not cross) $ needIservBins stg
- root <- buildRoot
- -- require the shims for testing stage1
- when (stg == stage0InTree) $ do
- -- Windows not supported as the wrapper scripts don't work on windows.. we could
- -- support it with a separate .bat or C wrapper code path but seems overkill when no-one will
- -- probably ever try and do this.
- when windowsHost $ do
- putFailure $ unlines [ "Testing stage1 compiler with windows is currently unsupported,"
- , "if you desire to do this then please open a ticket"]
- fail "Testing stage1 is not supported"
-
- need =<< sequence [(\f -> root -/- "stage1-test/bin" -/- takeFileName f) <$> (pkgFile stage0InTree p) | (Stage0 InTreeLibs,p) <- exepkgs]
-- stage 1 ghc lives under stage0/bin,
-- stage 2 ghc lives under stage1/bin, etc
--
GitLab