[Git][ghc/ghc][wip/hadrian-cross-stage2] Fix exe path
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Nov 29 11:01:43 UTC 2023
Matthew Pickering pushed to branch wip/hadrian-cross-stage2 at Glasgow Haskell Compiler / GHC
Commits:
3b45eff4 by Matthew Pickering at 2023-11-29T11:01:35+00:00
Fix exe path
- - - - -
3 changed files:
- hadrian/src/Oracles/TestSettings.hs
- hadrian/src/Rules/Test.hs
- hadrian/src/Settings/Builders/RunTest.hs
Changes:
=====================================
hadrian/src/Oracles/TestSettings.hs
=====================================
@@ -3,9 +3,9 @@
-- | required for testsuite e.g. WORDSIZE, HOSTOS etc.
module Oracles.TestSettings
- ( TestSetting (..), testSetting, testRTSSettings
+ ( TestSetting (..), getTestSetting, getBooleanSetting, testRTSSettings
, getCompilerPath, getBinaryDirectory, isInTreeCompiler
- , stageOfTestCompiler
+ , stageOfTestCompiler, getTestExePath
) where
import Base
@@ -48,8 +48,8 @@ data TestSetting = TestHostOS
-- | Lookup a test setting in @ghcconfig@ file.
-- | To obtain RTS ways supported in @ghcconfig@ file, use 'testRTSSettings'.
-testSetting :: TestSetting -> Action String
-testSetting key = do
+getTestSetting :: TestSetting -> Action String
+getTestSetting key = do
file <- testConfigFile
lookupValueOrError Nothing file $ case key of
TestHostOS -> "HostOS"
@@ -77,6 +77,14 @@ testSetting key = do
TestGhcLibDir -> "GhcLibdir"
TestCrossCompiling -> "CrossCompiling"
+-- | Parse the value of a Boolean test setting or report an error.
+getBooleanSetting :: TestSetting -> Action Bool
+getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key
+ where
+ msg = "Cannot parse test setting " ++ quote (show key)
+
+
+
-- | Get the RTS ways of the test compiler
testRTSSettings :: Action [String]
testRTSSettings = do
@@ -127,3 +135,19 @@ stageOfTestCompiler "stage2" = Just Stage1
stageOfTestCompiler "stage3" = Just Stage2
stageOfTestCompiler _ = Nothing
+
+-- Given the testGhc string, either a stage0..stage1..stage2 etc or a path to
+-- a compiler. Compute the absolute path to the relevant executable provided by
+-- the package in the second argument.
+getTestExePath :: String -> Package -> Action FilePath
+getTestExePath testGhc pkg = do
+ bindir <- getBinaryDirectory testGhc
+ compiler_path <- getCompilerPath testGhc
+ cross <- getBooleanSetting TestCrossCompiling
+ let cross_prefix = if cross then dropWhileEnd ((/=) '-') (takeFileName compiler_path) else ""
+ -- get relative path for the given program in the given stage
+ let make_absolute rel_path = do
+ abs_path <- liftIO (makeAbsolute rel_path)
+ fixAbsolutePathOnWindows abs_path
+ make_absolute (bindir </> (cross_prefix ++ programBasename vanilla pkg) <.> exe)
+ -- get relative path for the given program in the given stage
=====================================
hadrian/src/Rules/Test.hs
=====================================
@@ -9,7 +9,6 @@ import Expression
import Flavour
import Hadrian.Haskell.Cabal.Type (packageDependencies)
import Hadrian.Oracles.Cabal (readPackageData)
-import Hadrian.Oracles.Path (fixAbsolutePathOnWindows)
import Oracles.Setting
import Oracles.TestSettings
import Oracles.Flag
@@ -213,10 +212,6 @@ testRules = do
need [root -/- timeoutPath]
- -- get relative path for the given program in the given stage
- let make_absolute rel_path = do
- abs_path <- liftIO (IO.makeAbsolute rel_path)
- fixAbsolutePathOnWindows abs_path
ghcPath <- getCompilerPath testCompilerArg
@@ -236,19 +231,13 @@ testRules = do
testGhc <- testCompiler <$> userSetting defaultTestArgs
cross <- getBooleanSetting TestCrossCompiling
- bindir <- getBinaryDirectory testGhc
- compiler_path <- getCompilerPath testGhc
- let cross_prefix = if cross then dropWhileEnd ((/=) '-') (takeFileName compiler_path) else ""
-
- let exe_path :: Package -> String
- exe_path pkg = bindir </> (cross_prefix ++ programBasename vanilla pkg) <.> exe
-
- prog_ghc_pkg <- make_absolute (exe_path ghcPkg)
- prog_hsc2hs <- make_absolute (exe_path hsc2hs)
- prog_hp2ps <- make_absolute (exe_path hp2ps)
- prog_haddock <- make_absolute (exe_path haddock)
- prog_hpc <- make_absolute (exe_path hpc)
- prog_runghc <- make_absolute (exe_path runGhc)
+
+ prog_ghc_pkg <- getTestExePath testGhc ghcPkg
+ prog_hsc2hs <- getTestExePath testGhc hsc2hs
+ prog_hp2ps <- getTestExePath testGhc hp2ps
+ prog_haddock <- getTestExePath testGhc haddock
+ prog_hpc <- getTestExePath testGhc hpc
+ prog_runghc <- getTestExePath testGhc runGhc
-- Set environment variables for test's Makefile.
-- TODO: Ideally we would define all those env vars in 'env', so that
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -27,14 +27,6 @@ import Text.Read
import GHC.Platform.ArchOS
import Debug.Trace
-getTestSetting :: TestSetting -> Action String
-getTestSetting key = testSetting key
-
--- | Parse the value of a Boolean test setting or report an error.
-getBooleanSetting :: TestSetting -> Action Bool
-getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key
- where
- msg = "Cannot parse test setting " ++ quote (show key)
-- | Extra flags to send to the Haskell compiler to run tests.
runTestGhcFlags :: Stage -> Action String
@@ -101,22 +93,14 @@ inTreeCompilerArgs stg = do
(hasDynamicRts, hasThreadedRts) <- do
ways <- interpretInContext (vanillaContext stg rts) getRtsWays
return (dynamic `elem` ways, threaded `elem` ways)
- -- 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 <- (dynamic ==) . Context.Type.way <$> (programContext stg ghc)
- -- LeadingUnderscore is a property of the system so if cross-compiling stage1/stage2 could
- -- have different values? Currently not possible to express.
leadingUnderscore <- queryTargetTarget stg tgtSymbolsHaveLeadingUnderscore
withInterpreter <- ghcWithInterpreter stg
unregisterised <- queryTargetTarget stg tgtUnregisterised
tables_next_to_code <- queryTargetTarget stg tgtTablesNextToCode
targetWithSMP <- targetSupportsSMP stg
- cross <- flag CrossCompiling
-
- let ghcStage
- | cross, Stage1 <- stg = Stage1
- | otherwise = succStage stg
+ let ghcStage = succStage stg
debugAssertions <- ghcDebugAssertions <$> flavour <*> pure ghcStage
debugged <- ghcDebugged <$> flavour <*> pure ghcStage
profiled <- ghcProfiled <$> flavour <*> pure ghcStage
@@ -333,15 +317,16 @@ getTestArgs = do
-- targets specified in the TEST env var
testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
args <- expr $ userSetting defaultTestArgs
- bindir <- expr $ getBinaryDirectory (testCompiler args)
compiler <- expr $ getCompilerPath (testCompiler args)
globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
- -- MP: Is it better to compute cross_prefix from testCompiler?
- cross <- expr $ getBooleanSetting TestCrossCompiling
- test_target <- expr $ getTestSetting TestTARGETPLATFORM
- let cross_prefix = if cross then test_target ++ "-" else ""
- traceShowM ("cross", cross, cross_prefix, test_target)
+ testGhc <- expr (testCompiler <$> userSetting defaultTestArgs)
+
+ ghc_pkg_path <- expr $ getTestExePath testGhc ghcPkg
+ haddock_path <- expr $ getTestExePath testGhc haddock
+ hp2ps_path <- expr $ getTestExePath testGhc hp2ps
+ hpc_path <- expr $ getTestExePath testGhc hpc
+
-- the testsuite driver will itself tell us if we need to generate the docs target
-- So we always pass the haddock path if the hadrian configuration allows us to build
@@ -381,13 +366,13 @@ getTestArgs = do
Nothing -> Just $ "--verbose=" ++ globalTestVerbosity
Just verbosity -> Just $ "--verbose=" ++ verbosity
wayArgs = map ("--way=" ++) (testWays args)
- compilerArg = ["--config", "compiler=" ++ show (compiler)]
- ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- (cross_prefix <> "ghc-pkg") <.> exe)]
+ compilerArg = ["--config", "compiler=" ++ show compiler]
+ ghcPkgArg = ["--config", "ghc_pkg=" ++ show ghc_pkg_path]
haddockArg = if haveDocs
- then [ "--config", "haddock=" ++ show (bindir -/- (cross_prefix <> "haddock") <.> exe) ]
+ then [ "--config", "haddock=" ++ show haddock_path ]
else [ "--config", "haddock=" ]
- hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- (cross_prefix <> "hp2ps") <.> exe)]
- hpcArg = ["--config", "hpc=" ++ show (bindir -/- (cross_prefix <> "hpc") <.> exe)]
+ hp2psArg = ["--config", "hp2ps=" ++ show hp2ps_path ]
+ hpcArg = ["--config", "hpc=" ++ show hpc_path ]
inTreeArg = [ "-e", "config.in_tree_compiler=" ++
show (isInTreeCompiler (testCompiler args) || testHasInTreeFiles args) ]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b45eff4aba09359d2e7ec49aaa09735d7724bff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b45eff4aba09359d2e7ec49aaa09735d7724bff
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231129/fbd5eb2c/attachment-0001.html>
More information about the ghc-commits
mailing list