[Git][ghc/ghc][wip/decode_cloned_stack] Compiles (again)
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Nov 19 12:43:58 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
ff9d4c72 by Sven Tennie at 2022-11-19T12:43:37+00:00
Compiles (again)
- - - - -
4 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
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -11,6 +11,7 @@
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
-- TODO: Find better place than top level. Re-export from top-level?
module GHC.Exts.DecodeStack (
@@ -65,6 +66,8 @@ foreign import prim "getInfoTableTypezh" getInfoTableType# :: StackSnapshot# ->
foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
+foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
+
foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word#, Word# #)
@@ -119,6 +122,14 @@ toClosure f# (StackFrameIter (# s#, i# #)) = unsafePerformIO $
getClosureDataFromHeapRep heapRep infoTablePtr ptrList
+decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackSnapshot# -> Word# -> Word# -> [BitmapPayload]
+decodeLargeBitmap getterFun# stackFrame# closureOffset# relativePayloadOffset# =
+ let !(# bitmapArray#, size# #) = getterFun# stackFrame# closureOffset#
+ bitmapWords :: [Word] = foldrByteArray (\w acc -> W# w : acc) [] bitmapArray#
+ bes = wordsToBitmapEntries (StackFrameIter (# stackFrame#, plusWord# closureOffset# relativePayloadOffset# #)) (trace ("bitmapWords" ++ show bitmapWords) bitmapWords) (trace ("XXX size " ++ show (W# size#))(W# size#))
+ payloads = map toBitmapPayload bes
+ in
+ payloads
unpackStackFrameIter :: StackFrameIter -> StackFrame
unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
@@ -129,7 +140,7 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
ptrs' = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgRetBCOFramePtrs)) sfi
arity' = W# (getHalfWord# s# i# (intToWord# offsetStgRetBCOFrameArity))
size' = W# (getHalfWord# s# i# (intToWord# offsetStgRetBCOFrameSize))
- payload' =
+ payload' = decodeLargeBitmap getBCOLargeBitmap# s# i# 2##
in
RetBCO {
instrs = instrs',
@@ -145,10 +156,7 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
special = (toEnum . fromInteger . toInteger) (W# special#)
in
RetSmall special payloads
- RET_BIG -> let !(# bitmapArray#, size# #) = getLargeBitmap# s# i#
- bitmapWords :: [Word] = foldrByteArray (\w acc -> W# w : acc) [] bitmapArray#
- bes = wordsToBitmapEntries (StackFrameIter (# s#, plusWord# i# 1## #)) (trace ("bitmapWords" ++ show bitmapWords) bitmapWords) (trace ("XXX size " ++ show (W# size#))(W# size#))
- payloads = map toBitmapPayload bes
+ RET_BIG -> let payloads = decodeLargeBitmap getLargeBitmap# s# i# 1##
in
RetBig payloads
RET_FUN -> let
@@ -160,10 +168,7 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
case t of
ARG_GEN_BIG ->
let
- !(# bitmapArray#, size# #) = getRetFunLargeBitmap# s# i#
- bitmapWords :: [Word] = foldrByteArray (\w acc -> W# w : acc) [] bitmapArray#
- bes = wordsToBitmapEntries (StackFrameIter (# s#, plusWord# i# 2## #)) (trace ("bitmapWords" ++ show bitmapWords) bitmapWords) (trace ("XXX size " ++ show (W# size#))(W# size#))
- payloads = map toBitmapPayload bes
+ payloads = decodeLargeBitmap getRetFunLargeBitmap# s# i# 2##
in
payloads
_ ->
@@ -304,6 +309,7 @@ data StackFrame =
RetBig { payload :: [BitmapPayload] } |
RetFun { retFunType :: RetFunType, size :: Word, fun :: CL.Closure, payload :: [BitmapPayload]} |
RetBCO {
+ -- TODO: Add pre-defined BCO closures (like knownUpdateFrameType)
instrs :: CL.Closure,
literals :: CL.Closure,
ptrs :: CL.Closure,
=====================================
libraries/ghc-heap/GHC/Exts/StackConstants.hsc
=====================================
@@ -49,17 +49,17 @@ offsetStgRetFunFramePayload :: Int
offsetStgRetFunFramePayload = (#const OFFSET_StgRetFun_payload) + (#size StgHeader)
offsetStgRetBCOFrameInstrs :: Int
-offsetStgRetBCOFrameInstrs = (#const OFFSET_StgRetBCO_instrs) + (#size StgHeader)
+offsetStgRetBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
offsetStgRetBCOFrameLiterals :: Int
-offsetStgRetBCOFrameLiterals = (#const OFFSET_StgRetBCO_literals) + (#size StgHeader)
+offsetStgRetBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader)
offsetStgRetBCOFramePtrs :: Int
-offsetStgRetBCOFramePtrs = (#const OFFSET_StgRetBCO_ptrs) + (#size StgHeader)
+offsetStgRetBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader)
offsetStgRetBCOFrameArity :: Int
-offsetStgRetBCOFrameArity = (#const OFFSET_StgRetBCO_arity) + (#size StgHeader)
+offsetStgRetBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader)
offsetStgRetBCOFrameSize :: Int
-offsetStgRetBCOFrameSize = (#const OFFSET_StgRetBCO_size) + (#size StgHeader)
+offsetStgRetBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader)
#endif
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -155,6 +155,21 @@ StgWord getLargeBitmapSize(StgClosure *c) {
return bitmap->size;
}
+StgWord getRetFunSize(StgRetFun *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_SIZE(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 getBCOLargeBitmapSize(StgClosure *c) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -58,7 +58,7 @@ advanceStackFrameIterzh (P_ stack, W_ index) {
P_ nextClosure;
nextClosure = StgStack_sp(stack) + WDS(index);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(nextClosure));
- ccall checkSTACK(stack);
+// ccall checkSTACK(stack);
}
#endif
@@ -195,7 +195,9 @@ getWordzh(P_ stack, W_ index, W_ offset){
getHalfWordzh(P_ stack, W_ index, W_ offset){
P_ wordAddr;
wordAddr = (StgStack_sp(stack) + WDS(index) + offset);
- return (HALF_WORD[wordAddr]);
+ bits32 result;
+ result = bits32[wordAddr];
+ return (result);
}
getUnderflowFrameNextChunkzh(P_ stack, W_ index){
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff9d4c72fc0e1599d0317678028e12d852260a29
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff9d4c72fc0e1599d0317678028e12d852260a29
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/20221119/ffce3d65/attachment-0001.html>
More information about the ghc-commits
mailing list