[Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: Check sanity of stacks
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Oct 9 09:14:20 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
19730a4d by Sven Tennie at 2022-10-08T15:35:52+00:00
Check sanity of stacks
- - - - -
d264abaf by Sven Tennie at 2022-10-09T09:13:51+00:00
Start Update frames
- - - - -
5 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/cbits/Stack.cmm
- rts/Printer.c
- rts/sm/Sanity.c
- rts/sm/Sanity.h
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -92,22 +92,24 @@ toBitmapPayload :: BitmapEntry -> BitmapPayload
toBitmapPayload e | isPrimitive e = Primitive . toWord . closureFrame $ e
where
toWord (StackFrameIter (# s#, i# #)) = W# (derefStackWord# s# i#)
-toBitmapPayload e = Closure . unsafePerformIO . toClosure . closureFrame $ e
- where
- toClosure (StackFrameIter (# s#, i# #)) =
- case unpackClosureFromStackFrame# s# i# of
- (# infoTableAddr, heapRep, pointersArray #) -> do
- let infoTablePtr = Ptr infoTableAddr
- ptrList = [case indexArray# pointersArray i of
- (# ptr #) -> Box ptr
- | I# i <- [0..I# (sizeofArray# pointersArray) - 1]
- ]
+toBitmapPayload e = Closure . toClosure unpackClosureFromStackFrame# . closureFrame $ e
+
+-- TODO: Get rid of unsafePerformIO
+toClosure :: (StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# Any #)) -> StackFrameIter -> CL.Closure
+toClosure f# (StackFrameIter (# s#, i# #)) = unsafePerformIO $
+ case f# s# i# of
+ (# infoTableAddr, heapRep, pointersArray #) -> do
+ let infoTablePtr = Ptr infoTableAddr
+ ptrList = [case indexArray# pointersArray i of
+ (# ptr #) -> Box ptr
+ | I# i <- [0..I# (sizeofArray# pointersArray) - 1]
+ ]
- getClosureDataFromHeapRep heapRep infoTablePtr ptrList
+ getClosureDataFromHeapRep heapRep infoTablePtr ptrList
unpackStackFrameIter :: StackFrameIter -> StackFrame
-unpackStackFrameIter (StackFrameIter (# s#, i# #)) =
+unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
case (toEnum . fromIntegral) (W# (getInfoTableType# s# i#)) of
RET_BCO -> RetBCO
RET_SMALL -> let !(# bitmap#, size#, special# #) = getSmallBitmap# s# i#
@@ -123,7 +125,8 @@ unpackStackFrameIter (StackFrameIter (# s#, i# #)) =
in
RetBig payloads
RET_FUN -> RetFun
- UPDATE_FRAME -> UpdateFrame
+ -- TODO: Decode update frame type
+ UPDATE_FRAME -> UpdateFrame NormalUpdateFrame (toClosure unpackUpdateeFromUpdateFrame# sfi)
CATCH_FRAME -> CatchFrame
UNDERFLOW_FRAME -> UnderflowFrame
STOP_FRAME -> StopFrame
@@ -158,6 +161,8 @@ toInt# (I# i) = i
foreign import prim "unpackClosureFromStackFramezh" unpackClosureFromStackFrame# :: StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# b #)
+foreign import prim "unpackUpdateeFromUpdateFramezh" unpackUpdateeFromUpdateFrame# :: StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# b #)
+
foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word# -> Word#
data BitmapPayload = Closure CL.Closure | Primitive Word
@@ -191,8 +196,14 @@ data SpecialRetSmall =
RestoreCCCSEval
deriving (Enum, Eq,Show)
+data UpdateFrameType =
+ NormalUpdateFrame |
+ BhUpdateFrame |
+ MarkedUpdateFrame
+ deriving (Show)
+
data StackFrame =
- UpdateFrame |
+ UpdateFrame UpdateFrameType CL.Closure |
CatchFrame |
CatchStmFrame |
CatchRetryFrame |
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -53,6 +53,7 @@ advanceStackFrameIterzh (P_ stack, W_ index) {
P_ nextClosure;
nextClosure = StgStack_sp(stack) + WDS(index);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(nextClosure));
+ ccall checkSTACK(stack);
}
// ccall debugBelch("advanceStackFrameIterzh - stack %p, newStack %p, frameSize %ul, newIdex %ul, hasNext %ul, stackBottom %p\n", stack, newStack, frameSize, newIndex, hasNext, stackBottom);
@@ -96,9 +97,20 @@ unpackClosureFromStackFramezh(P_ stack, W_ index){
P_ closurePtr, closurePtrPrime;
closurePtr = (StgStack_sp(stack) + WDS(index));
closurePtrPrime = P_[closurePtr];
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtrPrime));
jump stg_unpackClosurezh(closurePtrPrime);
}
+unpackUpdateeFromUpdateFramezh(P_ stack, W_ index){
+ P_ closurePtr, closurePtrPrime, updateePtr;
+ closurePtr = (StgStack_sp(stack) + WDS(index));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));
+ updateePtr = StgUpdateFrame_updatee(closurePtr);
+ // ccall debugBelch("unpackUpdateeFromUpdateFramezh - frame %p, updateePtr %p\n", closurePtr, updateePtr);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(updateePtr));
+ jump stg_unpackClosurezh(updateePtr);
+}
+
getLargeBitmapzh(P_ stack, W_ index){
P_ c, stgArrBytes;
W_ size;
=====================================
rts/Printer.c
=====================================
@@ -260,6 +260,7 @@ printClosure( const StgClosure *obj )
case UPDATE_FRAME:
{
StgUpdateFrame* u = (StgUpdateFrame*)obj;
+ debugBelch("printObj - frame %p, indirectee %p\n", u, u->updatee);
debugBelch("%s(", info_update_frame(obj));
printPtr((StgPtr)GET_INFO((StgClosure *)u));
debugBelch(",");
=====================================
rts/sm/Sanity.c
=====================================
@@ -42,7 +42,6 @@ int isHeapAlloced ( StgPtr p);
static void checkSmallBitmap ( StgPtr payload, StgWord bitmap, uint32_t );
static void checkLargeBitmap ( StgPtr payload, StgLargeBitmap*, uint32_t );
static void checkClosureShallow ( const StgClosure * );
-static void checkSTACK (StgStack *stack);
static W_ countNonMovingSegments ( struct NonmovingSegment *segs );
static W_ countNonMovingHeap ( struct NonmovingHeap *heap );
@@ -700,7 +699,7 @@ checkCompactObjects(bdescr *bd)
}
}
-static void
+void
checkSTACK (StgStack *stack)
{
StgPtr sp = stack->sp;
=====================================
rts/sm/Sanity.h
=====================================
@@ -39,6 +39,7 @@ void memInventory (bool show);
void checkBQ (StgTSO *bqe, StgClosure *closure);
+void checkSTACK (StgStack *stack);
#include "EndPrivate.h"
#endif /* DEBUG */
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ae908a83a593fd4672e2234b3b149c43881fb8bc...d264abafc07006298a3571fbfc5958e5f2966739
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ae908a83a593fd4672e2234b3b149c43881fb8bc...d264abafc07006298a3571fbfc5958e5f2966739
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/20221009/e564b451/attachment-0001.html>
More information about the ghc-commits
mailing list