[Git][ghc/ghc][wip/decode_cloned_stack] Split StackFrameIterator into separate constructors
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Feb 4 20:00:46 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
6f861873 by Sven Tennie at 2023-02-04T20:00:02+00:00
Split StackFrameIterator into separate constructors
- - - - -
2 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -106,29 +106,36 @@ Technical details
foreign import prim "getUpdateFrameTypezh" getUpdateFrameType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
getUpdateFrameType :: StackFrameIter -> IO UpdateFrameType
-getUpdateFrameType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+getUpdateFrameType (SfiClosure {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
case (getUpdateFrameType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, uft# #) -> (# s1, W# uft# #))
+getUpdateFrameType sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
getUnderflowFrameNextChunk :: StackFrameIter -> IO StackSnapshot
-getUnderflowFrameNextChunk (StackFrameIter {..}) = IO $ \s ->
+getUnderflowFrameNextChunk (SfiClosure {..}) = IO $ \s ->
case getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index) s of
(# s1, stack# #) -> (# s1, StackSnapshot stack# #)
+getUnderflowFrameNextChunk sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
getWord :: StackFrameIter -> WordOffset -> IO Word
-getWord (StackFrameIter {..}) relativeOffset = IO $ \s ->
+getWord (SfiPrimitive {..}) relativeOffset = IO $ \s ->
case getWord# stackSnapshot# (wordOffsetToWord# index) (wordOffsetToWord# relativeOffset) s of
(# s1, w# #) -> (# s1, W# w# #)
+getWord (SfiClosure {..}) relativeOffset = IO $ \s ->
+ case getWord# stackSnapshot# (wordOffsetToWord# index) (wordOffsetToWord# relativeOffset) s of
+ (# s1, w# #) -> (# s1, W# w# #)
+getWord sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
-- TODO: Could use getWord
getRetFunType :: StackFrameIter -> IO RetFunType
-getRetFunType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+getRetFunType (SfiClosure {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
case (getRetFunType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, rft# #) -> (# s1, W# rft# #))
+getRetFunType sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
@@ -141,8 +148,9 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word
foreign import prim "getRetSmallSpecialTypezh" getRetSmallSpecialType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
getRetSmallSpecialType :: StackFrameIter -> IO SpecialRetSmall
-getRetSmallSpecialType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+getRetSmallSpecialType (SfiClosure {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
case (getRetSmallSpecialType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, rft# #) -> (# s1, W# rft# #))
+getRetSmallSpecialType sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
@@ -153,10 +161,10 @@ foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# ->
foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
getInfoTable :: StackFrameIter -> IO StgInfoTable
-getInfoTable StackFrameIter {..} | sfiKind == SfiClosure =
+getInfoTable SfiClosure {..} =
let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
in peekItbl infoTablePtr
-getInfoTable StackFrameIter {..} | sfiKind == SfiStack = peekItbl $ Ptr (getStackInfoTableAddr# stackSnapshot#)
+getInfoTable SfiStackClosure {..} = peekItbl $ Ptr (getStackInfoTableAddr# stackSnapshot#)
getInfoTable _ = error "Primitives have no info table!"
foreign import prim "getBoxedClosurezh" getBoxedClosure# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Any #)
@@ -164,21 +172,23 @@ foreign import prim "getBoxedClosurezh" getBoxedClosure# :: StackSnapshot# -> Wo
foreign import prim "getStackFieldszh" getStackFields# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Word32#, Word8#, Word8# #)
getStackFields :: StackFrameIter -> IO (Word32, Word8, Word8)
-getStackFields StackFrameIter {..} = IO $ \s ->
+getStackFields SfiStackClosure {..} = IO $ \s ->
case getStackFields# stackSnapshot# s of (# s1, sSize#, sDirty#, sMarking# #)
-> (# s1, (W32# sSize#, W8# sDirty#, W8# sMarking#) #)
+getStackFields sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
-- | Get an interator starting with the top-most stack frame
stackHead :: StackSnapshot -> StackFrameIter
-stackHead (StackSnapshot s) = StackFrameIter s 0 SfiClosure -- GHC stacks are never empty
+stackHead (StackSnapshot s) = SfiClosure s 0 -- GHC stacks are never empty
-- | Advance iterator to the next stack frame (if any)
advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
-advanceStackFrameIter (StackFrameIter {..}) =
+advanceStackFrameIter (SfiClosure {..}) =
let !(# s', i', hasNext #) = advanceStackFrameIter# stackSnapshot# (wordOffsetToWord# index)
in if (I# hasNext) > 0
- then Just $ StackFrameIter s' (primWordToWordOffset i') SfiClosure
+ then Just $ SfiClosure s' (primWordToWordOffset i')
else Nothing
+advanceStackFrameIter sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
primWordToWordOffset :: Word# -> WordOffset
primWordToWordOffset w# = fromIntegral (W# w#)
@@ -191,52 +201,58 @@ wordsToBitmapEntries sfi (b : bs) bitmapSize =
let entries = toBitmapEntries sfi b (min bitmapSize (fromIntegral wORD_SIZE_IN_BITS))
mbLastFrame = (listToMaybe . reverse) entries
in case mbLastFrame of
- Just (StackFrameIter {..}) ->
- entries ++ wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + 1) SfiClosure) bs (subtractDecodedBitmapWord bitmapSize)
- Nothing -> error "This should never happen! Recursion ended not in base case."
+ Just (SfiClosure {..}) ->
+ entries ++ wordsToBitmapEntries (SfiClosure stackSnapshot# (index + 1)) bs (subtractDecodedBitmapWord bitmapSize)
+ Just (SfiPrimitive {..}) ->
+ entries ++ wordsToBitmapEntries (SfiClosure stackSnapshot# (index + 1)) bs (subtractDecodedBitmapWord bitmapSize)
+ _ -> error "This should never happen! Recursion ended not in base case."
where
subtractDecodedBitmapWord :: Word -> Word
subtractDecodedBitmapWord bSize = fromIntegral $ max 0 ((fromIntegral bSize) - wORD_SIZE_IN_BITS)
toBitmapEntries :: StackFrameIter -> Word -> Word -> [StackFrameIter]
toBitmapEntries _ _ 0 = []
-toBitmapEntries sfi@(StackFrameIter {..}) bitmapWord bSize =
+toBitmapEntries (SfiClosure {..}) bitmapWord bSize =
-- TODO: overriding isPrimitive field is a bit weird. Could be calculated before
- sfi {
- sfiKind = if (bitmapWord .&. 1) /= 0 then SfiPrimitive else SfiClosure
- }
- : toBitmapEntries (StackFrameIter stackSnapshot# (index + 1) SfiClosure) (bitmapWord `shiftR` 1) (bSize - 1)
+ (if (bitmapWord .&. 1) /= 0 then SfiPrimitive stackSnapshot# index else SfiClosure stackSnapshot# index)
+ : toBitmapEntries (SfiClosure stackSnapshot# (index + 1)) (bitmapWord `shiftR` 1) (bSize - 1)
+toBitmapEntries sfi _ _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
toBitmapPayload :: StackFrameIter -> IO Box
-toBitmapPayload sfi | sfiKind sfi == SfiPrimitive = pure (StackFrameBox sfi)
-toBitmapPayload sfi = getClosure sfi 0
+toBitmapPayload sfi at SfiPrimitive{} = pure (StackFrameBox sfi)
+toBitmapPayload sfi at SfiClosure{} = getClosure sfi 0
+toBitmapPayload sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
getClosure :: StackFrameIter -> WordOffset -> IO Box
-getClosure sfi at StackFrameIter {..} relativeOffset = trace ("getClosure " ++ show sfi ++ " " ++ show relativeOffset) $
+getClosure sfi at SfiClosure {..} relativeOffset = trace ("getClosure " ++ show sfi ++ " " ++ show relativeOffset) $
IO $ \s ->
case (getBoxedClosure# stackSnapshot# (wordOffsetToWord# (index + relativeOffset)) s) of (# s1, ptr #) ->
(# s1, Box ptr #)
+getClosure sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
decodeLargeBitmap :: (StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
-decodeLargeBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset = do
+decodeLargeBitmap getterFun# sfi@(SfiClosure {..}) relativePayloadOffset = do
(bitmapArray, size) <- IO $ \s ->
case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
(# s1, ba#, s# #) -> (# s1, (ByteArray ba#, W# s#) #)
let bitmapWords :: [Word] = byteArrayToList bitmapArray
decodeBitmaps sfi relativePayloadOffset bitmapWords size
+decodeLargeBitmap _ sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> IO [Box]
-decodeBitmaps (StackFrameIter {..}) relativePayloadOffset bitmapWords size =
- let bes = wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + relativePayloadOffset) SfiClosure) bitmapWords size
+decodeBitmaps (SfiClosure {..}) relativePayloadOffset bitmapWords size =
+ let bes = wordsToBitmapEntries (SfiClosure stackSnapshot# (index + relativePayloadOffset)) bitmapWords size
in mapM toBitmapPayload bes
+decodeBitmaps sfi _ _ _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
decodeSmallBitmap :: (StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
-decodeSmallBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset = do
+decodeSmallBitmap getterFun# sfi@(SfiClosure {..}) relativePayloadOffset = do
(bitmap, size) <- IO $ \s ->
case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
(# s1, b# , s# #) -> (# s1, (W# b# , W# s#) #)
let bitmapWords = if size > 0 then [bitmap] else []
decodeBitmaps sfi relativePayloadOffset bitmapWords size
+decodeSmallBitmap _ sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
byteArrayToList :: ByteArray -> [Word]
byteArrayToList (ByteArray bArray) = go 0
@@ -250,8 +266,8 @@ wordOffsetToWord# :: WordOffset -> Word#
wordOffsetToWord# wo = intToWord# (fromIntegral wo)
unpackStackFrameIter :: StackFrameIter -> IO Closure
-unpackStackFrameIter sfi | sfiKind sfi == SfiPrimitive = UnknownTypeWordSizedPrimitive <$> (getWord sfi 0)
-unpackStackFrameIter sfi | sfiKind sfi == SfiStack = do
+unpackStackFrameIter sfi@(SfiPrimitive { }) = UnknownTypeWordSizedPrimitive <$> (getWord sfi 0)
+unpackStackFrameIter sfi@(SfiStackClosure {}) = do
info <- getInfoTable sfi
(stack_size', stack_dirty', stack_marking') <- getStackFields sfi
case tipe info of
@@ -265,7 +281,7 @@ unpackStackFrameIter sfi | sfiKind sfi == SfiStack = do
stack = stack'
}
_ -> error $ "Expected STACK closure, got " ++ show info
-unpackStackFrameIter sfi = do
+unpackStackFrameIter sfi@(SfiClosure {}) = do
traceM $ "unpackStackFrameIter - sfi " ++ show sfi
info <- getInfoTable sfi
res <- unpackStackFrameIter' info
@@ -334,11 +350,7 @@ unpackStackFrameIter sfi = do
(StackSnapshot nextChunk') <- getUnderflowFrameNextChunk sfi
pure $ UnderflowFrame
{ info = info,
- nextChunk = StackFrameBox $ StackFrameIter {
- stackSnapshot# = nextChunk',
- index = 0,
- sfiKind = SfiStack
- }
+ nextChunk = StackFrameBox $ SfiStackClosure nextChunk'
}
STOP_FRAME -> pure $ StopFrame {info = info}
ATOMICALLY_FRAME -> do
@@ -383,11 +395,8 @@ intToWord# :: Int -> Word#
intToWord# i = int2Word# (toInt# i)
decodeStack :: StackSnapshot -> IO Closure
-decodeStack (StackSnapshot stack#) = unpackStackFrameIter $ StackFrameIter {
- stackSnapshot# = stack#,
- index = 0,
- sfiKind = SfiStack
- }
+decodeStack (StackSnapshot stack#) = unpackStackFrameIter $ SfiStackClosure stack#
+
decodeStack' :: StackSnapshot -> [Box]
decodeStack' s = StackFrameBox (stackHead s) : go (advanceStackFrameIter (stackHead s))
where
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -25,7 +25,6 @@ module GHC.Exts.Heap.Closures (
, areBoxesEqual
, asBox
#if MIN_TOOL_VERSION_ghc(9,5,0)
- , SfiKind(..)
, StackFrameIter(..)
#endif
) where
@@ -68,19 +67,46 @@ foreign import prim "reallyUnsafePtrEqualityUpToTag"
reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
#if MIN_TOOL_VERSION_ghc(9,5,0)
-data SfiKind = SfiClosure | SfiPrimitive | SfiStack
- deriving (Eq, Show)
-
-data StackFrameIter = StackFrameIter
- { stackSnapshot# :: !StackSnapshot#,
- index :: !WordOffset,
- sfiKind :: !SfiKind
- }
+-- | Iterator state for stack decoding
+data StackFrameIter =
+ -- | Represents a `StackClosure` / @StgStack@
+ SfiStackClosure
+ { stackSnapshot# :: !StackSnapshot# }
+ -- | Represents a closure on the stack
+ | SfiClosure
+ { stackSnapshot# :: !StackSnapshot#,
+ index :: !WordOffset
+ }
+ -- | Represents a primitive word on the stack
+ | SfiPrimitive
+ { stackSnapshot# :: !StackSnapshot#,
+ index :: !WordOffset
+ }
+instance Eq StackFrameIter where
+ (SfiStackClosure s1#) == (SfiStackClosure s2#) = (StackSnapshot s1#) == (StackSnapshot s2#)
+ (SfiClosure s1# i1) == (SfiClosure s2# i2) =
+ (StackSnapshot s1#) == (StackSnapshot s2#)
+ && i1 == i2
+ (SfiPrimitive s1# i1) == (SfiPrimitive s2# i2) =
+ (StackSnapshot s1#) == (StackSnapshot s2#)
+ && i1 == i2
+ _ == _ = False
+
+-- TODO: Reduce duplication in where clause
instance Show StackFrameIter where
- showsPrec _ (StackFrameIter s# i p) rs =
- -- TODO: Record syntax could be nicer to read
- "StackFrameIter(" ++ pad_out (showHex addr "") ++ ", " ++ show i ++ ", " ++ show p ++ ")" ++ rs
+ showsPrec _ (SfiStackClosure s#) rs =
+ "SfiStackClosure { stackSnapshot# = " ++ pad_out (showHex addr "") ++ "}" ++ rs
+ where
+ addr = stackSnapshotToWord (StackSnapshot s#)
+ pad_out ls = '0':'x':ls
+ showsPrec _ (SfiClosure s# i ) rs =
+ "SfiClosure { stackSnapshot# = " ++ pad_out (showHex addr "") ++ ", index = " ++ show i ++ ", " ++ "}" ++ rs
+ where
+ addr = stackSnapshotToWord (StackSnapshot s#)
+ pad_out ls = '0':'x':ls
+ showsPrec _ (SfiPrimitive s# i ) rs =
+ "SfiPrimitive { stackSnapshot# = " ++ pad_out (showHex addr "") ++ ", index = " ++ show i ++ ", " ++ "}" ++ rs
where
addr = stackSnapshotToWord (StackSnapshot s#)
pad_out ls = '0':'x':ls
@@ -120,8 +146,7 @@ instance Show Box where
pad_out ls = '0':'x':ls
#if MIN_TOOL_VERSION_ghc(9,5,0)
showsPrec _ (StackFrameBox sfi) rs =
- -- TODO: Record syntax could be nicer to read
- "(StackFrameBox StackFrameIter(" ++ show sfi ++ ")" ++ rs
+ "(StackFrameBox " ++ show sfi ++ ")" ++ rs
#endif
-- | Boxes can be compared, but this is not pure, as different heap objects can,
@@ -132,14 +157,8 @@ areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
0# -> pure False
_ -> pure True
#if MIN_TOOL_VERSION_ghc(9,5,0)
--- TODO: Could be used for `instance Eq StackFrameIter`
-areBoxesEqual
- (StackFrameBox (StackFrameIter s1# i1 p1))
- (StackFrameBox (StackFrameIter s2# i2 p2)) =
- pure $
- (StackSnapshot s1#) == (StackSnapshot s2#)
- && i1 == i2
- && p1 == p2
+areBoxesEqual (StackFrameBox sfi1) (StackFrameBox sfi2) =
+ pure $ sfi1 == sfi2
areBoxesEqual _ _ = pure False
#endif
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6f861873caf2a185ff57f744aeba2847a5565d84
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6f861873caf2a185ff57f744aeba2847a5565d84
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/20230204/5ddcbdaf/attachment-0001.html>
More information about the ghc-commits
mailing list