[Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: Test Binary StackSnapshot instance
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Feb 19 16:42:05 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
a1e5e4d3 by Sven Tennie at 2023-02-19T10:22:35+00:00
Test Binary StackSnapshot instance
- - - - -
8fb2e54a by Sven Tennie at 2023-02-19T16:41:46+00:00
Fix Printer.c
- - - - -
4 changed files:
- libraries/ghci/GHCi/Message.hs
- rts/Printer.c
- + testsuite/tests/ghci/should_run/BinaryStackSnapshot.hs
- testsuite/tests/ghci/should_run/all.T
Changes:
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -479,7 +479,7 @@ instance Binary Heap.TsoFlags
instance Binary Heap.SpecialRetSmall
instance Binary Heap.UpdateFrameType
instance Binary Heap.RetFunType
--- TODO: Revisit this. This instance is pretty hacky (unsafeCoerce# ...)
+
instance Binary StackSnapshot where
get = do
v <- get @Word
=====================================
rts/Printer.c
=====================================
@@ -260,7 +260,6 @@ printClosure( const StgClosure *obj )
case UPDATE_FRAME:
{
StgUpdateFrame* u = (StgUpdateFrame*)obj;
- debugBelch("printObj - frame %p, indirectee %p\n", u, u->updatee);
debugBelch("%s(", info_update_frame(obj));
printPtr((StgPtr)GET_INFO((StgClosure *)u));
debugBelch(",");
@@ -280,32 +279,6 @@ printClosure( const StgClosure *obj )
break;
}
- case CATCH_STM_FRAME:
- {
- StgCatchSTMFrame* c = (StgCatchSTMFrame*)obj;
- debugBelch("CATCH_STM_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)c));
- debugBelch(",");
- printPtr((StgPtr)c->code);
- debugBelch(",");
- printPtr((StgPtr)c->handler);
- debugBelch(")\n");
- break;
- }
-
- case ATOMICALLY_FRAME :
- {
- StgAtomicallyFrame* f = (StgAtomicallyFrame*)obj;
- debugBelch("ATOMICALLY_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)f));
- debugBelch(",");
- printPtr((StgPtr)f->code);
- debugBelch(",");
- printPtr((StgPtr)f->result);
- debugBelch(")\n");
- break;
- }
-
case UNDERFLOW_FRAME:
{
StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
@@ -491,7 +464,6 @@ const char *info_update_frame(const StgClosure *closure)
// it pointing to the code or struct members when compiling with
// TABLES_NEXT_TO_CODE.
const StgInfoTable *info = closure->header.info;
- debugBelch("info_update_frame - closure %p, info %p\n", closure, info);
if (info == &stg_upd_frame_info) {
return "NORMAL_UPDATE_FRAME";
} else if (info == &stg_bh_upd_frame_info) {
@@ -502,46 +474,21 @@ const char *info_update_frame(const StgClosure *closure)
return "ERROR: Not an update frame!!!";
}
}
-// TODO: Remove later
-// Assumes little endian
-void printBits(size_t const size, void const * const ptr)
-{
- unsigned char *b = (unsigned char*) ptr;
- unsigned char byte;
- int i, j;
-
- for (i = size-1; i >= 0; i--) {
- for (j = 7; j >= 0; j--) {
- byte = (b[i] >> j) & 1;
- debugBelch("%u", byte);
- }
- }
- debugBelch("\n");
-}
-
-StgPtr origSp = NULL;
static void
printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
uint32_t size )
{
- debugBelch("printSmallBitmap - payload %p\n", payload);
- debugBelch("printSmallBitmap - bitmap ");
- printBits(sizeof(StgWord), &bitmap);
- debugBelch("printSmallBitmap - size %u, bitmap %ul\n", size, bitmap);
-
uint32_t i;
for(i = 0; i < size; i++, bitmap >>= 1 ) {
- debugBelch("printSmallBitmap - index %ld\n", &payload[i] - origSp);
debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
if ((bitmap & 1) == 0) {
- debugBelch("closure - ");
printPtr((P_)payload[i]);
debugBelch(" -- ");
printObj((StgClosure*) payload[i]);
} else {
- debugBelch("primitive - Word# %" FMT_Word "\n", (W_)payload[i]);
+ debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
}
}
}
@@ -556,44 +503,36 @@ printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
i = 0;
for (bmp=0; i < size; bmp++) {
StgWord bitmap = large_bitmap->bitmap[bmp];
- debugBelch("printLargeBitmap - bitmap no %ul, bits ", bmp);
- printBits(sizeof(StgWord), &bitmap);
j = 0;
for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
if ((bitmap & 1) == 0) {
- debugBelch("closure - ");
printPtr((P_)payload[i]);
debugBelch(" -- ");
printObj((StgClosure*) payload[i]);
} else {
- debugBelch("primitive - Word# %" FMT_Word "\n", (W_)payload[i]);
+ debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
}
}
}
}
-
void
printStackChunk( StgPtr sp, StgPtr spBottom )
{
const StgInfoTable *info;
- origSp = sp;
ASSERT(sp <= spBottom);
for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
+
info = get_itbl((StgClosure *)sp);
- debugBelch("printStackChunk - closure size : %lu , sp : %p, spBottom %p, info ptr %p, itbl type %ul \n", stack_frame_sizeW((StgClosure *)sp), sp, spBottom, info, info->type);
- debugBelch("printStackChunk - index: %ld \n", sp - origSp);
switch (info->type) {
- case UNDERFLOW_FRAME:
case UPDATE_FRAME:
case CATCH_FRAME:
+ case UNDERFLOW_FRAME:
case STOP_FRAME:
- case CATCH_STM_FRAME:
- case ATOMICALLY_FRAME:
printClosure((StgClosure*)sp);
continue;
@@ -651,7 +590,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
debugBelch("RET_SMALL (%p)\n", info);
}
StgWord bitmap = info->layout.bitmap;
- debugBelch("printStackChunk - RET_SMALL - bitmap: %lu \n", bitmap);
printSmallBitmap(spBottom, sp+1,
BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
continue;
@@ -710,10 +648,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
case RET_BIG:
debugBelch("RET_BIG (%p)\n", sp);
- debugBelch("payload ptr : %p \n", (StgPtr)((StgClosure *) sp)->payload);
StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
- debugBelch("bitmap ptr %p\n", bitmap);
- debugBelch("bitmap size %ul\n", bitmap->size);
printLargeBitmap(spBottom,
(StgPtr)((StgClosure *) sp)->payload,
bitmap,
@@ -739,7 +674,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
default:
- // sp + 3 because the payload's offset is 24
printSmallBitmap(spBottom, sp+3,
BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
@@ -757,8 +691,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
void printStack( StgStack *stack )
{
- debugBelch("printStack - stack %p, sp %p, size %ul, bottom %p\n", stack, stack->sp, stack->stack_size, stack->stack + stack->stack_size);
-
printStackChunk( stack->sp, stack->stack + stack->stack_size );
}
=====================================
testsuite/tests/ghci/should_run/BinaryStackSnapshot.hs
=====================================
@@ -0,0 +1,19 @@
+module Main where
+
+import Data.Binary
+import GHC.Stack.CloneStack (cloneMyStack)
+import GHCi.Message ()
+
+main :: IO ()
+main = do
+ stack <- cloneMyStack
+ let stack' = (decode . encode) stack
+
+ if stack == stack'
+ then pure ()
+ else
+ error $
+ "Encoding/decoding roundtrip went wrong! stack "
+ ++ show stack
+ ++ ", stack' "
+ ++ show stack'
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -34,6 +34,7 @@ test('T12525', just_ghci, ghci_script, ['T12525.script'])
test('T12549', just_ghci, ghci_script, ['T12549.script'])
test('T13456', [just_ghci, combined_output], ghci_script, ['T13456.script'])
test('BinaryArray', normal, compile_and_run, [''])
+test('BinaryStackSnapshot', normal, compile_and_run, [''])
test('T14125a', just_ghci, ghci_script, ['T14125a.script'])
test('T13825-ghci',just_ghci, ghci_script, ['T13825-ghci.script'])
test('T14608', just_ghci, ghci_script, ['T14608.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bab63f7f014e1ff0d5479506680c35e7386bdf0e...8fb2e54ab16b3dfe5f26a3f4a027b3395ac3f6dd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bab63f7f014e1ff0d5479506680c35e7386bdf0e...8fb2e54ab16b3dfe5f26a3f4a027b3395ac3f6dd
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/20230219/e5856c8b/attachment-0001.html>
More information about the ghc-commits
mailing list