[Git][ghc/ghc][wip/decode_cloned_stack] 4 commits: Test StgAtomicallyFrame
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Mon Dec 26 16:37:21 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
563a6480 by Sven Tennie at 2022-12-26T09:17:54+00:00
Test StgAtomicallyFrame
- - - - -
22f4b6b0 by Sven Tennie at 2022-12-26T10:21:32+00:00
Test RetSmall
- - - - -
3748200d by Sven Tennie at 2022-12-26T10:39:52+00:00
Test RetSmall 2
- - - - -
5a5017b3 by Sven Tennie at 2022-12-26T16:36:52+00:00
Start testing BigRet
- - - - -
4 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- 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
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -103,7 +103,7 @@ toBitmapEntries sfi@(StackFrameIter(# s, i #)) bitmap bSize = BitmapEntry {
} : toBitmapEntries (StackFrameIter (# s , plusWord# i 1## #)) (bitmap `shiftR` 1) (bSize - 1)
toBitmapPayload :: BitmapEntry -> IO Box
-toBitmapPayload e | isPrimitive e = pure $ asBox . CL.UnknownTypeWordSizedPrimitive . toWord . closureFrame $ e
+toBitmapPayload e | isPrimitive e = pure $ DecodedClosureBox. CL.UnknownTypeWordSizedPrimitive . toWord . closureFrame $ e
where
toWord (StackFrameIter (# s#, i# #)) = W# (derefStackWord# s# i#)
toBitmapPayload e = toClosure unpackClosureFromStackFrame# (closureFrame e)
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -20,6 +20,7 @@ import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack (StackSnapshot (..))
import TestUtils
import Unsafe.Coerce (unsafeCoerce)
+import GHC.Exts.Heap (GenClosure(wordVal))
foreign import prim "any_update_framezh" any_update_frame# :: Word# -> (# StackSnapshot# #)
@@ -29,6 +30,16 @@ foreign import prim "any_catch_stm_framezh" any_catch_stm_frame# :: Word# -> (#
foreign import prim "any_catch_retry_framezh" any_catch_retry_frame# :: Word# -> (# StackSnapshot# #)
+foreign import prim "any_atomically_framezh" any_atomically_frame# :: Word# -> (# StackSnapshot# #)
+
+foreign import prim "any_ret_small_prim_framezh" any_ret_small_prim_frame# :: Word# -> (# StackSnapshot# #)
+
+foreign import prim "any_ret_small_closure_framezh" any_ret_small_closure_frame# :: Word# -> (# StackSnapshot# #)
+
+foreign import prim "any_ret_big_prims_framezh" any_ret_big_prims_frame# :: Word# -> (# StackSnapshot# #)
+
+foreign import prim "any_ret_big_closures_framezh" any_ret_big_closures_frame# :: Word# -> (# StackSnapshot# #)
+
main :: HasCallStack => IO ()
main = do
test any_update_frame# 42## $
@@ -56,6 +67,36 @@ main = do
assertConstrClosure 46 =<< getBoxedClosureData first_code
assertConstrClosure 47 =<< getBoxedClosureData alt_code
e -> error $ "Wrong closure type: " ++ show e
+ test any_atomically_frame# 48## $
+ \case
+ AtomicallyFrame {..} -> do
+ assertConstrClosure 48 =<< getBoxedClosureData atomicallyFrameCode
+ assertConstrClosure 49 =<< getBoxedClosureData result
+ e -> error $ "Wrong closure type: " ++ show e
+ -- TODO: Test for UnderflowFrame once it points to a Box payload
+ test any_ret_small_prim_frame# 50## $
+ \case
+ RetSmall {..} -> do
+ assertEqual knownRetSmallType RetN
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 1
+ assertUnknownTypeWordSizedPrimitive 50 (head pCs)
+ e -> error $ "Wrong closure type: " ++ show e
+ test any_ret_small_closure_frame# 51## $
+ \case
+ RetSmall {..} -> do
+ assertEqual knownRetSmallType RetP
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 1
+ assertConstrClosure 51 (head pCs)
+ e -> error $ "Wrong closure type: " ++ show e
+ test any_ret_big_prims_frame# 52## $
+ \case
+ RetBig {..} -> do
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 1
+ assertUnknownTypeWordSizedPrimitive 52 (head pCs)
+ e -> error $ "Wrong closure type: " ++ show e
test :: HasCallStack => (Word# -> (# StackSnapshot# #)) -> Word# -> (Closure -> IO ()) -> IO ()
test setup w assertion = do
@@ -81,5 +122,11 @@ assertConstrClosure w c = case c of
assertEqual (null ptrArgs) True
e -> error $ "Wrong closure type: " ++ show e
+assertUnknownTypeWordSizedPrimitive :: HasCallStack => Word -> Closure -> IO ()
+assertUnknownTypeWordSizedPrimitive w c = case c of
+ UnknownTypeWordSizedPrimitive {..} -> do
+ assertEqual wordVal w
+ e -> error $ "Wrong closure type: " ++ show e
+
unboxSingletonTuple :: (# StackSnapshot# #) -> StackSnapshot#
unboxSingletonTuple (# s# #) = s#
=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -5,9 +5,9 @@
#include "rts/Types.h"
#include "rts/storage/ClosureMacros.h"
#include "rts/storage/Closures.h"
+#include "rts/storage/InfoTables.h"
#include "rts/storage/TSO.h"
#include "stg/Types.h"
-#include <stdlib.h>
extern void printStack(StgStack *stack);
@@ -43,6 +43,7 @@ void create_any_catch_stm_frame(Capability *cap, StgStack *stack, StgWord w) {
catchF->handler = payload2;
}
+// TODO: Use `w` for running_alt_code, too.
void create_any_catch_retry_frame(Capability *cap, StgStack *stack, StgWord w) {
StgCatchRetryFrame *catchRF = (StgCatchRetryFrame *)stack->sp;
SET_HDR(catchRF, &stg_catch_retry_frame_info, CCS_SYSTEM);
@@ -53,6 +54,60 @@ void create_any_catch_retry_frame(Capability *cap, StgStack *stack, StgWord w) {
catchRF->alt_code = payload2;
}
+void create_any_atomically_frame(Capability *cap, StgStack *stack, StgWord w) {
+ StgAtomicallyFrame *aF = (StgAtomicallyFrame *)stack->sp;
+ SET_HDR(aF, &stg_atomically_frame_info, CCS_SYSTEM);
+ StgClosure *payload1 = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ StgClosure *payload2 = UNTAG_CLOSURE(rts_mkWord(cap, w + 1));
+ aF->code = payload1;
+ aF->result = payload2;
+}
+
+void create_any_ret_small_prim_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &stg_ret_n_info, CCS_SYSTEM);
+ // The cast is a lie (w is interpreted as plain Word, not as pointer), but the
+ // memory layout fits.
+ c->payload[0] = (StgClosure *)w;
+}
+
+void create_any_ret_small_closure_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &stg_ret_p_info, CCS_SYSTEM);
+ StgClosure *payload = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ c->payload[0] = payload;
+}
+
+void create_any_ret_big_prims_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;
+
+ debugBelch("Yooo itbl : %us\n", get_itbl(c)->type);
+ debugBelch("Yooo bitmap size : %ul\n", GET_LARGE_BITMAP(get_itbl(c))->size);
+ printStack(stack);
+}
+
StgStack *setup(StgWord closureSizeWords, StgWord w,
void (*f)(Capability *, StgStack *, StgWord)) {
Capability *cap = rts_lock();
@@ -92,3 +147,28 @@ StgStack *any_catch_stm_frame(StgWord w) {
StgStack *any_catch_retry_frame(StgWord w) {
return setup(sizeofW(StgCatchRetryFrame), w, &create_any_catch_retry_frame);
}
+
+StgStack *any_atomically_frame(StgWord w) {
+ return setup(sizeofW(StgAtomicallyFrame), w, &create_any_atomically_frame);
+}
+
+StgStack *any_ret_small_prim_frame(StgWord w) {
+ return setup(sizeofW(StgClosure) + sizeofW(StgWord), w,
+ &create_any_ret_small_prim_frame);
+}
+
+StgStack *any_ret_small_closure_frame(StgWord w) {
+ return setup(sizeofW(StgClosure) + sizeofW(StgClosurePtr), w,
+ &create_any_ret_small_closure_frame);
+}
+
+StgStack *any_ret_big_closures_frame(StgWord w) {
+ return NULL; // TODO: Implement
+ // return setup(sizeofW(StgClosure) + sizeofW(StgClosurePtr), w,
+ // &create_any_ret_closures_closure_frame);
+}
+
+StgStack *any_ret_big_prims_frame(StgWord w) {
+ return setup(sizeofW(StgClosure) + sizeofW(StgWord), w,
+ &create_any_ret_big_prims_frame);
+}
=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -23,3 +23,33 @@ any_catch_retry_framezh(W_ w){
(stack) = ccall any_catch_retry_frame(w);
return (stack);
}
+
+any_atomically_framezh(W_ w){
+ P_ stack;
+ (stack) = ccall any_atomically_frame(w);
+ return (stack);
+}
+
+any_ret_small_prim_framezh(W_ w){
+ P_ stack;
+ (stack) = ccall any_ret_small_prim_frame(w);
+ return (stack);
+}
+
+any_ret_small_closure_framezh(W_ w){
+ P_ stack;
+ (stack) = ccall any_ret_small_closure_frame(w);
+ return (stack);
+}
+
+any_ret_big_prims_framezh(W_ w){
+ P_ stack;
+ (stack) = ccall any_ret_big_prims_frame(w);
+ return (stack);
+}
+
+any_ret_big_closures_framezh(W_ w){
+ P_ stack;
+ (stack) = ccall any_ret_big_closures_frame(w);
+ return (stack);
+}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e4b9bfbd5a08604717eb16cdd66c215627bbef34...5a5017b38e147012ee1dba46954d67437c2bd21d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e4b9bfbd5a08604717eb16cdd66c215627bbef34...5a5017b38e147012ee1dba46954d67437c2bd21d
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/20221226/9138aaa4/attachment-0001.html>
More information about the ghc-commits
mailing list