From ad09a5f7671c5594524c517945b2bdd7c5e2c8fa Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 23 Mar 2022 12:13:52 +0100 Subject: Hadrian: make DDEBUG separate from debugged RTS This patchs separates whether -DDEBUG is enabled (i.e. whether debug assertions are enabled) from whether we are using the debugged RTS (i.e. GhcDebugged = YES). This means that we properly skip tests which have been marked with `when(compiler_debugged(), skip)`. Fixes #21113, #21153 and #21234 --- hadrian/doc/user-settings.md | 6 +++-- hadrian/src/Flavour.hs | 5 +--- hadrian/src/Flavour/Type.hs | 4 +++- hadrian/src/Settings/Builders/RunTest.hs | 36 ++++++++++++++++++---------- hadrian/src/Settings/Default.hs | 1 + hadrian/src/Settings/Flavours/Development.hs | 7 +++--- hadrian/src/Settings/Flavours/Validate.hs | 14 ++--------- hadrian/src/Settings/Packages.hs | 9 +++++-- 8 files changed, 46 insertions(+), 36 deletions(-) diff --git a/hadrian/doc/user-settings.md b/hadrian/doc/user-settings.md index 5b6c5ca65a..0cc7807755 100644 --- a/hadrian/doc/user-settings.md +++ b/hadrian/doc/user-settings.md @@ -35,8 +35,10 @@ data Flavour = Flavour { ghciWithDebugger :: Bool, -- | Build profiled GHC. ghcProfiled :: Bool, - -- | Build GHC with debug information. - ghcDebugged :: Bool + -- | Build GHC with the debug RTS. + ghcDebugged :: Bool, + -- | Build GHC with debug assertions. + ghcDebugAssertions :: Bool, -- | Build the GHC executable against the threaded runtime system. ghcThreaded :: Bool, -- | Whether to build docs and which ones diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs index 25416294e7..33d4d68ec4 100644 --- a/hadrian/src/Flavour.hs +++ b/hadrian/src/Flavour.hs @@ -213,10 +213,7 @@ enableLateCCS = -- | Enable assertions for the stage2 compiler enableAssertions :: Flavour -> Flavour -enableAssertions = - let Right kv = parseKV "stage1.*.ghc.hs.opts += -DDEBUG" - Right transformer = applySetting kv - in transformer +enableAssertions flav = flav { ghcDebugAssertions = True } -- | Produce fully statically-linked executables and build libraries suitable -- for static linking. diff --git a/hadrian/src/Flavour/Type.hs b/hadrian/src/Flavour/Type.hs index 9f992fd6f2..46d540aabe 100644 --- a/hadrian/src/Flavour/Type.hs +++ b/hadrian/src/Flavour/Type.hs @@ -32,8 +32,10 @@ data Flavour = Flavour { ghciWithDebugger :: Bool, -- | Build profiled GHC. ghcProfiled :: Bool, - -- | Build GHC with debugging assertions. + -- | Build GHC with the debug RTS. ghcDebugged :: Bool, + -- | Build GHC with debug assertions. + ghcDebugAssertions :: Bool, -- | Build the GHC executable against the threaded runtime system. ghcThreaded :: Bool, -- | Whether to build docs and which ones diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs index 6a49334a70..fcc4f1816d 100644 --- a/hadrian/src/Settings/Builders/RunTest.hs +++ b/hadrian/src/Settings/Builders/RunTest.hs @@ -2,6 +2,7 @@ module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags) where import Hadrian.Utilities +import qualified System.FilePath import System.Environment import CommandLine @@ -63,13 +64,16 @@ data TestCompilerArgs = TestCompilerArgs{ , withInterpreter :: Bool , unregisterised :: Bool , withSMP :: Bool - , debugged :: Bool + , debugAssertions :: Bool + -- ^ Whether the compiler has debug assertions enabled, + -- corresponding to the -DDEBUG option. , profiled :: Bool , os,arch, platform, wordsize :: String , libdir :: FilePath , have_llvm :: Bool , rtsLinker :: Bool , pkgConfCacheFile :: FilePath } + deriving (Eq, Show) -- | If the tree is in-compiler then we already know how we will build it so @@ -95,8 +99,8 @@ inTreeCompilerArgs stg = expr $ do withInterpreter <- ghcWithInterpreter unregisterised <- flag GhcUnregisterised withSMP <- targetSupportsSMP - debugged <- ghcDebugged <$> flavour - profiled <- ghcProfiled <$> flavour + debugAssertions <- ghcDebugAssertions <$> flavour + profiled <- ghcProfiled <$> flavour os <- setting HostOs arch <- setting TargetArch @@ -108,8 +112,10 @@ inTreeCompilerArgs stg = expr $ do top <- topDirectory - pkgConfCacheFile <- (top -/-) <$> (packageDbPath stg <&> (-/- "package.cache")) - libdir <- (top -/-) <$> stageLibPath stg + pkgConfCacheFile <- System.FilePath.normalise . (top -/-) + <$> (packageDbPath stg <&> (-/- "package.cache")) + libdir <- System.FilePath.normalise . (top -/-) + <$> stageLibPath stg rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker @@ -136,8 +142,7 @@ outOfTreeCompilerArgs testGhc = do withInterpreter <- getBooleanSetting TestGhcWithInterpreter unregisterised <- getBooleanSetting TestGhcUnregisterised withSMP <- getBooleanSetting TestGhcWithSMP - debugged <- getBooleanSetting TestGhcDebugged - + debugAssertions <- getBooleanSetting TestGhcDebugged os <- getTestSetting TestHostOS arch <- getTestSetting TestTargetARCH_CPP @@ -148,8 +153,8 @@ outOfTreeCompilerArgs testGhc = do have_llvm <- expr (liftIO (isJust <$> findExecutable llc_cmd)) profiled <- getBooleanSetting TestGhcProfiled - pkgConfCacheFile <- getTestSetting TestGhcPackageDb <&> (-/- "package.cache") - libdir <- getTestSetting TestGhcLibDir + pkgConfCacheFile <- getTestSetting TestGhcPackageDb <&> ( "package.cache") + libdir <- getTestSetting TestGhcLibDir rtsLinker <- getBooleanSetting TestGhcWithRtsLinker return TestCompilerArgs{..} @@ -170,7 +175,14 @@ runTestBuilderArgs = builder Testsuite ? do TestCompilerArgs{..} <- case stageOfTestCompiler testGhc of Just stg -> inTreeCompilerArgs stg - Nothing -> outOfTreeCompilerArgs testGhc + {- 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? bignumBackend <- getBignumBackend @@ -214,8 +226,8 @@ runTestBuilderArgs = builder Testsuite ? do , arg "-e", arg $ "config.accept_platform=" ++ show acceptPlatform , arg "-e", arg $ "config.accept_os=" ++ show acceptOS , arg "-e", arg $ "config.exeext=" ++ quote (if null exe then "" else "."<>exe) - , arg "-e", arg $ "config.compiler_debugged=" ++ - show debugged + , arg "-e", arg $ "config.compiler_debugged=" ++ show debugAssertions + -- 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 diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs index 21ab008cb7..441f009107 100644 --- a/hadrian/src/Settings/Default.hs +++ b/hadrian/src/Settings/Default.hs @@ -236,6 +236,7 @@ defaultFlavour = Flavour , ghciWithDebugger = False , ghcProfiled = False , ghcDebugged = False + , ghcDebugAssertions = False , ghcThreaded = True , ghcDocs = cmdDocsArgs } diff --git a/hadrian/src/Settings/Flavours/Development.hs b/hadrian/src/Settings/Flavours/Development.hs index cce12b53d1..9c0a342bac 100644 --- a/hadrian/src/Settings/Flavours/Development.hs +++ b/hadrian/src/Settings/Flavours/Development.hs @@ -12,7 +12,8 @@ developmentFlavour ghcStage = defaultFlavour , args = defaultBuilderArgs <> developmentArgs ghcStage <> defaultPackageArgs , libraryWays = pure [vanilla] , rtsWays = pure [vanilla, logging, debug, threaded, threadedLogging, threadedDebug] - , dynamicGhcPrograms = return False } + , dynamicGhcPrograms = return False + , ghcDebugAssertions = True } developmentArgs :: Stage -> Args developmentArgs ghcStage = do @@ -24,5 +25,5 @@ developmentArgs ghcStage = do package cabal ? pure ["-O0"]] , hsLibrary = notStage0 ? arg "-dcore-lint" , hsCompiler = mconcat [stage0 ? arg "-O2", - succ stage == ghcStage ? pure ["-O0", "-DDEBUG"]] - , hsGhc = succ stage == ghcStage ? pure ["-O0", "-DDEBUG"] } + succ stage == ghcStage ? pure ["-O0"]] + , hsGhc = succ stage == ghcStage ? pure ["-O0"] } diff --git a/hadrian/src/Settings/Flavours/Validate.hs b/hadrian/src/Settings/Flavours/Validate.hs index 79377e83e3..7e54278f90 100644 --- a/hadrian/src/Settings/Flavours/Validate.hs +++ b/hadrian/src/Settings/Flavours/Validate.hs @@ -37,20 +37,10 @@ validateArgs = sourceArgs SourceArgs slowValidateFlavour :: Flavour slowValidateFlavour = werror $ validateFlavour { name = "slow-validate" - , args = defaultBuilderArgs <> slowValidateArgs <> defaultPackageArgs + , args = defaultBuilderArgs <> validateArgs <> defaultPackageArgs + , ghcDebugAssertions = True } -slowValidateArgs :: Args -slowValidateArgs = - mconcat [ validateArgs - , sourceArgs SourceArgs - { hsCompiler = notStage0 ? arg "-DDEBUG" - , hsDefault = mempty - , hsLibrary = mempty - , hsGhc = mempty - } - ] - quickValidateArgs :: Args quickValidateArgs = sourceArgs SourceArgs { hsDefault = mempty diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs index 33ffa91289..43141610a7 100644 --- a/hadrian/src/Settings/Packages.hs +++ b/hadrian/src/Settings/Packages.hs @@ -26,6 +26,7 @@ packageArgs = do cursesIncludeDir <- getSetting CursesIncludeDir cursesLibraryDir <- getSetting CursesLibDir + debugAssertions <- ghcDebugAssertions <$> expr flavour mconcat --------------------------------- base --------------------------------- @@ -48,7 +49,9 @@ packageArgs = do [ builder Alex ? arg "--latin1" , builder (Ghc CompileHs) ? mconcat - [ inputs ["**/GHC.hs", "**/GHC/Driver/Make.hs"] ? arg "-fprof-auto" + [ debugAssertions ? notStage0 ? arg "-DDEBUG" + + , inputs ["**/GHC.hs", "**/GHC/Driver/Make.hs"] ? arg "-fprof-auto" , input "**/Parser.hs" ? pure ["-fno-ignore-interface-pragmas", "-fcmm-sink"] -- Enable -haddock and -Winvalid-haddock for the compiler @@ -75,7 +78,9 @@ packageArgs = do ---------------------------------- ghc --------------------------------- , package ghc ? mconcat - [ builder Ghc ? arg ("-I" ++ compilerPath) + [ builder Ghc ? mconcat + [ arg ("-I" ++ compilerPath) + , debugAssertions ? notStage0 ? arg "-DDEBUG" ] , builder (Cabal Flags) ? mconcat [ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter" -- cgit v1.2.1