[Git][ghc/ghc][master] 2 commits: Add support for -debug in the testsuite
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Apr 11 23:25:13 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00
Add support for -debug in the testsuite
Confusingly, GhcDebugged referred to GhcDebugAssertions.
- - - - -
b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00
Add missing cases in -Di prettyprinter
Fixes #23142
- - - - -
11 changed files:
- hadrian/src/Oracles/TestSettings.hs
- hadrian/src/Settings/Builders/RunTest.hs
- rts/Printer.c
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/ghc-config/ghc-config.hs
- testsuite/mk/test.mk
- testsuite/tests/rts/Makefile
- + testsuite/tests/rts/T23142.hs
- + testsuite/tests/rts/T23142.stdout
- testsuite/tests/rts/all.T
Changes:
=====================================
hadrian/src/Oracles/TestSettings.hs
=====================================
@@ -25,8 +25,9 @@ data TestSetting = TestHostOS
| TestTARGETPLATFORM
| TestTargetOS_CPP
| TestTargetARCH_CPP
+ | TestRTSWay
| TestGhcStage
- | TestGhcDebugged
+ | TestGhcDebugAssertions
| TestGhcWithNativeCodeGen
| TestGhcWithInterpreter
| TestGhcWithRtsLinker
@@ -56,8 +57,9 @@ testSetting key = do
TestTARGETPLATFORM -> "TARGETPLATFORM"
TestTargetOS_CPP -> "TargetOS_CPP"
TestTargetARCH_CPP -> "TargetARCH_CPP"
+ TestRTSWay -> "RTSWay"
TestGhcStage -> "GhcStage"
- TestGhcDebugged -> "GhcDebugged"
+ TestGhcDebugAssertions -> "GhcDebugAssertions"
TestGhcWithNativeCodeGen -> "GhcWithNativeCodeGen"
TestGhcWithInterpreter -> "GhcWithInterpreter"
TestGhcWithRtsLinker -> "GhcWithRtsLinker"
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -69,6 +69,9 @@ data TestCompilerArgs = TestCompilerArgs{
, unregisterised :: Bool
, tables_next_to_code :: Bool
, targetWithSMP :: Bool -- does the target support SMP
+ , debugged :: Bool
+ -- ^ Whether the compiler has the debug RTS,
+ -- corresponding to the -debug option.
, debugAssertions :: Bool
-- ^ Whether the compiler has debug assertions enabled,
-- corresponding to the -DDEBUG option.
@@ -104,6 +107,7 @@ inTreeCompilerArgs stg = do
let ghcStage = succStage stg
debugAssertions <- ghcDebugAssertions <$> flavour <*> pure ghcStage
+ debugged <- ghcDebugged <$> flavour <*> pure ghcStage
profiled <- ghcProfiled <$> flavour <*> pure ghcStage
os <- setting HostOs
@@ -149,12 +153,14 @@ outOfTreeCompilerArgs = do
unregisterised <- getBooleanSetting TestGhcUnregisterised
tables_next_to_code <- getBooleanSetting TestGhcTablesNextToCode
targetWithSMP <- targetSupportsSMP
- debugAssertions <- getBooleanSetting TestGhcDebugged
+ debugAssertions <- getBooleanSetting TestGhcDebugAssertions
os <- getTestSetting TestHostOS
arch <- getTestSetting TestTargetARCH_CPP
platform <- getTestSetting TestTARGETPLATFORM
wordsize <- getTestSetting TestWORDSIZE
+ rtsWay <- getTestSetting TestRTSWay
+ let debugged = "debug" `isInfixOf` rtsWay
llc_cmd <- getTestSetting TestLLC
have_llvm <- liftIO (isJust <$> findExecutable llc_cmd)
@@ -243,6 +249,7 @@ runTestBuilderArgs = builder Testsuite ? do
, 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 debugAssertions
+ , arg "-e", arg $ "config.debug_rts=" ++ show debugged
-- MP: TODO, we do not need both, they get aliased to the same thing.
, arg "-e", arg $ asBool "ghc_with_native_codegen=" withNativeCodeGen
=====================================
rts/Printer.c
=====================================
@@ -297,6 +297,45 @@ printClosure( const StgClosure *obj )
break;
}
+ case ATOMICALLY_FRAME:
+ {
+ StgAtomicallyFrame* u = (StgAtomicallyFrame*)obj;
+ debugBelch("ATOMICALLY_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(",");
+ printPtr((StgPtr)u->code);
+ debugBelch(",");
+ printPtr((StgPtr)u->result);
+ debugBelch(")\n");
+ break;
+ }
+
+ case CATCH_RETRY_FRAME:
+ {
+ StgCatchRetryFrame* u = (StgCatchRetryFrame*)obj;
+ debugBelch("CATCH_RETRY_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(",");
+ printPtr((StgPtr)u->first_code);
+ debugBelch(",");
+ printPtr((StgPtr)u->alt_code);
+ debugBelch(")\n");
+ break;
+ }
+
+ case CATCH_STM_FRAME:
+ {
+ StgCatchSTMFrame* u = (StgCatchSTMFrame*)obj;
+ debugBelch("CATCH_STM_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ debugBelch(",");
+ printPtr((StgPtr)u->code);
+ debugBelch(",");
+ printPtr((StgPtr)u->handler);
+ debugBelch(")\n");
+ break;
+ }
+
case ARR_WORDS:
{
StgWord i;
@@ -319,6 +358,10 @@ printClosure( const StgClosure *obj )
debugBelch("MUT_ARR_PTRS_FROZEN_CLEAN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
break;
+ case MUT_ARR_PTRS_FROZEN_DIRTY:
+ debugBelch("MUT_ARR_PTRS_FROZEN_DIRTY(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
+ break;
+
case SMALL_MUT_ARR_PTRS_CLEAN:
debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
(W_)((StgSmallMutArrPtrs *)obj)->ptrs);
@@ -334,6 +377,11 @@ printClosure( const StgClosure *obj )
(W_)((StgSmallMutArrPtrs *)obj)->ptrs);
break;
+ case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
+ debugBelch("SMALL_MUT_ARR_PTRS_FROZEN_DIRTY(size=%" FMT_Word ")\n",
+ (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+ break;
+
case MVAR_CLEAN:
case MVAR_DIRTY:
{
@@ -533,6 +581,9 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
case CATCH_FRAME:
case UNDERFLOW_FRAME:
case STOP_FRAME:
+ case ATOMICALLY_FRAME:
+ case CATCH_RETRY_FRAME:
+ case CATCH_STM_FRAME:
printClosure((StgClosure*)sp);
continue;
=====================================
testsuite/driver/testglobals.py
=====================================
@@ -64,6 +64,9 @@ class TestConfig:
# Was the compiler compiled with DEBUG?
self.compiler_debugged = False
+ # Was the compiler compiled with -debug?
+ self.debug_rts = False
+
# Was the compiler compiled with LLVM?
self.ghc_built_by_llvm = False
=====================================
testsuite/driver/testlib.py
=====================================
@@ -681,6 +681,9 @@ def compiler_profiled( ) -> bool:
def compiler_debugged( ) -> bool:
return config.compiler_debugged
+def debug_rts( ) -> bool:
+ return config.debug_rts
+
def have_gdb( ) -> bool:
return config.have_gdb
=====================================
testsuite/ghc-config/ghc-config.hs
=====================================
@@ -13,12 +13,13 @@ main = do
getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform"
getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture"
+ getGhcFieldOrFail fields "RTSWay" "RTS way"
info <- readProcess ghc ["--info"] ""
let fields = read info :: [(String,String)]
getGhcFieldOrFail fields "GhcStage" "Stage"
- getGhcFieldOrFail fields "GhcDebugged" "Debug on"
+ getGhcFieldOrFail fields "GhcDebugAssertions" "Debug on"
getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
getGhcFieldOrFail fields "GhcWithRtsLinker" "target has RTS linker"
=====================================
testsuite/mk/test.mk
=====================================
@@ -78,7 +78,7 @@ endif
RUNTEST_OPTS += -e "ghc_compiler_always_flags='$(TEST_HC_OPTS)'"
-ifeq "$(GhcDebugged)" "YES"
+ifeq "$(GhcDebugAssertions)" "YES"
RUNTEST_OPTS += -e "config.compiler_debugged=True"
else
RUNTEST_OPTS += -e "config.compiler_debugged=False"
=====================================
testsuite/tests/rts/Makefile
=====================================
@@ -147,3 +147,13 @@ EventlogOutput_IPE:
"$(TEST_HC)" -debug -finfo-table-map -v0 EventlogOutput.hs
./EventlogOutput +RTS -va 2> EventlogOutput_IPE.stderr.log
grep "IPE:" EventlogOutput_IPE.stderr.log
+
+.PHONY: T23142
+T23142:
+ # Test that the -Di output contains different frames
+ "$(TEST_HC)" --run -ignore-dot-ghci T23142.hs +RTS -Di -RTS 2> T23142.log
+ grep -m1 -c "ATOMICALLY_FRAME" T23142.log
+ grep -m1 -c "CATCH_RETRY_FRAME" T23142.log
+ grep -m1 -c "CATCH_STM_FRAME" T23142.log
+ grep -m1 -c "MUT_ARR_PTRS_FROZEN_DIRTY" T23142.log
+ grep -m1 -c "SMALL_MUT_ARR_PTRS_FROZEN_DIRTY" T23142.log
=====================================
testsuite/tests/rts/T23142.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE UnboxedTuples, MagicHash #-}
+module T23142 where
+
+import GHC.IO
+import GHC.Exts
+
+main :: IO ()
+main = IO (\s -> case newArray# 10# (2 :: Int) s of
+ (# s', a #) -> case unsafeFreezeArray# a s' of
+ (# s'', _ #) -> (# s'', () #))
+ >>
+ IO (\s -> case newSmallArray# 10# (2 :: Int) s of
+ (# s', a #) -> case unsafeFreezeSmallArray# a s' of
+ (# s'', _ #) -> (# s'', () #))
+ >>
+ IO (atomically# (\s -> catchSTM# (\s -> (# s, () #)) (\_ s -> (# s, () #)) s))
+ >>
+ IO (atomically# (\s -> catchRetry# (\s -> (# s, () #)) (\s -> (# s, () #)) s))
=====================================
testsuite/tests/rts/T23142.stdout
=====================================
@@ -0,0 +1,5 @@
+1
+1
+1
+1
+1
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -575,3 +575,5 @@ test('T22795b', [only_ways(['normal']), js_skip], compile_and_run, ['-single-thr
test('T22795c', [only_ways(['normal']), js_skip], compile_and_run, ['-threaded -single-threaded'])
test('T17574', [js_skip], compile_and_run, ['-with-rtsopts -T'])
+
+test('T23142', [unless(debug_rts(), skip), req_interp], makefile_test, ['T23142'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ba77b369a170ba68f4eb5c8f3ae13e03dcbb28d...b7474b57830261a94903da61bb2df33022c11357
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ba77b369a170ba68f4eb5c8f3ae13e03dcbb28d...b7474b57830261a94903da61bb2df33022c11357
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/20230411/0f488351/attachment-0001.html>
More information about the ghc-commits
mailing list