[Git][ghc/ghc][wip/decode_cloned_stack] Test RET_FUN/ARG_GEN_BIG
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Jan 14 11:35:31 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
fa21c734 by Sven Tennie at 2023-01-14T11:34:56+00:00
Test RET_FUN/ARG_GEN_BIG
- - - - -
8 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/tests/all.T
- 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/CloneStack.c
- rts/Printer.c
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -181,7 +181,7 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) = trace ("decoding ... "
fun' <- getClosure sfi offsetStgRetFunFrameFun
payload' <-
if t == CL.ARG_GEN_BIG then
- decodeLargeBitmap getRetFunLargeBitmap# sfi 2##
+ decodeLargeBitmap getRetFunLargeBitmap# sfi 3##
else
-- TODO: The offsets should be based on DerivedConstants.h
decodeSmallBitmap getRetFunSmallBitmap# sfi 3##
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -39,20 +39,20 @@ test('closure_size_noopt',
compile_and_run, [''])
test('tso_and_stack_closures',
- [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']),
+ [extra_files(['create_tso.c','create_tso.h','TestUtils.hs','stack_lib.c']),
only_ways(['profthreaded']),
ignore_stdout,
ignore_stderr
],
- multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])
+ multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c',''), ('stack_lib.c', '')], ''])
test('parse_tso_flags',
- [extra_files(['TestUtils.hs']),
+ [extra_files(['stack_lib.c', 'TestUtils.hs']),
only_ways(['normal']),
ignore_stdout,
ignore_stderr
],
- compile_and_run, [''])
+ multi_compile_and_run, ['parse_tso_flags', [('stack_lib.c','')], ''])
test('T21622',
only_ways(['normal']),
compile_and_run, [''])
@@ -108,5 +108,5 @@ test('stack_misc_closures',
,('stack_misc_closures_prim.cmm', '')
,('stack_lib.c', '')
]
- , '-debug -optc-g -g'
+ , '-debug -optc-g -g -ddump-to-file -dlint -dppr-debug -ddump-cmm'
])
=====================================
libraries/ghc-heap/tests/stack_lib.c
=====================================
@@ -183,7 +183,7 @@ ClosureTypeList *foldStackToList(StgStack *stack) {
break;
case ARG_GEN_BIG: {
bitmapList = foldLargeBitmapToList(
- spBottom, sp + 2, GET_FUN_LARGE_BITMAP(fun_info),
+ spBottom, sp + 3, GET_FUN_LARGE_BITMAP(fun_info),
GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
}
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -12,19 +12,19 @@
module Main where
+-- TODO: Remove later
+import Debug.Trace
import GHC.Exts
import GHC.Exts.DecodeStack
import GHC.Exts.Heap
+import GHC.Exts.Heap (GenClosure (wordVal), HasHeapRep (getClosureData))
import GHC.Exts.Heap.Closures
+import GHC.IO (IO (..))
import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack (StackSnapshot (..))
+import System.Mem
import TestUtils
import Unsafe.Coerce (unsafeCoerce)
-import GHC.Exts.Heap (GenClosure(wordVal), HasHeapRep (getClosureData))
-import System.Mem
---TODO: Remove later
-import Debug.Trace
-import GHC.IO (IO (..))
foreign import prim "any_update_framezh" any_update_frame# :: SetupFunction
@@ -54,6 +54,8 @@ foreign import prim "any_ret_fun_arg_n_prim_framezh" any_ret_fun_arg_n_prim_fram
foreign import prim "any_ret_fun_arg_gen_framezh" any_ret_fun_arg_gen_framezh# :: SetupFunction
+foreign import prim "any_ret_fun_arg_gen_big_framezh" any_ret_fun_arg_gen_big_framezh# :: SetupFunction
+
foreign import ccall "maxSmallBitmapBits" maxSmallBitmapBits_c :: Word
foreign import ccall "belchStack" belchStack# :: StackSnapshot# -> IO ()
@@ -142,7 +144,7 @@ main = do
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) (fromIntegral maxSmallBitmapBits_c)
let wds = map getWordFromConstr01 pCs
- assertEqual wds [1..58]
+ assertEqual wds [1 .. 58]
e -> error $ "Wrong closure type: " ++ show e
test any_ret_small_prims_frame# $
\case
@@ -151,7 +153,7 @@ main = do
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) (fromIntegral maxSmallBitmapBits_c)
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
- assertEqual wds [1..58]
+ assertEqual wds [1 .. 58]
e -> error $ "Wrong closure type: " ++ show e
test any_ret_big_prims_min_frame# $
\case
@@ -159,7 +161,7 @@ main = do
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 59
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
- assertEqual wds [1..59]
+ assertEqual wds [1 .. 59]
e -> error $ "Wrong closure type: " ++ show e
test any_ret_big_prims_min_frame# $
\case
@@ -167,7 +169,7 @@ main = do
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 59
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
- assertEqual wds [1..59]
+ assertEqual wds [1 .. 59]
e -> error $ "Wrong closure type: " ++ show e
test any_ret_big_closures_min_frame# $
\case
@@ -175,7 +177,7 @@ main = do
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 59
let wds = map getWordFromConstr01 pCs
- assertEqual wds [1..59]
+ assertEqual wds [1 .. 59]
e -> error $ "Wrong closure type: " ++ show e
test any_ret_big_closures_two_words_frame# $
\case
@@ -183,7 +185,7 @@ main = do
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 65
let wds = map getWordFromConstr01 pCs
- assertEqual wds [1..65]
+ assertEqual wds [1 .. 65]
e -> error $ "Wrong closure type: " ++ show e
test any_ret_fun_arg_n_prim_framezh# $
\case
@@ -193,7 +195,7 @@ main = do
assertFun01Closure 1 =<< getBoxedClosureData retFunFun
pCs <- mapM getBoxedClosureData retFunPayload
assertEqual (length pCs) 1
- let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1]
e -> error $ "Wrong closure type: " ++ show e
test any_ret_fun_arg_gen_framezh# $
@@ -218,29 +220,46 @@ main = do
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]
+ assertEqual [w0, w1, w2, w3, w4, w5, w6, w7] [1, 2, 3, 4, 5, 6, 7, 8]
e -> error $ "Wrong closure type: " ++ show e
+ test any_ret_fun_arg_gen_big_framezh# $
+ \case
+ RetFun {..} -> do
+ assertEqual retFunType ARG_GEN_BIG
+ assertEqual retFunSize 70
+ 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
+ traceM $ "pCs " ++ show pCs
+ assertEqual (length pCs) 70
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1 .. 70]
type SetupFunction = State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
test :: HasCallStack => SetupFunction -> (Closure -> IO ()) -> IO ()
test setup assertion = do
- sn <- getStackSnapshot setup
- -- Run garbage collection now, to prevent later surprises: It's hard to debug
- -- when the GC suddenly does it's work and there were bad closures or pointers.
- -- Better fail early, here.
- performGC
- stack <- decodeStack' sn
- assert sn stack
- -- The result of HasHeapRep should be similar (wrapped in the closure for
- -- StgStack itself.)
- let (StackSnapshot sn#) = sn
- stack' <- getClosureData sn#
- case stack' of
- SimpleStack {..} -> do
- !cs <- mapM getBoxedClosureData stackClosures
- assert sn cs
- _ -> error $ "Unexpected closure type : " ++ show stack'
+ sn <- getStackSnapshot setup
+ -- Run garbage collection now, to prevent later surprises: It's hard to debug
+ -- when the GC suddenly does it's work and there were bad closures or pointers.
+ -- Better fail early, here.
+ performGC
+ stack <- decodeStack' sn
+ assert sn stack
+ -- The result of HasHeapRep should be similar (wrapped in the closure for
+ -- StgStack itself.)
+ let (StackSnapshot sn#) = sn
+ stack' <- getClosureData sn#
+ case stack' of
+ SimpleStack {..} -> do
+ !cs <- mapM getBoxedClosureData stackClosures
+ assert sn cs
+ _ -> error $ "Unexpected closure type : " ++ show stack'
where
assert :: StackSnapshot -> [Closure] -> IO ()
assert sn stack = do
@@ -261,7 +280,7 @@ test setup assertion = do
-- just pulls a @StgStack@ from RTS to Haskell land.
getStackSnapshot :: SetupFunction -> IO StackSnapshot
getStackSnapshot action# = IO $ \s ->
- case action# s of (# s1, stack #) -> (# s1, StackSnapshot stack #)
+ case action# s of (# s1, stack #) -> (# s1, StackSnapshot stack #)
assertConstrClosure :: HasCallStack => Word -> Closure -> IO ()
assertConstrClosure w c = case c of
@@ -302,3 +321,79 @@ assertUnknownTypeWordSizedPrimitive w c = case c of
unboxSingletonTuple :: (# StackSnapshot# #) -> StackSnapshot#
unboxSingletonTuple (# s# #) = s#
+
+{-# NOINLINE bigFun #-}
+bigFun ::
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word
+bigFun a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47 a48 a49 a50 a51 a52 a53 a54 a55 a56 a57 a58 a59 a60 a61 a62 a63 a64 a65 a66 a67 a68 a69 a70 =
+ a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + a31 + a32 + a33 + a34 + a35 + a36 + a37 + a38 + a39 + a40 + a41 + a42 + a43 + a44 + a45 + a46 + a47 + a48 + a49 + a50 + a51 + a52 + a53 + a54 + a55 + a56 + a57 + a58 + a59 + a60 + a61 + a62 + a63 + a64 + a65 + a66 + a67 + a68 + a69 + a70
=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -203,6 +203,19 @@ void create_any_ret_fun_arg_gen_frame(Capability *cap, StgStack *stack,
}
}
+RTS_CLOSURE(Main_bigFun_closure);
+void create_any_ret_fun_arg_gen_big_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgRetFun *c = (StgRetFun *)stack->sp;
+ c->info = &test_ret_fun_info;
+ c->fun = &Main_bigFun_closure;
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun));
+ c->size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+ for (int i = 0; i < c->size; i++) {
+ c->payload[i] = rts_mkWord(cap, w++);
+ }
+}
+
// Import from Sanity.c
extern void checkSTACK(StgStack *stack);
@@ -306,4 +319,10 @@ StgStack *any_ret_fun_arg_gen_frame(Capability *cap) {
&create_any_ret_fun_arg_gen_frame);
}
+StgStack *any_ret_fun_arg_gen_big_frame(Capability *cap) {
+ return setup(
+ cap, sizeofW(StgRetFun) + 70 * sizeofW(StgWord),
+ &create_any_ret_fun_arg_gen_big_frame);
+}
+
void belchStack(StgStack *stack) { printStack(stack); }
=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -84,6 +84,12 @@ any_ret_fun_arg_gen_framezh() {
return (stack);
}
+any_ret_fun_arg_gen_big_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_fun_arg_gen_big_frame(MyCapability() "ptr");
+ return (stack);
+}
+
INFO_TABLE_RET ( test_small_ret_full_p, RET_SMALL, W_ info_ptr,
#if SIZEOF_VOID_P == 4
P_ ptr1, P_ ptr2, P_ ptr3, P_ ptr4, P_ ptr5, P_ ptr6, P_ ptr7, P_ ptr8, P_ ptr9, P_ ptr10,
=====================================
rts/CloneStack.c
=====================================
@@ -61,11 +61,6 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack)
break;
}
}
-
-#if defined(DEBUG)
- printStack(top_stack);
-#endif
-
return top_stack;
}
=====================================
rts/Printer.c
=====================================
@@ -734,7 +734,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
BITMAP_SIZE(fun_info->f.b.bitmap));
break;
case ARG_GEN_BIG:
- printLargeBitmap(spBottom, sp+2,
+ printLargeBitmap(spBottom, sp+3,
GET_FUN_LARGE_BITMAP(fun_info),
GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa21c734c0c69a7ae02a9e46a469cae6eb93448c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa21c734c0c69a7ae02a9e46a469cae6eb93448c
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/20230114/f5eb5ca9/attachment-0001.html>
More information about the ghc-commits
mailing list