[Git][ghc/ghc][wip/decode_cloned_stack] Test StgCatchFrame

[Sven Tennie (@supersven)]

Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC


Commits:
a57759a4 by Sven Tennie at 2022-12-25T18:38:45+00:00
Test StgCatchFrame

- - - - -


3 changed files:

- 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/tests/stack_misc_closures.hs
=====================================
@@ -16,33 +16,36 @@ import GHC.Exts
 import GHC.Exts.DecodeStack
 import GHC.Exts.Heap
 import GHC.Exts.Heap.Closures
+import GHC.Stack (HasCallStack)
 import GHC.Stack.CloneStack (StackSnapshot (..))
 import TestUtils
 import Unsafe.Coerce (unsafeCoerce)
-import GHC.Stack (HasCallStack)
 
 foreign import prim "any_update_framezh" any_update_frame# :: Word# -> (# StackSnapshot# #)
 
+foreign import prim "any_catch_framezh" any_catch_frame# :: Word# -> (# StackSnapshot# #)
+
 main :: HasCallStack => IO ()
 main = do
-  let sn = StackSnapshot (unboxSingletonTuple (any_update_frame# 42##))
+  test any_update_frame# 42## $
+    \case
+      UpdateFrame {..} -> do
+        assertEqual knownUpdateFrameType NormalUpdateFrame
+        assertConstrClosure 42 =<< getBoxedClosureData updatee
+      e -> error $ "Wrong closure type: " ++ show e
+  test any_catch_frame# 43## $
+    \case
+      CatchFrame {..} -> do
+        assertEqual exceptions_blocked 1
+        assertConstrClosure 43 =<< getBoxedClosureData handler
+      e -> error $ "Wrong closure type: " ++ show e
+
+test :: HasCallStack => (Word# -> (# StackSnapshot# #)) -> Word# -> (Closure -> IO ()) -> IO ()
+test setup w assertion = do
+  let sn = StackSnapshot (unboxSingletonTuple (setup w))
   stack <- decodeStack' sn
   assertStackInvariants sn stack
   assertEqual (length stack) 2
-
-  let updateFrame = head stack
-  print $ "updateFrame : " ++ show updateFrame
-  case updateFrame of
-    UpdateFrame {..} -> do
-      assertEqual knownUpdateFrameType NormalUpdateFrame
-      u <- getBoxedClosureData updatee
-      case u of
-        ConstrClosure {..} -> do
-          assertEqual (tipe info) CONSTR_0_1
-          assertEqual dataArgs [42]
-          assertEqual (null ptrArgs) True
-        _ -> error $ "Wrong closure type: " ++ show u
-    _ -> error $ "Wrong closure type: " ++ show updateFrame
   assertThat
     "Last frame is stop frame"
     ( \case
@@ -51,5 +54,15 @@ main = do
     )
     (last stack)
 
+  assertion $ head stack
+
+assertConstrClosure :: Word -> Closure -> IO ()
+assertConstrClosure w c = case c of
+  ConstrClosure {..} -> do
+    assertEqual (tipe info) CONSTR_0_1
+    assertEqual dataArgs [w]
+    assertEqual (null ptrArgs) True
+  e -> error $ "Wrong closure type: " ++ show e
+
 unboxSingletonTuple :: (# StackSnapshot# #) -> StackSnapshot#
 unboxSingletonTuple (# s# #) = s#


=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -5,6 +5,7 @@
 #include "rts/Types.h"
 #include "rts/storage/ClosureMacros.h"
 #include "rts/storage/Closures.h"
+#include "rts/storage/TSO.h"
 #include "stg/Types.h"
 #include <stdlib.h>
 
@@ -17,14 +18,30 @@ extern void printStack(StgStack *stack);
 #define SIZEOF_W SIZEOF_VOID_P
 #define WDS(n) ((n)*SIZEOF_W)
 
-StgStack *any_update_frame() {
+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);
+  StgClosure *payload = UNTAG_CLOSURE(rts_mkWord(cap, w));
+  updF->updatee = payload;
+}
+
+void create_any_catch_frame(Capability *cap, StgStack *stack, StgWord w) {
+  StgCatchFrame *catchF = (StgCatchFrame *)stack->sp;
+  SET_HDR(catchF, &stg_catch_frame_info, CCS_SYSTEM);
+  StgClosure *payload = UNTAG_CLOSURE(rts_mkWord(cap, w));
+  catchF->exceptions_blocked = 1;
+  catchF->handler = payload;
+}
+
+StgStack *setup(StgWord closureSizeWords, StgWord w,
+                void (*f)(Capability *, StgStack *, StgWord)) {
   Capability *cap = rts_lock();
-  StgWord closureSizeWords =
-      sizeofW(StgStack) + sizeofW(StgUpdateFrame) + MIN_STACK_WORDS;
-  StgStack *stack = (StgStack *)allocate(cap, closureSizeWords);
-  StgWord closureSizeBytes = WDS(closureSizeWords);
+  StgWord totalSizeWords =
+      sizeofW(StgStack) + closureSizeWords + MIN_STACK_WORDS;
+  StgStack *stack = (StgStack *)allocate(cap, totalSizeWords);
+  StgWord totalSizeBytes = WDS(totalSizeWords);
   SET_HDR(stack, &stg_upd_frame_info, CCS_SYSTEM);
-  stack->stack_size = closureSizeBytes;
+  stack->stack_size = totalSizeBytes;
   stack->dirty = 0;
   stack->marking = 0;
 
@@ -32,13 +49,18 @@ StgStack *any_update_frame() {
   stack->sp = spBottom;
   stack->sp -= sizeofW(StgStopFrame);
   SET_HDR((StgClosure *)stack->sp, &stg_stop_thread_info, CCS_SYSTEM);
+  stack->sp -= closureSizeWords;
+
+  f(cap, stack, w);
 
-  stack->sp -= sizeofW(StgUpdateFrame);
-  StgUpdateFrame *updF = (StgUpdateFrame *)stack->sp;
-  SET_HDR(updF, &stg_upd_frame_info, CCS_SYSTEM);
-  StgClosure *payload = UNTAG_CLOSURE(rts_mkWord(cap, 42));
-  updF->updatee = payload;
   rts_unlock(cap);
-  printStack(stack);
   return stack;
 }
+
+StgStack *any_update_frame(StgWord w) {
+  return setup(sizeofW(StgUpdateFrame), w, &create_any_update_frame);
+}
+
+StgStack *any_catch_frame(StgWord w) {
+  return setup(sizeofW(StgCatchFrame), w, &create_any_catch_frame);
+}


=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -1,7 +1,13 @@
 #include "Cmm.h"
 
-any_update_framezh(){
+any_update_framezh(W_ w){
     P_ stack;
-    (stack) = ccall any_update_frame();
+    (stack) = ccall any_update_frame(w);
+    return (stack);
+}
+
+any_catch_framezh(W_ w){
+    P_ stack;
+    (stack) = ccall any_catch_frame(w);
     return (stack);
 }



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a57759a4dcb586798ac48193dd9aae96f811e424

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a57759a4dcb586798ac48193dd9aae96f811e424
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/20221225/37996d2e/attachment-0001.html>