[Git][ghc/ghc][wip/decode_cloned_stack] 8 commits: Cleanup RET_BIG test
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Fri Dec 30 14:41:51 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
647e844f by Sven Tennie at 2022-12-28T14:24:12+00:00
Cleanup RET_BIG test
- - - - -
ccd19ee5 by Sven Tennie at 2022-12-28T15:44:27+00:00
Rename
- - - - -
a528102f by Sven Tennie at 2022-12-28T16:33:22+00:00
Add test
- - - - -
aeeab770 by Sven Tennie at 2022-12-28T16:35:03+00:00
Cleanup
- - - - -
f2a06a9f by Sven Tennie at 2022-12-28T18:10:51+00:00
Ensure decoding with HasHeapRep works as well
- - - - -
7b763c0b by Sven Tennie at 2022-12-28T18:30:09+00:00
Test BIG_RET with 2 words
- - - - -
dd37107c by Sven Tennie at 2022-12-28T18:54:19+00:00
Simplify tests by limiting the word story
- - - - -
f4b3f251 by Sven Tennie at 2022-12-30T10:51:24+00:00
Test RET_FUN ARG_N
- - - - -
9 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/StackConstants.hsc
- 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/GHC/Exts/DecodeStack.hs
=====================================
@@ -183,7 +183,8 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) = trace ("decoding ... "
if t == CL.ARG_GEN_BIG then
decodeLargeBitmap getRetFunLargeBitmap# sfi 2##
else
- decodeSmallBitmap getRetFunSmallBitmap# sfi 2##
+ -- TODO: The offsets should be based on DerivedConstants.h
+ decodeSmallBitmap getRetFunSmallBitmap# sfi 3##
pure $ CL.RetFun t size' fun' payload'
-- TODO: Decode update frame type
UPDATE_FRAME -> let
@@ -271,7 +272,9 @@ decodeStack s = do
#if defined(DEBUG)
belchStack s
#endif
- SimpleStack . (map asBox) <$> decodeStack' s
+ stack <- decodeStack' s
+ let boxed = map DecodedClosureBox stack
+ pure $ SimpleStack boxed
decodeStack' :: StackSnapshot -> IO [CL.Closure]
decodeStack' s = unpackStackFrameIter (stackHead s) >>= \frame -> (frame :) <$> go (advanceStackFrameIter (stackHead s))
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -134,7 +134,7 @@ instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
#if MIN_VERSION_base(4,17,0)
-instance HasHeapRep StackSnapshot# where
+instance {-# OVERLAPPING #-} HasHeapRep StackSnapshot# where
getClosureData s# = decodeStack (StackSnapshot s#)
#endif
=====================================
libraries/ghc-heap/GHC/Exts/StackConstants.hsc
=====================================
@@ -40,13 +40,14 @@ offsetStgCatchRetryFrameAltCode :: Int
offsetStgCatchRetryFrameAltCode = (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
offsetStgRetFunFrameSize :: Int
-offsetStgRetFunFrameSize = (#const OFFSET_StgRetFun_size) + (#size StgHeader)
+-- StgRetFun has no header, but only a pointer to the info table at the beginning.
+offsetStgRetFunFrameSize = (#const OFFSET_StgRetFun_size)
offsetStgRetFunFrameFun :: Int
-offsetStgRetFunFrameFun = (#const OFFSET_StgRetFun_fun) + (#size StgHeader)
+offsetStgRetFunFrameFun = (#const OFFSET_StgRetFun_fun)
offsetStgRetFunFramePayload :: Int
-offsetStgRetFunFramePayload = (#const OFFSET_StgRetFun_payload) + (#size StgHeader)
+offsetStgRetFunFramePayload = (#const OFFSET_StgRetFun_payload)
offsetStgRetBCOFrameInstrs :: Int
offsetStgRetBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -117,6 +117,7 @@ getRetFunSmallBitmapzh(P_ stack, W_ index) {
(bitmap) = ccall getRetFunBitmapWord(c);
(size) = ccall getRetFunBitmapSize(c);
+ ccall debugBelch("getRetFunSmallBitmapzh - bitmap %ul , size %u", bitmap, size);
return (bitmap, size);
}
=====================================
libraries/ghc-heap/tests/stack_lib.c
=====================================
@@ -172,24 +172,30 @@ ClosureTypeList *foldStackToList(StgStack *stack) {
const StgFunInfoTable *fun_info =
get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ result = add(result, fun_info->i.type);
+
+ ClosureTypeList *bitmapList;
switch (fun_info->f.fun_type) {
case ARG_GEN:
- foldSmallBitmapToList(spBottom, sp + 2,
- BITMAP_BITS(fun_info->f.b.bitmap),
- BITMAP_SIZE(fun_info->f.b.bitmap));
+ bitmapList = foldSmallBitmapToList(spBottom, sp + 2,
+ BITMAP_BITS(fun_info->f.b.bitmap),
+ BITMAP_SIZE(fun_info->f.b.bitmap));
break;
case ARG_GEN_BIG: {
- foldSmallBitmapToList(spBottom, sp + 2, GET_FUN_LARGE_BITMAP(fun_info),
- GET_FUN_LARGE_BITMAP(fun_info)->size);
+ bitmapList = foldLargeBitmapToList(
+ spBottom, sp + 2, GET_FUN_LARGE_BITMAP(fun_info),
+ GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
}
default: {
- foldSmallBitmapToList(spBottom, sp + 2,
- BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
- BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
+ bitmapList = foldSmallBitmapToList(
+ spBottom, sp + 2,
+ 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);
}
default: {
errorBelch("Unexpected closure type!");
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -20,8 +20,9 @@ import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack (StackSnapshot (..))
import TestUtils
import Unsafe.Coerce (unsafeCoerce)
-import GHC.Exts.Heap (GenClosure(wordVal))
+import GHC.Exts.Heap (GenClosure(wordVal), HasHeapRep (getClosureData))
import System.Mem
+--TODO: Remove later
import Debug.Trace
import GHC.IO (IO (..))
@@ -43,128 +44,198 @@ foreign import prim "any_ret_small_closure_framezh" any_ret_small_closure_frame#
foreign import prim "any_ret_small_closures_framezh" any_ret_small_closures_frame# :: SetupFunction
-foreign import prim "any_ret_big_prims_framezh" any_ret_big_prims_frame# :: SetupFunction
+foreign import prim "any_ret_big_prims_min_framezh" any_ret_big_prims_min_frame# :: SetupFunction
-foreign import prim "any_ret_big_prim_framezh" any_ret_big_prim_frame# :: SetupFunction
+foreign import prim "any_ret_big_closures_min_framezh" any_ret_big_closures_min_frame# :: SetupFunction
-foreign import prim "any_ret_big_closures_framezh" any_ret_big_closures_frame# :: SetupFunction
+foreign import prim "any_ret_big_closures_two_words_framezh" any_ret_big_closures_two_words_frame# :: SetupFunction
+
+foreign import prim "any_ret_fun_arg_n_prim_framezh" any_ret_fun_arg_n_prim_framezh# :: SetupFunction
foreign import ccall "maxSmallBitmapBits" maxSmallBitmapBits_c :: Word
foreign import ccall "belchStack" belchStack# :: StackSnapshot# -> IO ()
+{-
+__Test stategy:__
+
+- Create @StgStack at s in C that contain two closures (as they are on stack they
+may also be called "frames"). A stop frame and the frame which's decoding should
+be tested.
+
+- Cmm primops are used to get `StackSnapshot#` values. (This detour ensures that
+the closures are referenced by `StackSnapshot#` and not garbage collected right
+away.)
+
+- These can then be decoded and checked.
+
+This strategy may look pretty complex for a test. But, it can provide very
+specific corner cases that would be hard to (reliably!) produce in Haskell.
+
+N.B. `StackSnapshots` are managed by the garbage collector. This isn't much of
+an issue regarding the test data, as it's already very terse. However, it's
+important to know that the GC may rewrite parts of the stack and that the stack
+must be sound (otherwise, the GC may fail badly.)
+
+The decission to make `StackSnapshots`s (and their closures) being managed by the
+GC isn't accidential. It's closer to the reality of decoding stacks.
+
+N.B. the test data stack are only meant be de decoded. They are not executable
+(the result would likely be a crash or non-sense.)
+-}
main :: HasCallStack => IO ()
main = do
- traceM "test any_update_frame#"
- test any_update_frame# 42## $
+ test any_update_frame# $
\case
UpdateFrame {..} -> do
assertEqual knownUpdateFrameType NormalUpdateFrame
- assertEqual 42 =<< (getWordFromBlackhole =<< getBoxedClosureData updatee)
+ assertEqual 1 =<< (getWordFromBlackhole =<< getBoxedClosureData updatee)
e -> error $ "Wrong closure type: " ++ show e
- traceM "test any_catch_frame#"
- test any_catch_frame# 43## $
+ test any_catch_frame# $
\case
CatchFrame {..} -> do
assertEqual exceptions_blocked 1
- assertConstrClosure 43 =<< getBoxedClosureData handler
+ assertConstrClosure 1 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
- traceM "test any_catch_stm_frame#"
- test any_catch_stm_frame# 44## $
+ test any_catch_stm_frame# $
\case
CatchStmFrame {..} -> do
- assertConstrClosure 44 =<< getBoxedClosureData catchFrameCode
- assertConstrClosure 45 =<< getBoxedClosureData handler
+ assertConstrClosure 1 =<< getBoxedClosureData catchFrameCode
+ assertConstrClosure 2 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
- traceM "test any_catch_retry_frame#"
- test any_catch_retry_frame# 46## $
+ test any_catch_retry_frame# $
\case
CatchRetryFrame {..} -> do
assertEqual running_alt_code 1
- assertConstrClosure 46 =<< getBoxedClosureData first_code
- assertConstrClosure 47 =<< getBoxedClosureData alt_code
+ assertConstrClosure 1 =<< getBoxedClosureData first_code
+ assertConstrClosure 2 =<< getBoxedClosureData alt_code
e -> error $ "Wrong closure type: " ++ show e
- traceM "test any_atomically_frame#"
- test any_atomically_frame# 48## $
+ test any_atomically_frame# $
\case
AtomicallyFrame {..} -> do
- assertConstrClosure 48 =<< getBoxedClosureData atomicallyFrameCode
- assertConstrClosure 49 =<< getBoxedClosureData result
+ assertConstrClosure 1 =<< getBoxedClosureData atomicallyFrameCode
+ assertConstrClosure 2 =<< getBoxedClosureData result
e -> error $ "Wrong closure type: " ++ show e
-- TODO: Test for UnderflowFrame once it points to a Box payload
- traceM "test any_ret_small_prim_frame#"
- test any_ret_small_prim_frame# 50## $
+ test any_ret_small_prim_frame# $
\case
RetSmall {..} -> do
assertEqual knownRetSmallType RetN
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 1
- assertUnknownTypeWordSizedPrimitive 50 (head pCs)
+ assertUnknownTypeWordSizedPrimitive 1 (head pCs)
e -> error $ "Wrong closure type: " ++ show e
- traceM "test any_ret_small_closure_frame#"
- test any_ret_small_closure_frame# 51## $
+ test any_ret_small_closure_frame# $
\case
RetSmall {..} -> do
assertEqual knownRetSmallType RetP
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 1
- assertConstrClosure 51 (head pCs)
+ assertConstrClosure 1 (head pCs)
e -> error $ "Wrong closure type: " ++ show e
- traceM "test any_ret_small_closures_frame#"
- test any_ret_small_closures_frame# 1## $
+ test any_ret_small_closures_frame# $
\case
RetSmall {..} -> do
assertEqual knownRetSmallType None
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) (fromIntegral maxSmallBitmapBits_c)
- assertConstrClosure 1 (head pCs)
- assertConstrClosure 58 (last pCs)
let wds = map getWordFromConstr01 pCs
assertEqual wds [1..58]
e -> error $ "Wrong closure type: " ++ show e
- traceM "test any_ret_small_prims_frame#"
- test any_ret_small_prims_frame# 1## $
+ test any_ret_small_prims_frame# $
\case
RetSmall {..} -> do
assertEqual knownRetSmallType None
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) (fromIntegral maxSmallBitmapBits_c)
- assertUnknownTypeWordSizedPrimitive 1 (head pCs)
- assertUnknownTypeWordSizedPrimitive 58 (last pCs)
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1..58]
e -> error $ "Wrong closure type: " ++ show e
- traceM "test any_ret_big_prim_frame#"
- test any_ret_big_prim_frame# 52## $
+ test any_ret_big_prims_min_frame# $
+ \case
+ RetBig {..} -> do
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 59
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ assertEqual wds [1..59]
+ e -> error $ "Wrong closure type: " ++ show e
+ test any_ret_big_prims_min_frame# $
\case
RetBig {..} -> do
pCs <- mapM getBoxedClosureData payload
assertEqual (length pCs) 59
- assertUnknownTypeWordSizedPrimitive 52 (head pCs)
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ assertEqual wds [1..59]
e -> error $ "Wrong closure type: " ++ show e
+ test any_ret_big_closures_min_frame# $
+ \case
+ RetBig {..} -> do
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 59
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1..59]
+ e -> error $ "Wrong closure type: " ++ show e
+ test any_ret_big_closures_two_words_frame# $
+ \case
+ RetBig {..} -> do
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 65
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1..65]
+ e -> error $ "Wrong closure type: " ++ show e
+ test any_ret_fun_arg_n_prim_framezh# $
+ \case
+ RetFun {..} -> do
+ assertEqual retFunType ARG_N
+ assertEqual retFunSize 1
+ assertFun01Closure 1 =<< getBoxedClosureData retFunFun
+ pCs <- mapM getBoxedClosureData retFunPayload
+ assertEqual (length pCs) 1
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ assertEqual wds [1]
+ e -> error $ "Wrong closure type: " ++ show e
+
+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'
+ where
+ assert :: StackSnapshot -> [Closure] -> IO ()
+ assert sn stack = do
+ assertStackInvariants sn stack
+ assertEqual (length stack) 2
+ assertThat
+ "Last frame is stop frame"
+ ( \case
+ StopFrame -> True
+ _ -> False
+ )
+ (last stack)
+ assertion $ head stack
-type SetupFunction = Word# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
-
-test :: HasCallStack => SetupFunction -> Word# -> (Closure -> IO ()) -> IO ()
-test setup w assertion = do
- sn <- getStackSnapshot setup w
- performGC
- stack <- decodeStack' sn
- assertStackInvariants sn stack
- assertEqual (length stack) 2
- assertThat
- "Last frame is stop frame"
- ( \case
- StopFrame -> True
- _ -> False
- )
- (last stack)
-
- assertion $ head stack
-
-getStackSnapshot :: SetupFunction -> Word# -> IO StackSnapshot
-getStackSnapshot action# w# = IO $ \s ->
- case action# w# s of (# s1, stack #) -> (# s1, StackSnapshot stack #)
+-- | Get a `StackSnapshot` from test setup
+--
+-- This function mostly resembles `cloneStack`. Though, it doesn't clone, but
+-- 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 #)
assertConstrClosure :: HasCallStack => Word -> Closure -> IO ()
assertConstrClosure w c = case c of
@@ -174,6 +245,14 @@ assertConstrClosure w c = case c of
assertEqual (null ptrArgs) True
e -> error $ "Wrong closure type: " ++ show e
+assertFun01Closure :: HasCallStack => Word -> Closure -> IO ()
+assertFun01Closure w c = case c of
+ FunClosure {..} -> do
+ assertEqual (tipe info) FUN_0_1
+ assertEqual dataArgs [w]
+ assertEqual (null ptrArgs) True
+ e -> error $ "Wrong closure type: " ++ show e
+
getWordFromConstr01 :: HasCallStack => Closure -> Word
getWordFromConstr01 c = case c of
ConstrClosure {..} -> head dataArgs
=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -26,11 +26,11 @@ void create_any_update_frame(Capability *cap, StgStack *stack, StgWord w) {
StgUpdateFrame *updF = (StgUpdateFrame *)stack->sp;
SET_HDR(updF, &stg_upd_frame_info, CCS_SYSTEM);
// StgInd and a BLACKHOLE have the same structure
- StgInd* blackhole = allocate(cap, sizeofW(StgInd));
+ StgInd *blackhole = allocate(cap, sizeofW(StgInd));
SET_HDR(blackhole, &test_fake_blackhole_info, CCS_SYSTEM);
StgClosure *payload = rts_mkWord(cap, w);
blackhole->indirectee = payload;
- updF->updatee = (StgClosure*) blackhole;
+ updF->updatee = (StgClosure *)blackhole;
}
void create_any_catch_frame(Capability *cap, StgStack *stack, StgWord w) {
@@ -114,49 +114,66 @@ void create_any_ret_small_prims_frame(Capability *cap, StgStack *stack,
}
}
-RTS_RET(test_big_ret_n);
-void create_any_ret_big_prim_frame(Capability *cap, StgStack *stack,
- StgWord w) {
+#define MIN_LARGE_BITMAP_BITS (MAX_SMALL_BITMAP_BITS + 1)
+
+RTS_RET(test_big_ret_min_n);
+void create_any_ret_big_prims_min_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
StgClosure *c = (StgClosure *)stack->sp;
- SET_HDR(c, &test_big_ret_n_info, CCS_SYSTEM);
- c->payload[0] = (StgClosure *)w;
- debugBelch("Yolo size %lu\n", GET_LARGE_BITMAP(get_itbl(c))->size);
- debugBelch("Yolo bitmap %lu\n", GET_LARGE_BITMAP(get_itbl(c))->bitmap[0]);
+ SET_HDR(c, &test_big_ret_min_n_info, CCS_SYSTEM);
+
+ for (int i = 0; i < MIN_LARGE_BITMAP_BITS; i++) {
+ c->payload[i] = (StgClosure *)w;
+ w++;
+ }
}
-void create_any_ret_big_prims_frame(Capability *cap, StgStack *stack,
- StgWord w) {
+RTS_RET(test_big_ret_min_p);
+void create_any_ret_big_closures_min_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
StgClosure *c = (StgClosure *)stack->sp;
- StgWord bitmapCount = 1;
- StgWord memSizeInfo = sizeofW(StgRetInfoTable);
- StgWord memSizeBitmap =
- sizeofW(StgLargeBitmap) + bitmapCount * sizeofW(StgWord);
- StgRetInfoTable *info = allocate(cap, memSizeInfo);
- memset(info, 0, WDS(memSizeInfo));
- StgLargeBitmap *largeBitmap = allocate(cap, memSizeBitmap);
- memset(largeBitmap, 0, WDS(memSizeBitmap));
- info->i.type = RET_BIG;
-#if !defined(TABLES_NEXT_TO_CODE)
- info->i.layout.large_bitmap =
- largeBitmap; /* pointer to large bitmap structure */
- SET_HDR(c, info, CCS_SYSTEM);
-#else
- info->i.layout.large_bitmap_offset =
- ((StgWord)largeBitmap) - ((StgWord)(info + 1));
- SET_HDR(c, (StgInfoTable *)info + 1, CCS_SYSTEM);
-#endif
- largeBitmap->size = 1;
- largeBitmap->bitmap[0] = 1;
- StgClosure *payload = UNTAG_CLOSURE(rts_mkWord(cap, w));
- c->payload[0] = (StgClosure *)w;
+ SET_HDR(c, &test_big_ret_min_p_info, CCS_SYSTEM);
+
+ for (int i = 0; i < MIN_LARGE_BITMAP_BITS; i++) {
+ c->payload[i] = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ w++;
+ }
+}
- debugBelch("Yooo itbl : %us\n", get_itbl(c)->type);
- debugBelch("Yooo bitmap size : %ul\n", GET_LARGE_BITMAP(get_itbl(c))->size);
+#define TWO_WORDS_LARGE_BITMAP_BITS (BITS_IN(W_) + 1)
+
+RTS_RET(test_big_ret_two_words_p);
+void create_any_ret_big_closures_two_words_frame(Capability *cap,
+ StgStack *stack, StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &test_big_ret_two_words_p_info, CCS_SYSTEM);
+
+ for (int i = 0; i < TWO_WORDS_LARGE_BITMAP_BITS; i++) {
+ c->payload[i] = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ w++;
+ }
+}
+
+RTS_RET(test_ret_fun);
+RTS_RET(test_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)
+ 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]);
+ // The cast is a lie (w is interpreted as plain Word, not as pointer), but the
+ // memory layout fits.
+ c->payload[0] = (StgClosure *)w;
+ f->payload[0] = (StgClosure *)w;
printStack(stack);
}
-void checkSTACK (StgStack *stack);
-StgStack *setup(Capability *cap, StgWord closureSizeWords, StgWord w,
+void checkSTACK(StgStack *stack);
+StgStack *setup(Capability *cap, StgWord closureSizeWords,
void (*f)(Capability *, StgStack *, StgWord)) {
StgWord totalSizeWords =
sizeofW(StgStack) + closureSizeWords + MIN_STACK_WORDS;
@@ -173,68 +190,79 @@ StgStack *setup(Capability *cap, StgWord closureSizeWords, StgWord w,
SET_HDR((StgClosure *)stack->sp, &stg_stop_thread_info, CCS_SYSTEM);
stack->sp -= closureSizeWords;
- f(cap, stack, w);
+ // Pointers can easÃly be confused with each other. Provide a start value for
+ // values (1) in closures and increment it after every usage. The goal is to
+ // have distinct values in the closure to ensure nothing gets mixed up.
+ f(cap, stack, 1);
checkSTACK(stack);
return stack;
}
-StgStack *any_update_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgUpdateFrame), w, &create_any_update_frame);
+StgStack *any_update_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgUpdateFrame), &create_any_update_frame);
}
-StgStack *any_catch_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgCatchFrame), w, &create_any_catch_frame);
+StgStack *any_catch_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgCatchFrame), &create_any_catch_frame);
}
-StgStack *any_catch_stm_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgCatchSTMFrame), w, &create_any_catch_stm_frame);
+StgStack *any_catch_stm_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgCatchSTMFrame), &create_any_catch_stm_frame);
}
-StgStack *any_catch_retry_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgCatchRetryFrame), w, &create_any_catch_retry_frame);
+StgStack *any_catch_retry_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgCatchRetryFrame), &create_any_catch_retry_frame);
}
-StgStack *any_atomically_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgAtomicallyFrame), w, &create_any_atomically_frame);
+StgStack *any_atomically_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgAtomicallyFrame), &create_any_atomically_frame);
}
-StgStack *any_ret_small_prim_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgClosure) + sizeofW(StgWord), w,
+StgStack *any_ret_small_prim_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgClosure) + sizeofW(StgWord),
&create_any_ret_small_prim_frame);
}
-StgStack *any_ret_small_closure_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgClosure) + sizeofW(StgClosurePtr), w,
+StgStack *any_ret_small_closure_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgClosure) + sizeofW(StgClosurePtr),
&create_any_ret_small_closure_frame);
}
-StgStack *any_ret_small_closures_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgClosure) +
- MAX_SMALL_BITMAP_BITS * sizeofW(StgClosurePtr),
- w, &create_any_ret_small_closures_frame);
+StgStack *any_ret_small_closures_frame(Capability *cap) {
+ return setup(
+ cap, sizeofW(StgClosure) + MAX_SMALL_BITMAP_BITS * sizeofW(StgClosurePtr),
+ &create_any_ret_small_closures_frame);
+}
+
+StgStack *any_ret_small_prims_frame(Capability *cap) {
+ return setup(cap,
+ sizeofW(StgClosure) + MAX_SMALL_BITMAP_BITS * sizeofW(StgWord),
+ &create_any_ret_small_prims_frame);
}
-StgStack *any_ret_small_prims_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgClosure) +
- MAX_SMALL_BITMAP_BITS * sizeofW(StgWord),
- w, &create_any_ret_small_prims_frame);
+StgStack *any_ret_big_closures_min_frame(Capability *cap) {
+ return setup(
+ cap, sizeofW(StgClosure) + MIN_LARGE_BITMAP_BITS * sizeofW(StgClosure),
+ &create_any_ret_big_closures_min_frame);
}
-StgStack *any_ret_big_closures_frame(Capability *cap, StgWord w) {
- return NULL; // TODO: Implement
- // return setup(sizeofW(StgClosure) + sizeofW(StgClosurePtr), w,
- // &create_any_ret_closures_closure_frame);
+StgStack *any_ret_big_closures_two_words_frame(Capability *cap) {
+ return setup(cap,
+ sizeofW(StgClosure) +
+ TWO_WORDS_LARGE_BITMAP_BITS * sizeofW(StgClosure),
+ &create_any_ret_big_closures_two_words_frame);
}
-StgStack *any_ret_big_prim_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgClosure) + 59 * sizeofW(StgWord), w,
- &create_any_ret_big_prim_frame);
+StgStack *any_ret_big_prims_min_frame(Capability *cap) {
+ return setup(cap,
+ sizeofW(StgClosure) + MIN_LARGE_BITMAP_BITS * sizeofW(StgWord),
+ &create_any_ret_big_prims_min_frame);
}
-StgStack *any_ret_big_prims_frame(Capability *cap, StgWord w) {
- return setup(cap, sizeofW(StgClosure) + sizeofW(StgWord), w,
- &create_any_ret_big_prims_frame);
+StgStack *any_ret_fun_arg_n_prim_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgRetFun) + sizeofW(StgWord),
+ &create_any_ret_fun_arg_n_prim_frame);
}
void belchStack(StgStack *stack) { printStack(stack); }
=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -1,77 +1,84 @@
#include "Cmm.h"
-any_update_framezh(W_ w){
+any_update_framezh() {
P_ stack;
- ("ptr" stack) = ccall any_update_frame(MyCapability() "ptr", w);
+ ("ptr" stack) = ccall any_update_frame(MyCapability() "ptr");
return (stack);
}
-any_catch_framezh(W_ w){
+any_catch_framezh() {
P_ stack;
- (stack) = ccall any_catch_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_catch_frame(MyCapability() "ptr");
return (stack);
}
-any_catch_stm_framezh(W_ w){
+any_catch_stm_framezh() {
P_ stack;
- (stack) = ccall any_catch_stm_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_catch_stm_frame(MyCapability() "ptr");
return (stack);
}
-any_catch_retry_framezh(W_ w){
+any_catch_retry_framezh() {
P_ stack;
- (stack) = ccall any_catch_retry_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_catch_retry_frame(MyCapability() "ptr");
return (stack);
}
-any_atomically_framezh(W_ w){
+any_atomically_framezh() {
P_ stack;
- (stack) = ccall any_atomically_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_atomically_frame(MyCapability() "ptr");
return (stack);
}
-any_ret_small_prim_framezh(W_ w){
+any_ret_small_prim_framezh() {
P_ stack;
- (stack) = ccall any_ret_small_prim_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_ret_small_prim_frame(MyCapability() "ptr");
return (stack);
}
-any_ret_small_prims_framezh(W_ w){
+any_ret_small_prims_framezh() {
P_ stack;
- (stack) = ccall any_ret_small_prims_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_ret_small_prims_frame(MyCapability() "ptr");
return (stack);
}
-any_ret_small_closure_framezh(W_ w){
+any_ret_small_closure_framezh() {
P_ stack;
- (stack) = ccall any_ret_small_closure_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_ret_small_closure_frame(MyCapability() "ptr");
return (stack);
}
-any_ret_small_closures_framezh(W_ w){
+any_ret_small_closures_framezh() {
P_ stack;
- (stack) = ccall any_ret_small_closures_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_ret_small_closures_frame(MyCapability() "ptr");
return (stack);
}
-any_ret_big_prims_framezh(W_ w){
+any_ret_big_prims_min_framezh() {
P_ stack;
- (stack) = ccall any_ret_big_prims_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_ret_big_prims_min_frame(MyCapability() "ptr");
return (stack);
}
-any_ret_big_prim_framezh(W_ w){
+any_ret_big_closures_min_framezh() {
P_ stack;
- (stack) = ccall any_ret_big_prim_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_ret_big_closures_min_frame(MyCapability() "ptr");
return (stack);
}
-any_ret_big_closures_framezh(W_ w){
+any_ret_big_closures_two_words_framezh() {
P_ stack;
- (stack) = ccall any_ret_big_closures_frame(MyCapability() "ptr", w);
+ (stack) = ccall any_ret_big_closures_two_words_frame(MyCapability() "ptr");
return (stack);
}
+any_ret_fun_arg_n_prim_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_fun_arg_n_prim_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,
@@ -112,21 +119,84 @@ W_ n51, W_ n52, W_ n53, W_ n54, W_ n55, W_ n56, W_ n57, W_ n58
return ();
}
-INFO_TABLE_RET ( test_big_ret_n, RET_BIG, W_ info_ptr,
+// Size of this large bitmap closure is: max size of small bitmap + 1
+INFO_TABLE_RET ( test_big_ret_min_n, RET_BIG, W_ info_ptr,
+#if SIZEOF_VOID_P == 4
+W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10,
+W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20,
+W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27, W_ n28
+#elif SIZEOF_VOID_P == 8
W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10,
W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20,
W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27, W_ n28, W_ n29, W_ n30,
W_ n31, W_ n32, W_ n33, W_ n34, W_ n35, W_ n36, W_ n37, W_ n38, W_ n39, W_ n40,
W_ n41, W_ n42, W_ n43, W_ n44, W_ n45, W_ n46, W_ n47, W_ n48, W_ n49, W_ n50,
W_ n51, W_ n52, W_ n53, W_ n54, W_ n55, W_ n56, W_ n57, W_ n58, W_ n59
+#endif
+)
+ return (/* no return values */)
+{
+ return ();
+}
+
+// Size of this large bitmap closure is: max size of small bitmap + 1
+INFO_TABLE_RET ( test_big_ret_min_p, RET_BIG, W_ info_ptr,
+#if SIZEOF_VOID_P == 4
+P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10,
+P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20,
+P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28
+#elif SIZEOF_VOID_P == 8
+P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10,
+P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20,
+P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30,
+P_ p31, P_ p32, P_ p33, P_ p34, P_ p35, P_ p36, P_ p37, P_ p38, P_ p39, P_ p40,
+P_ p41, P_ p42, P_ p43, P_ p44, P_ p45, P_ p46, P_ p47, P_ p48, P_ p49, P_ p50,
+P_ p51, P_ p52, P_ p53, P_ p54, P_ p55, P_ p56, P_ p57, P_ p58, P_ p59
+#endif
)
return (/* no return values */)
{
return ();
}
+// Size of this large bitmap closure is: max size of bits in word + 1
+// This results in a two word StgLargeBitmap.
+INFO_TABLE_RET ( test_big_ret_two_words_p, RET_BIG, W_ info_ptr,
+#if SIZEOF_VOID_P == 4
+P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10,
+P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20,
+P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30,
+P_ p31, P_ p32, P_ p33
+#elif SIZEOF_VOID_P == 8
+P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10,
+P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20,
+P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30,
+P_ p31, P_ p32, P_ p33, P_ p34, P_ p35, P_ p36, P_ p37, P_ p38, P_ p39, P_ p40,
+P_ p41, P_ p42, P_ p43, P_ p44, P_ p45, P_ p46, P_ p47, P_ p48, P_ p49, P_ p50,
+P_ p51, P_ p52, P_ p53, P_ p54, P_ p55, P_ p56, P_ p57, P_ p58, P_ p59, P_ p60,
+P_ p61, P_ p62, P_ p63, P_ p64, P_ p65
+#endif
+)
+ return (/* no return values */)
+{
+ return ();
+}
+
+// A BLACKHOLE without any code. Just a placeholder to keep the GC happy.
INFO_TABLE(test_fake_blackhole,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
(P_ node)
{
return ();
}
+
+INFO_TABLE_RET ( test_ret_fun, RET_FUN, W_ info_ptr, W_ size, P_ fun, P_ payload)
+ return (/* no return values */)
+{
+ return ();
+}
+
+INFO_TABLE_FUN ( test_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
=====================================
@@ -739,7 +739,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
default:
- printSmallBitmap(spBottom, sp+2,
+ // 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]));
break;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/17902c75c8bb069ae63a80ed33d7cfb9708abcf1...f4b3f2518394f338eb512596946336d12a75d8bc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/17902c75c8bb069ae63a80ed33d7cfb9708abcf1...f4b3f2518394f338eb512596946336d12a75d8bc
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/20221230/135dc43e/attachment-0001.html>
More information about the ghc-commits
mailing list