[Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: Test StgCatchSTMFrame
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Dec 25 19:26:29 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
4974c9c8 by Sven Tennie at 2022-12-25T18:55:10+00:00
Test StgCatchSTMFrame
- - - - -
e4b9bfbd by Sven Tennie at 2022-12-25T19:26:08+00:00
Test StgCatchRetryFrame
- - - - -
6 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/StackConstants.hsc
- 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
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -207,7 +207,7 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) = trace ("decoding ... "
CATCH_RETRY_FRAME -> do
let running_alt_code' = getWord sfi offsetStgCatchRetryFrameRunningAltCode
first_code' <- getClosure sfi offsetStgCatchRetryFrameRunningFirstCode
- alt_code' <- getClosure sfi offsetStgCatchRetryFrameRunningAltCode
+ alt_code' <- getClosure sfi offsetStgCatchRetryFrameAltCode
pure $ CL.CatchRetryFrame running_alt_code' first_code' alt_code'
CATCH_STM_FRAME -> CL.CatchStmFrame
<$> getClosure sfi offsetStgCatchSTMFrameCode
=====================================
libraries/ghc-heap/GHC/Exts/StackConstants.hsc
=====================================
@@ -12,12 +12,12 @@ import Prelude
#undef BLOCKS_PER_MBLOCK
#include "DerivedConstants.h"
-offsetStgCatchSTMFrameCode :: Int
-offsetStgCatchSTMFrameCode = (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
-
offsetStgCatchFrameHandler :: Int
offsetStgCatchFrameHandler = (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
+offsetStgCatchSTMFrameCode :: Int
+offsetStgCatchSTMFrameCode = (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
+
offsetStgCatchSTMFrameHandler :: Int
offsetStgCatchSTMFrameHandler = (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
=====================================
libraries/ghc-heap/tests/stack_lib.c
=====================================
@@ -3,6 +3,7 @@
#include "rts/Messages.h"
#include "rts/Types.h"
#include "rts/storage/ClosureMacros.h"
+#include "rts/storage/ClosureTypes.h"
#include "rts/storage/Closures.h"
#include "stg/Types.h"
#include <stdlib.h>
@@ -123,6 +124,12 @@ ClosureTypeList *foldStackToList(StgStack *stack) {
result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->handler))->type);
continue;
}
+ case CATCH_RETRY_FRAME: {
+ StgCatchRetryFrame *f = (StgCatchRetryFrame *)sp;
+ result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->first_code))->type);
+ result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->alt_code))->type);
+ continue;
+ }
case STOP_FRAME: {
continue;
}
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -25,6 +25,10 @@ foreign import prim "any_update_framezh" any_update_frame# :: Word# -> (# StackS
foreign import prim "any_catch_framezh" any_catch_frame# :: Word# -> (# StackSnapshot# #)
+foreign import prim "any_catch_stm_framezh" any_catch_stm_frame# :: Word# -> (# StackSnapshot# #)
+
+foreign import prim "any_catch_retry_framezh" any_catch_retry_frame# :: Word# -> (# StackSnapshot# #)
+
main :: HasCallStack => IO ()
main = do
test any_update_frame# 42## $
@@ -39,6 +43,19 @@ main = do
assertEqual exceptions_blocked 1
assertConstrClosure 43 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
+ test any_catch_stm_frame# 44## $
+ \case
+ CatchStmFrame {..} -> do
+ assertConstrClosure 44 =<< getBoxedClosureData catchFrameCode
+ assertConstrClosure 45 =<< getBoxedClosureData handler
+ e -> error $ "Wrong closure type: " ++ show e
+ test any_catch_retry_frame# 46## $
+ \case
+ CatchRetryFrame {..} -> do
+ assertEqual running_alt_code 1
+ assertConstrClosure 46 =<< getBoxedClosureData first_code
+ assertConstrClosure 47 =<< getBoxedClosureData alt_code
+ e -> error $ "Wrong closure type: " ++ show e
test :: HasCallStack => (Word# -> (# StackSnapshot# #)) -> Word# -> (Closure -> IO ()) -> IO ()
test setup w assertion = do
@@ -56,7 +73,7 @@ test setup w assertion = do
assertion $ head stack
-assertConstrClosure :: Word -> Closure -> IO ()
+assertConstrClosure :: HasCallStack => Word -> Closure -> IO ()
assertConstrClosure w c = case c of
ConstrClosure {..} -> do
assertEqual (tipe info) CONSTR_0_1
=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -18,6 +18,7 @@ extern void printStack(StgStack *stack);
#define SIZEOF_W SIZEOF_VOID_P
#define WDS(n) ((n)*SIZEOF_W)
+// TODO: Try to remove UNTAG_CLOSURE. This should happen in the decoding logic.
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);
@@ -33,6 +34,25 @@ void create_any_catch_frame(Capability *cap, StgStack *stack, StgWord w) {
catchF->handler = payload;
}
+void create_any_catch_stm_frame(Capability *cap, StgStack *stack, StgWord w) {
+ StgCatchSTMFrame *catchF = (StgCatchSTMFrame *)stack->sp;
+ SET_HDR(catchF, &stg_catch_stm_frame_info, CCS_SYSTEM);
+ StgClosure *payload1 = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ StgClosure *payload2 = UNTAG_CLOSURE(rts_mkWord(cap, w + 1));
+ catchF->code = payload1;
+ catchF->handler = payload2;
+}
+
+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);
+ StgClosure *payload1 = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ StgClosure *payload2 = UNTAG_CLOSURE(rts_mkWord(cap, w + 1));
+ catchRF->running_alt_code = 1;
+ catchRF->first_code = payload1;
+ catchRF->alt_code = payload2;
+}
+
StgStack *setup(StgWord closureSizeWords, StgWord w,
void (*f)(Capability *, StgStack *, StgWord)) {
Capability *cap = rts_lock();
@@ -64,3 +84,11 @@ StgStack *any_update_frame(StgWord w) {
StgStack *any_catch_frame(StgWord w) {
return setup(sizeofW(StgCatchFrame), w, &create_any_catch_frame);
}
+
+StgStack *any_catch_stm_frame(StgWord w) {
+ return setup(sizeofW(StgCatchSTMFrame), w, &create_any_catch_stm_frame);
+}
+
+StgStack *any_catch_retry_frame(StgWord w) {
+ return setup(sizeofW(StgCatchRetryFrame), w, &create_any_catch_retry_frame);
+}
=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -11,3 +11,15 @@ any_catch_framezh(W_ w){
(stack) = ccall any_catch_frame(w);
return (stack);
}
+
+any_catch_stm_framezh(W_ w){
+ P_ stack;
+ (stack) = ccall any_catch_stm_frame(w);
+ return (stack);
+}
+
+any_catch_retry_framezh(W_ w){
+ P_ stack;
+ (stack) = ccall any_catch_retry_frame(w);
+ return (stack);
+}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a57759a4dcb586798ac48193dd9aae96f811e424...e4b9bfbd5a08604717eb16cdd66c215627bbef34
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a57759a4dcb586798ac48193dd9aae96f811e424...e4b9bfbd5a08604717eb16cdd66c215627bbef34
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/5078570f/attachment-0001.html>
More information about the ghc-commits
mailing list