[Git][ghc/ghc][wip/decode_cloned_stack] Test RET_FUN/ARG_GEN
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Fri Jan 13 19:11:24 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
572878b4 by Sven Tennie at 2023-01-13T19:10:01+00:00
Test RET_FUN/ARG_GEN
- - - - -
7 changed files:
- libraries/ghc-heap/cbits/Stack.c
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/tests/stack_lib.c
- libraries/ghc-heap/tests/stack_misc_closures.hs
- libraries/ghc-heap/tests/stack_misc_closures_c.c
- libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
- rts/Printer.c
Changes:
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -111,7 +111,7 @@ StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {
const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
switch (fun_info->f.fun_type) {
case ARG_GEN:
- return BITMAP_BITS(fun_info->f.b.bitmap);
+ return BITMAP_SIZE(fun_info->f.b.bitmap);
case ARG_GEN_BIG:
return GET_FUN_LARGE_BITMAP(fun_info)->size;
default:
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -117,7 +117,7 @@ getRetFunSmallBitmapzh(P_ stack, W_ index) {
(bitmap) = ccall getRetFunBitmapWord(c);
(size) = ccall getRetFunBitmapSize(c);
- ccall debugBelch("getRetFunSmallBitmapzh - bitmap %ul , size %u", bitmap, size);
+ ccall debugBelch("getRetFunSmallBitmapzh - bitmap %ul , size %u\n", bitmap, size);
return (bitmap, size);
}
=====================================
libraries/ghc-heap/tests/stack_lib.c
=====================================
@@ -177,7 +177,7 @@ ClosureTypeList *foldStackToList(StgStack *stack) {
ClosureTypeList *bitmapList;
switch (fun_info->f.fun_type) {
case ARG_GEN:
- bitmapList = foldSmallBitmapToList(spBottom, sp + 2,
+ bitmapList = foldSmallBitmapToList(spBottom, sp + 3,
BITMAP_BITS(fun_info->f.b.bitmap),
BITMAP_SIZE(fun_info->f.b.bitmap));
break;
@@ -189,16 +189,17 @@ ClosureTypeList *foldStackToList(StgStack *stack) {
}
default: {
bitmapList = foldSmallBitmapToList(
- spBottom, sp + 2,
+ spBottom, sp + 3,
BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
break;
}
}
result = concat(result, bitmapList);
+ continue;
}
default: {
- errorBelch("Unexpected closure type!");
+ errorBelch("Unexpected closure type: %us", info->type);
break;
}
}
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -52,6 +52,8 @@ foreign import prim "any_ret_big_closures_two_words_framezh" any_ret_big_closure
foreign import prim "any_ret_fun_arg_n_prim_framezh" any_ret_fun_arg_n_prim_framezh# :: SetupFunction
+foreign import prim "any_ret_fun_arg_gen_framezh" any_ret_fun_arg_gen_framezh# :: SetupFunction
+
foreign import ccall "maxSmallBitmapBits" maxSmallBitmapBits_c :: Word
foreign import ccall "belchStack" belchStack# :: StackSnapshot# -> IO ()
@@ -194,6 +196,30 @@ main = do
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1]
e -> error $ "Wrong closure type: " ++ show e
+ test any_ret_fun_arg_gen_framezh# $
+ \case
+ RetFun {..} -> do
+ assertEqual retFunType ARG_GEN
+ assertEqual retFunSize 8
+ fc <- getBoxedClosureData retFunFun
+ case fc of
+ FunClosure {..} -> do
+ assertEqual (tipe info) FUN_STATIC
+ assertEqual (null dataArgs) True
+ assertEqual (null ptrArgs) True
+ e -> error $ "Wrong closure type: " ++ show e
+ pCs <- mapM getBoxedClosureData retFunPayload
+ assertEqual (length pCs) 8
+ let w0 = getWordFromUnknownTypeWordSizedPrimitive (head pCs)
+ w1 = getWordFromConstr01 (pCs !! 1)
+ w2 = getWordFromConstr01 (pCs !! 2)
+ w3 = getWordFromUnknownTypeWordSizedPrimitive (pCs !! 3)
+ w4 = getWordFromUnknownTypeWordSizedPrimitive (pCs !! 4)
+ w5 = getWordFromUnknownTypeWordSizedPrimitive (pCs !! 5)
+ w6 = getWordFromUnknownTypeWordSizedPrimitive (pCs !! 6)
+ w7 = getWordFromConstr01 (pCs !! 7)
+ assertEqual [w0, w1, w2, w3, w4, w5, w6, w7] [1, 2 ,3, 4, 5, 6, 7, 8]
+ e -> error $ "Wrong closure type: " ++ show e
type SetupFunction = State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -8,9 +8,12 @@
#include "rts/storage/Closures.h"
#include "rts/storage/InfoTables.h"
#include "rts/storage/TSO.h"
+#include "stg/MiscClosures.h"
#include "stg/Types.h"
+// TODO: Delete when development finished
extern void printStack(StgStack *stack);
+extern void printObj(StgClosure *obj);
// See rts/Threads.c
#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 3)
@@ -155,13 +158,14 @@ void create_any_ret_big_closures_two_words_frame(Capability *cap,
}
RTS_RET(test_ret_fun);
-RTS_RET(test_fun_0_1);
+RTS_RET(test_arg_n_fun_0_1);
void create_any_ret_fun_arg_n_prim_frame(Capability *cap, StgStack *stack,
StgWord w) {
StgRetFun *c = (StgRetFun *)stack->sp;
c->info = &test_ret_fun_info;
- StgClosure *f = (StgClosure *)allocate(cap, sizeofW(StgClosure) * sizeofW(StgWord));
- SET_HDR(f, &test_fun_0_1_info, ccs)
+ StgClosure *f =
+ (StgClosure *)allocate(cap, sizeofW(StgClosure) + sizeofW(StgWord));
+ SET_HDR(f, &test_arg_n_fun_0_1_info, ccs)
c->fun = f;
const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun));
c->size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
@@ -169,10 +173,39 @@ void create_any_ret_fun_arg_n_prim_frame(Capability *cap, StgStack *stack,
// memory layout fits.
c->payload[0] = (StgClosure *)w;
f->payload[0] = (StgClosure *)w;
- printStack(stack);
}
-void checkSTACK(StgStack *stack);
+RTS_CLOSURE(base_GHCziIOziEncodingziLatin1_zdwasciizuencode_closure);
+void create_any_ret_fun_arg_gen_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgRetFun *c = (StgRetFun *)stack->sp;
+ c->info = &test_ret_fun_info;
+ // The selection of this closure was a bit arbitrary: There aren't many
+ // ARG_GEN closures around and I found this one first. N.B.: The payload
+ // values (and their types) are non-sense. But, this should be okay as we're
+ // only testing de-serialization.
+ c->fun = &base_GHCziIOziEncodingziLatin1_zdwasciizuencode_closure;
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun));
+ c->size = BITMAP_SIZE(fun_info->f.b.bitmap);
+ c->payload[0] = (StgClosure *)w;
+ c->payload[1] = rts_mkWord(cap, ++w);
+ c->payload[2] = rts_mkWord(cap, ++w);
+ c->payload[3] = (StgClosure *)++w;
+ c->payload[4] = (StgClosure *)++w;
+ c->payload[5] = (StgClosure *)++w;
+ c->payload[6] = (StgClosure *)++w;
+ c->payload[7] = rts_mkWord(cap, ++w);
+
+ // TODO: Is this really needed? ghc-heap does not need it. Does the GC need
+ // it?
+ for (int i = 0; i < 8; i++) {
+ c->fun->payload[i] = c->payload[i];
+ }
+}
+
+// Import from Sanity.c
+extern void checkSTACK(StgStack *stack);
+
StgStack *setup(Capability *cap, StgWord closureSizeWords,
void (*f)(Capability *, StgStack *, StgWord)) {
StgWord totalSizeWords =
@@ -195,6 +228,8 @@ StgStack *setup(Capability *cap, StgWord closureSizeWords,
// have distinct values in the closure to ensure nothing gets mixed up.
f(cap, stack, 1);
+ // Make a sanitiy check to find unsound closures before the GC and the decode
+ // code.
checkSTACK(stack);
return stack;
}
@@ -265,4 +300,10 @@ StgStack *any_ret_fun_arg_n_prim_frame(Capability *cap) {
&create_any_ret_fun_arg_n_prim_frame);
}
+StgStack *any_ret_fun_arg_gen_frame(Capability *cap) {
+ return setup(
+ cap, sizeofW(StgRetFun) + 5 * sizeofW(StgWord) + 3 * sizeofW(StgClosure),
+ &create_any_ret_fun_arg_gen_frame);
+}
+
void belchStack(StgStack *stack) { printStack(stack); }
=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -78,6 +78,11 @@ any_ret_fun_arg_n_prim_framezh() {
return (stack);
}
+any_ret_fun_arg_gen_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_fun_arg_gen_frame(MyCapability() "ptr");
+ return (stack);
+}
INFO_TABLE_RET ( test_small_ret_full_p, RET_SMALL, W_ info_ptr,
#if SIZEOF_VOID_P == 4
@@ -195,7 +200,7 @@ INFO_TABLE_RET ( test_ret_fun, RET_FUN, W_ info_ptr, W_ size, P_ fun, P_ payload
return ();
}
-INFO_TABLE_FUN ( test_fun_0_1, 0 , 0, FUN_0_1, "FUN_0_1", "FUN_0_1", 1, ARG_N)
+INFO_TABLE_FUN ( test_arg_n_fun_0_1, 0 , 0, FUN_0_1, "FUN_0_1", "FUN_0_1", 1, ARG_N)
return (/* no return values */)
{
return ();
=====================================
rts/Printer.c
=====================================
@@ -729,7 +729,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
switch (fun_info->f.fun_type) {
case ARG_GEN:
- printSmallBitmap(spBottom, sp+2,
+ printSmallBitmap(spBottom, sp+3,
BITMAP_BITS(fun_info->f.b.bitmap),
BITMAP_SIZE(fun_info->f.b.bitmap));
break;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/572878b4df78d905a9a9d50b2765f14acbaed9e7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/572878b4df78d905a9a9d50b2765f14acbaed9e7
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/20230113/bacc8d98/attachment-0001.html>
More information about the ghc-commits
mailing list