[Git][ghc/ghc][wip/decode_cloned_stack] Save
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Tue Nov 1 08:15:09 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
453b2623 by Sven Tennie at 2022-11-01T08:14:55+00:00
Save
- - - - -
5 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/StackConstants.hsc
- libraries/ghc-heap/cbits/Stack.c
- libraries/ghc-heap/cbits/Stack.cmm
- utils/deriveConstants/Main.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -65,8 +65,12 @@ foreign import prim "getInfoTableTypezh" getInfoTableType# :: StackSnapshot# ->
foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
+foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
+
foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word#, Word# #)
+foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word# #)
+
data BitmapEntry = BitmapEntry {
closureFrame :: StackFrameIter,
isPrimitive :: Bool
@@ -132,7 +136,13 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
payloads = map toBitmapPayload bes
in
RetBig payloads
- RET_FUN -> RetFun
+ RET_FUN -> let
+ t = getRetFunType# s# i#
+ size = W# (getWord# s# i# (intToWord# offsetStgRetFunFrameSize))
+ fun = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgRetFunFrameFun)) sfi
+ payload :: [CL.Closure]
+ in
+ RetFun t size fun payload
-- TODO: Decode update frame type
UPDATE_FRAME -> let
c = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgUpdateFrameUpdatee)) sfi
@@ -141,6 +151,7 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
UpdateFrame t c
CATCH_FRAME -> let
c = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgCatchFrameHandler)) sfi
+ -- TODO: Replace with getWord# expression
exceptionsBlocked = W# (getCatchFrameExceptionsBlocked# s# i#)
in
CatchFrame exceptionsBlocked c
@@ -210,6 +221,8 @@ foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :
foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> Word#
+foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
+
data BitmapPayload = Closure CL.Closure | Primitive Word
instance Show BitmapPayload where
@@ -257,10 +270,42 @@ data StackFrame =
StopFrame |
RetSmall { knownRetSmallType :: SpecialRetSmall, payload :: [BitmapPayload]} |
RetBig { payload :: [BitmapPayload] } |
- RetFun |
+ RetFun { retFunType :: RetFunType, size :: Word, fun :: CL.Closure, payload :: [CL.Closure]} |
RetBCO
deriving (Show)
+data RetFunType =
+ ARG_GEN |
+ ARG_GEN_BIG |
+ ARG_BCO |
+ ARG_NONE |
+ ARG_N |
+ ARG_P |
+ ARG_F |
+ ARG_D |
+ ARG_L |
+ ARG_V16 |
+ ARG_V32 |
+ ARG_V64 |
+ ARG_NN |
+ ARG_NP |
+ ARG_PN |
+ ARG_PP |
+ ARG_NNN |
+ ARG_NNP |
+ ARG_NPN |
+ ARG_NPP |
+ ARG_PNN |
+ ARG_PNP |
+ ARG_PPN |
+ ARG_PPP |
+ ARG_PPPP |
+ ARG_PPPPP |
+ ARG_PPPPPP |
+ ARG_PPPPPPP |
+ ARG_PPPPPPPP
+ deriving (Show, Eq, Enum)
+
#if defined(DEBUG)
foreign import ccall "belchStack" belchStack# :: StackSnapshot# -> IO ()
=====================================
libraries/ghc-heap/GHC/Exts/StackConstants.hsc
=====================================
@@ -34,3 +34,12 @@ offsetStgCatchRetryFrameRunningFirstCode = (#const OFFSET_StgCatchRetryFrame_fir
offsetStgCatchRetryFrameAltCode :: Int
offsetStgCatchRetryFrameAltCode = (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
+
+offsetStgRetFunFrameSize :: Int
+offsetStgRetFunFrameSize = (#const OFFSET_StgRetFun_size) + (#size StgHeader)
+
+offsetStgRetFunFrameFun :: Int
+offsetStgRetFunFrameFun = (#const OFFSET_StgRetFun_fun) + (#size StgHeader)
+
+offsetStgRetFunFramePayload :: Int
+offsetStgRetFunFramePayload = (#const OFFSET_StgRetFun_payload) + (#size StgHeader)
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -6,19 +6,19 @@
#include "rts/storage/Closures.h"
#include "rts/storage/InfoTables.h"
-StgWord stackFrameSize(StgStack* stack, StgWord index){
- StgClosure* c = (StgClosure *) stack->sp + index;
+StgWord stackFrameSize(StgStack *stack, StgWord index) {
+ StgClosure *c = (StgClosure *)stack->sp + index;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
return stack_frame_sizeW(c);
}
-StgStack* getUnderflowFrameStack(StgStack* stack, StgWord index){
- StgClosure* frame = (StgClosure *) stack->sp + index;
+StgStack *getUnderflowFrameStack(StgStack *stack, StgWord index) {
+ StgClosure *frame = (StgClosure *)stack->sp + index;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));
- const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
+ const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
- if(info->i.type == UNDERFLOW_FRAME) {
- return ((StgUnderflowFrame*) frame)->next_chunk;
+ if (info->i.type == UNDERFLOW_FRAME) {
+ return ((StgUnderflowFrame *)frame)->next_chunk;
} else {
return NULL;
}
@@ -33,7 +33,7 @@ const StgInfoTable *getItbl(StgClosure *closure) {
StgWord getSpecialRetSmall(StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
- StgWord c = *(StgWord*)closure;
+ StgWord c = *(StgWord *)closure;
if (c == (StgWord)&stg_ap_v_info) {
return 1;
} else if (c == (StgWord)&stg_ap_f_info) {
@@ -79,35 +79,50 @@ StgWord getSpecialRetSmall(StgClosure *closure) {
}
}
-StgWord getUpdateFrameType(StgClosure* c) {
+StgWord getUpdateFrameType(StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- const StgInfoTable* info = c->header.info;
+ const StgInfoTable *info = c->header.info;
if (info == &stg_upd_frame_info) {
- return 0;
+ return 0;
} else if (info == &stg_bh_upd_frame_info) {
- return 1;
+ return 1;
} else if (info == &stg_marked_upd_frame_info) {
- return 2;
+ return 2;
} else {
// Cannot do more than warn and exit.
- errorBelch("Cannot decide Update Frame type for info table %p closure %p.", info, c);
+ errorBelch("Cannot decide Update Frame type for info table %p closure %p.",
+ info, c);
stg_exit(EXIT_INTERNAL_ERROR);
}
}
-StgWord getBitmapSize(StgClosure *c){
+StgWord getBitmapSize(StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- const StgInfoTable* info = get_itbl(c);
+ const StgInfoTable *info = get_itbl(c);
StgWord bitmap = info->layout.bitmap;
return BITMAP_SIZE(bitmap);
}
-StgWord getBitmapWord(StgClosure *c){
+StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ switch (fun_info->f.fun_type) {
+ case ARG_GEN:
+ return BITMAP_BITS(fun_info->f.b.bitmap),
+ case ARG_GEN_BIG:
+ return GET_FUN_LARGE_BITMAP(fun_info)->size;
+ default:
+ return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
+ }
+ }
+
+StgWord getBitmapWord(StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- const StgInfoTable* info = get_itbl(c);
+ const StgInfoTable *info = get_itbl(c);
StgWord bitmap = info->layout.bitmap;
// debugBelch("getBitmapWord - bitmap : %lu \n", bitmap);
StgWord bitmapWord = BITMAP_BITS(bitmap);
@@ -115,44 +130,86 @@ StgWord getBitmapWord(StgClosure *c){
return bitmapWord;
}
-StgWord getLargeBitmapSize(StgClosure *c){
+StgWord getRetFunBitmapWord(StgClosure *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ switch (fun_info->f.fun_type) {
+ case ARG_GEN:
+ return BITMAP_BITS(fun_info->f.b.bitmap);
+ case ARG_GEN_BIG:
+ // Cannot do more than warn and exit.
+ errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun);
+ stg_exit(EXIT_INTERNAL_ERROR);
+ default:
+ return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+ }
+}
+
+StgWord getLargeBitmapSize(StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- const StgInfoTable* info = get_itbl(c);
- StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
+ const StgInfoTable *info = get_itbl(c);
+ StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
return bitmap->size;
}
-#define ROUNDUP_BITS_TO_WDS(n) (((n) + WORD_SIZE_IN_BITS - 1) / WORD_SIZE_IN_BITS )
+#define ROUNDUP_BITS_TO_WDS(n) \
+ (((n) + WORD_SIZE_IN_BITS - 1) / WORD_SIZE_IN_BITS)
// Copied from Cmm.h
-#define SIZEOF_W SIZEOF_VOID_P
+#define SIZEOF_W SIZEOF_VOID_P
#define WDS(n) ((n)*SIZEOF_W)
-StgArrBytes* getLargeBitmaps(Capability *cap, StgClosure *c){
+StgArrBytes *getLargeBitmaps(Capability *cap, StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- const StgInfoTable* info = get_itbl(c);
- StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
+ const StgInfoTable *info = get_itbl(c);
+ StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
StgWord neededWords = ROUNDUP_BITS_TO_WDS(bitmap->size);
- StgArrBytes* array = (StgArrBytes *) allocate(cap, sizeofW(StgArrBytes) + neededWords);
+ StgArrBytes *array =
+ (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + neededWords);
SET_HDR(array, &stg_ARR_WORDS_info, CCCS);
array->bytes = WDS(ROUNDUP_BITS_TO_WDS(bitmap->size));
- for(int i = 0; i < neededWords; i++) {
+ for (int i = 0; i < neededWords; i++) {
array->payload[i] = bitmap->bitmap[i];
}
return array;
}
-#if defined(DEBUG)
-extern void printStack (StgStack *stack);
-void belchStack(StgStack* stack){
- printStack(stack);
+StgArrBytes *getRetFunLargeBitmaps(Capability *cap, StgRetFun *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);
+ StgWord neededWords = ROUNDUP_BITS_TO_WDS(bitmap->size);
+ StgArrBytes *array =
+ (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + neededWords);
+ SET_HDR(array, &stg_ARR_WORDS_info, CCCS);
+ array->bytes = WDS(ROUNDUP_BITS_TO_WDS(bitmap->size));
+
+ for (int i = 0; i < neededWords; i++) {
+ array->payload[i] = bitmap->bitmap[i];
+ }
+
+ return array;
}
+
+#if defined(DEBUG)
+extern void printStack(StgStack *stack);
+void belchStack(StgStack *stack) { printStack(stack); }
#endif
-StgStack* getUnderflowFrameNextChunk(StgUnderflowFrame* frame){
+StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {
return frame->next_chunk;
}
+
+StgWord getRetFunType(StgRetFun *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ return fun_info->f.fun_type;
+}
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -99,6 +99,18 @@ getSmallBitmapzh(P_ stack, W_ index) {
return (bitmap, size, specialType);
}
+getRetFunSmallBitmapzh(P_ stack, W_ index) {
+ P_ c;
+ c = StgStack_sp(stack) + WDS(index);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ bitmap, size, specialType;
+ (bitmap) = ccall getRetFunBitmapWord(c);
+ (size) = ccall getRetFunBitmapSize(c);
+
+ return (bitmap, size);
+}
+
getLargeBitmapzh(P_ stack, W_ index){
P_ c, stgArrBytes;
W_ size;
@@ -113,6 +125,18 @@ getLargeBitmapzh(P_ stack, W_ index){
return (stgArrBytes, size);
}
+getRetFunLargeBitmapzh(P_ stack, W_ index){
+ P_ c, stgArrBytes;
+ W_ size;
+ c = StgStack_sp(stack) + WDS(index);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ (stgArrBytes) = ccall getRetFunLargeBitmaps(MyCapability(), c);
+ (size) = ccall getRetFunSize(c);
+
+ return (stgArrBytes, size);
+}
+
// TODO: Use generalized version unpackClosureReferencedByFramezh with offset=0
unpackClosureFromStackFramezh(P_ stack, W_ index){
P_ closurePtr, closurePtrPrime;
@@ -167,3 +191,13 @@ getUnderflowFrameNextChunkzh(P_ stack, W_ index){
ASSERT(LOOKS_LIKE_CLOURE_PTR(next_chunk));
return (next_chunk);
}
+
+getRetFunTypezh(P_ stack, W_ index){
+ P_ c;
+ c = StgStack_sp(stack) + WDS(index);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ type;
+ (type) = ccall getRetFunType(c);
+ return (type);
+}
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -464,6 +464,10 @@ wanteds os = concat
,closureField C "StgCatchFrame" "handler"
,closureField C "StgCatchFrame" "exceptions_blocked"
+ ,closureField C "StgRetFun" "size"
+ ,closureField C "StgRetFun" "fun"
+ ,closureField C "StgRetFun" "payload"
+
,closureSize C "StgPAP"
,closureField C "StgPAP" "n_args"
,closureFieldGcptr C "StgPAP" "fun"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/453b2623e13aefe4193c03fc55793ac30de33e16
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/453b2623e13aefe4193c03fc55793ac30de33e16
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/20221101/875e0fdc/attachment-0001.html>
More information about the ghc-commits
mailing list