From 4d189db9da47b15b1ef354c1febe3dd9ee442927 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 20 Apr 2022 12:18:20 -0400 Subject: testsuite: Cabalify ghc-config To ensure that the build benefits from Hadrian's usual logic for building packages, avoiding #21409. Closes #21409. --- hadrian/src/Packages.hs | 7 +-- hadrian/src/Rules/Test.hs | 20 ++------- hadrian/src/Settings/Default.hs | 2 +- testsuite/ghc-config/ghc-config.cabal | 11 +++++ testsuite/ghc-config/ghc-config.hs | 85 +++++++++++++++++++++++++++++++++++ testsuite/mk/boilerplate.mk | 6 +-- testsuite/mk/ghc-config.hs | 84 ---------------------------------- 7 files changed, 107 insertions(+), 108 deletions(-) create mode 100644 testsuite/ghc-config/ghc-config.cabal create mode 100644 testsuite/ghc-config/ghc-config.hs delete mode 100644 testsuite/mk/ghc-config.hs diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs index 9ca18f14c3..d1b49c35b1 100644 --- a/hadrian/src/Packages.hs +++ b/hadrian/src/Packages.hs @@ -5,7 +5,7 @@ module Packages ( checkExact, countDeps, compareSizes, compiler, containers, deepseq, deriveConstants, directory, exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, - ghcCompact, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, + ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, libffi, libiserv, mtl, parsec, pretty, primitive, process, remoteIserv, rts, runGhc, stm, templateHaskell, terminfo, text, time, timeout, touchy, @@ -37,7 +37,7 @@ ghcPackages = [ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps , compareSizes, compiler, containers, deepseq, deriveConstants, directory , exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh - , ghcCompact, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs + , ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs , hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl , parsec, pretty, process, rts, runGhc, stm, templateHaskell , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml @@ -53,7 +53,7 @@ isGhcPackage = (`elem` ghcPackages) array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps, compareSizes, compiler, containers, deepseq, deriveConstants, directory, exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, - ghcCompact, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs, + ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, libiserv, mtl, parsec, pretty, primitive, process, rts, runGhc, stm, templateHaskell, terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml, @@ -84,6 +84,7 @@ ghcBignum = lib "ghc-bignum" ghcBoot = lib "ghc-boot" ghcBootTh = lib "ghc-boot-th" ghcCompact = lib "ghc-compact" +ghcConfig = prg "ghc-config" `setPath` "testsuite/ghc-config" ghcHeap = lib "ghc-heap" ghci = lib "ghci" ghciWrapper = prg "ghci-wrapper" `setPath` "driver/ghci" diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs index f7d3a6c883..a1bc0612ef 100644 --- a/hadrian/src/Rules/Test.hs +++ b/hadrian/src/Rules/Test.hs @@ -21,12 +21,6 @@ import Utilities import Context.Type import qualified System.Directory as IO -ghcConfigHsPath :: FilePath -ghcConfigHsPath = "testsuite/mk/ghc-config.hs" - -ghcConfigProgPath :: FilePath -ghcConfigProgPath = "test/bin/ghc-config" <.> exe - checkPprProgPath, checkPprSourcePath :: FilePath checkPprProgPath = "test/bin/check-ppr" <.> exe checkPprSourcePath = "utils/check-ppr/Main.hs" @@ -109,13 +103,6 @@ testRules = do testsuiteDeps - -- Using program shipped with testsuite to generate ghcconfig file. - root -/- ghcConfigProgPath %> \_ -> do - ghc0Path <- getCompilerPath "stage0" - -- Invoke via bash to work around #17362. - -- Reasons why this is required are not entirely clear. - cmd ["bash"] ["-c", ghc0Path ++ " " ++ ghcConfigHsPath ++ " -o " ++ (root -/- ghcConfigProgPath)] - -- 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. @@ -179,11 +166,10 @@ testRules = do ghcPath <- getCompilerPath testGhc whenJust (stageOf testGhc) $ \stg -> need . (:[]) =<< programPath (Context stg ghc vanilla) + ghcConfigProgPath <- programPath =<< programContext Stage0 ghcConfig cwd <- liftIO $ IO.getCurrentDirectory - need [makeRelative cwd ghcPath] - need [root -/- ghcConfigProgPath] - cmd [FileStdout $ root -/- ghcConfigPath] (root -/- ghcConfigProgPath) - [ghcPath] + need [makeRelative cwd ghcPath, ghcConfigProgPath] + cmd [FileStdout $ root -/- ghcConfigPath] ghcConfigProgPath [ghcPath] root -/- timeoutPath %> \_ -> timeoutProgBuilder diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs index 5e2c5f54f7..3b3498461c 100644 --- a/hadrian/src/Settings/Default.hs +++ b/hadrian/src/Settings/Default.hs @@ -157,7 +157,7 @@ stage2Packages = stage1Packages -- | Packages that are built only for the testsuite. testsuitePackages :: Action [Package] -testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact, countDeps ]) +testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact, countDeps, ghcConfig ]) -- | Default build ways for library packages: -- * We always build 'vanilla' way. diff --git a/testsuite/ghc-config/ghc-config.cabal b/testsuite/ghc-config/ghc-config.cabal new file mode 100644 index 0000000000..017cbea8de --- /dev/null +++ b/testsuite/ghc-config/ghc-config.cabal @@ -0,0 +1,11 @@ +cabal-version: 2.4 +name: ghc-config +version: 0.1.0.0 +synopsis: A utility used by GHC's testsuite driver to extract information from @ghc --info@. +author: The GHC Developers +maintainer: ghc-devs@haskell.org + +executable ghc-config + main-is: ghc-config.hs + build-depends: base, process + default-language: Haskell2010 diff --git a/testsuite/ghc-config/ghc-config.hs b/testsuite/ghc-config/ghc-config.hs new file mode 100644 index 0000000000..efb88f81f2 --- /dev/null +++ b/testsuite/ghc-config/ghc-config.hs @@ -0,0 +1,85 @@ +import System.Environment +import System.Process +import Data.Maybe + +main :: IO () +main = do + [ghc] <- getArgs + + info <- readProcess ghc ["+RTS", "--info"] "" + let fields = read info :: [(String,String)] + getGhcFieldOrFail fields "HostOS" "Host OS" + getGhcFieldOrFail fields "WORDSIZE" "Word size" + getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform" + getGhcFieldOrFail fields "TargetOS_CPP" "Target OS" + getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture" + + info <- readProcess ghc ["--info"] "" + let fields = read info :: [(String,String)] + + getGhcFieldOrFail fields "GhcStage" "Stage" + getGhcFieldOrFail fields "GhcDebugged" "Debug on" + getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator" + getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter" + getGhcFieldOrFail fields "GhcWithRtsLinker" "target has RTS linker" + getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised" + getGhcFieldOrFail fields "GhcWithSMP" "Support SMP" + getGhcFieldOrFail fields "GhcRTSWays" "RTS ways" + getGhcFieldOrFail fields "GhcLibdir" "LibDir" + getGhcFieldOrFail fields "GhcGlobalPackageDb" "Global Package DB" + getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO" + getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO" + getGhcFieldOrDefault fields "LeadingUnderscore" "Leading underscore" "NO" + getGhcFieldProgWithDefault fields "AR" "ar command" "ar" + getGhcFieldProgWithDefault fields "CLANG" "LLVM clang command" "clang" + getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc" + getGhcFieldProgWithDefault fields "TEST_CC" "C compiler command" "gcc" + getGhcFieldProgWithDefault fields "TEST_CC_OPTS" "C compiler flags" "" + +getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO () +getGhcFieldOrFail fields mkvar key + = getGhcField fields mkvar key id (fail ("No field: " ++ key)) + +getGhcFieldOrDefault :: [(String,String)] -> String -> String -> String -> IO () +getGhcFieldOrDefault fields mkvar key deflt + = getGhcField fields mkvar key id on_fail + where + on_fail = putStrLn (mkvar ++ '=' : deflt) + +getGhcFieldProgWithDefault + :: [(String,String)] + -> String -> String -> String + -> IO () +getGhcFieldProgWithDefault fields mkvar key deflt + = getGhcField fields mkvar key fix on_fail + where + fix val = fixSlashes (fixTopdir topdir val) + topdir = fromMaybe "" (lookup "LibDir" fields) + on_fail = putStrLn (mkvar ++ '=' : deflt) + +getGhcField + :: [(String,String)] -> String -> String + -> (String -> String) + -> IO () + -> IO () +getGhcField fields mkvar key fix on_fail = + case lookup key fields of + Nothing -> on_fail + Just val -> putStrLn (mkvar ++ '=' : fix val) + +fixTopdir :: String -> String -> String +fixTopdir t "" = "" +fixTopdir t ('$':'t':'o':'p':'d':'i':'r':s) = t ++ s +fixTopdir t (c:s) = c : fixTopdir t s + +fixSlashes :: FilePath -> FilePath +fixSlashes = map f + where f '\\' = '/' + f c = c + +parseVersion :: String -> [Int] +parseVersion v = case break (== '.') v of + (n, rest) -> read n : case rest of + [] -> [] + ('.':v') -> parseVersion v' + _ -> error "bug in parseVersion" diff --git a/testsuite/mk/boilerplate.mk b/testsuite/mk/boilerplate.mk index df1b835b0c..8ce5dafb7b 100644 --- a/testsuite/mk/boilerplate.mk +++ b/testsuite/mk/boilerplate.mk @@ -246,7 +246,7 @@ endif # the results, and emits a little .mk file with make bindings for the values. # This way we cache the results for different values of $(TEST_HC) -$(TOP)/mk/ghc-config : $(TOP)/mk/ghc-config.hs +$(TOP)/ghc-config/ghc-config : $(TOP)/ghc-config/ghc-config.hs "$(TEST_HC)" --make -o $@ $< empty= @@ -254,8 +254,8 @@ space=$(empty) $(empty) ifeq "$(ghc_config_mk)" "" ghc_config_mk = $(TOP)/mk/ghcconfig$(subst $(space),_,$(subst :,_,$(subst /,_,$(subst \,_,$(TEST_HC))))).mk -$(ghc_config_mk) : $(TOP)/mk/ghc-config - $(TOP)/mk/ghc-config "$(TEST_HC)" >"$@"; if [ "$$?" != "0" ]; then $(RM) "$@"; exit 1; fi +$(ghc_config_mk) : $(TOP)/ghc-config/ghc-config + $(TOP)/ghc-config/ghc-config "$(TEST_HC)" >"$@"; if [ "$$?" != "0" ]; then $(RM) "$@"; exit 1; fi # If the ghc-config fails, remove $@, and fail endif diff --git a/testsuite/mk/ghc-config.hs b/testsuite/mk/ghc-config.hs deleted file mode 100644 index f12b579e8d..0000000000 --- a/testsuite/mk/ghc-config.hs +++ /dev/null @@ -1,84 +0,0 @@ -import System.Environment -import System.Process -import Data.Maybe - -main = do - [ghc] <- getArgs - - info <- readProcess ghc ["+RTS", "--info"] "" - let fields = read info :: [(String,String)] - getGhcFieldOrFail fields "HostOS" "Host OS" - getGhcFieldOrFail fields "WORDSIZE" "Word size" - getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform" - getGhcFieldOrFail fields "TargetOS_CPP" "Target OS" - getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture" - - info <- readProcess ghc ["--info"] "" - let fields = read info :: [(String,String)] - - getGhcFieldOrFail fields "GhcStage" "Stage" - getGhcFieldOrFail fields "GhcDebugged" "Debug on" - getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator" - getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter" - getGhcFieldOrFail fields "GhcWithRtsLinker" "target has RTS linker" - getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised" - getGhcFieldOrFail fields "GhcWithSMP" "Support SMP" - getGhcFieldOrFail fields "GhcRTSWays" "RTS ways" - getGhcFieldOrFail fields "GhcLibdir" "LibDir" - getGhcFieldOrFail fields "GhcGlobalPackageDb" "Global Package DB" - getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO" - getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO" - getGhcFieldOrDefault fields "LeadingUnderscore" "Leading underscore" "NO" - getGhcFieldProgWithDefault fields "AR" "ar command" "ar" - getGhcFieldProgWithDefault fields "CLANG" "LLVM clang command" "clang" - getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc" - getGhcFieldProgWithDefault fields "TEST_CC" "C compiler command" "gcc" - getGhcFieldProgWithDefault fields "TEST_CC_OPTS" "C compiler flags" "" - -getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO () -getGhcFieldOrFail fields mkvar key - = getGhcField fields mkvar key id (fail ("No field: " ++ key)) - -getGhcFieldOrDefault :: [(String,String)] -> String -> String -> String -> IO () -getGhcFieldOrDefault fields mkvar key deflt - = getGhcField fields mkvar key id on_fail - where - on_fail = putStrLn (mkvar ++ '=' : deflt) - -getGhcFieldProgWithDefault - :: [(String,String)] - -> String -> String -> String - -> IO () -getGhcFieldProgWithDefault fields mkvar key deflt - = getGhcField fields mkvar key fix on_fail - where - fix val = fixSlashes (fixTopdir topdir val) - topdir = fromMaybe "" (lookup "LibDir" fields) - on_fail = putStrLn (mkvar ++ '=' : deflt) - -getGhcField - :: [(String,String)] -> String -> String - -> (String -> String) - -> IO () - -> IO () -getGhcField fields mkvar key fix on_fail = - case lookup key fields of - Nothing -> on_fail - Just val -> putStrLn (mkvar ++ '=' : fix val) - -fixTopdir :: String -> String -> String -fixTopdir t "" = "" -fixTopdir t ('$':'t':'o':'p':'d':'i':'r':s) = t ++ s -fixTopdir t (c:s) = c : fixTopdir t s - -fixSlashes :: FilePath -> FilePath -fixSlashes = map f - where f '\\' = '/' - f c = c - -parseVersion :: String -> [Int] -parseVersion v = case break (== '.') v of - (n, rest) -> read n : case rest of - [] -> [] - ('.':v') -> parseVersion v' - _ -> error "bug in parseVersion" -- cgit v1.2.1