Add missing cases in -Di prettyprinter

Fixes #23142

5 files changed, 86 insertions, 0 deletions

diff --git a/rts/Printer.c b/rts/Printer.c
index ccd82be877..e2dee0984e 100644
--- a/rts/Printer.c
+++ b/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;
 
diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile
index d7bb87ae91..d6e7b047d8 100644
--- a/testsuite/tests/rts/Makefile
+++ b/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
diff --git a/testsuite/tests/rts/T23142.hs b/testsuite/tests/rts/T23142.hs
new file mode 100644
index 0000000000..75e255c68f
--- /dev/null
+++ b/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))
diff --git a/testsuite/tests/rts/T23142.stdout b/testsuite/tests/rts/T23142.stdout
new file mode 100644
index 0000000000..627e1097cd
--- /dev/null
+++ b/testsuite/tests/rts/T23142.stdout
@@ -0,0 +1,5 @@
+1
+1
+1
+1
+1
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index ba18e32d35..64b21cbc89 100644
--- a/testsuite/tests/rts/all.T
+++ b/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'])