[Git][ghc/ghc][wip/decode_cloned_stack] Splitting StackFrames from Closures: Compiles
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Wed Mar 29 17:58:24 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
9da88173 by Sven Tennie at 2023-03-29T17:58:11+00:00
Splitting StackFrames from Closures: Compiles
- - - - -
5 changed files:
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/Decode.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghci/GHCi/Message.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.Exts.Heap (
-- * Closure types
Closure
, GenClosure(..)
+ , StackFrame(..)
, ClosureType(..)
, PrimType(..)
, WhatNext(..)
@@ -138,11 +139,6 @@ instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
getClosureData x = return $
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
-#if MIN_TOOL_VERSION_ghc(9,7,0)
-instance {-# OVERLAPPING #-} HasHeapRep StackSnapshot# where
- getClosureData s# = decodeStack (StackSnapshot s#)
-#endif
-
-- | Get the heap representation of a closure _at this moment_, even if it is
-- unevaluated or an indirection or other exotic stuff. Beware when passing
-- something to this function, the same caveats as for
@@ -180,31 +176,9 @@ getClosureDataFromHeapObject x = do
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a
-#if MIN_TOOL_VERSION_ghc(9,7,0)
-getBoxedClosureData b@(StackFrameBox sfi) = trace ("unpack " ++ show b) $ unpackStackFrameIter sfi
-#endif
-
-- | Get the size of the top-level closure in words.
-- Includes header and payload. Does not follow pointers.
--
-- @since 8.10.1
closureSize :: Box -> IO Int
closureSize (Box x) = pure $ I# (closureSize# x)
-#if MIN_TOOL_VERSION_ghc(9,7,0)
-closureSize (StackFrameBox sfi) = unpackStackFrameIter sfi <&>
- \c ->
- case c of
- UpdateFrame {} -> sizeStgUpdateFrame
- CatchFrame {} -> sizeStgCatchFrame
- CatchStmFrame {} -> sizeStgCatchSTMFrame
- CatchRetryFrame {} -> sizeStgCatchRetryFrame
- AtomicallyFrame {} -> sizeStgAtomicallyFrame
- RetSmall {..} -> sizeStgClosure + length payload
- RetBig {..} -> sizeStgClosure + length payload
- RetFun {..} -> sizeStgRetFunFrame + length retFunPayload
- -- The one additional word is a pointer to the StgBCO in the closure's payload
- RetBCO {..} -> sizeStgClosure + 1 + length bcoArgs
- -- The one additional word is a pointer to the next stack chunk
- UnderflowFrame {} -> sizeStgClosure + 1
- _ -> error "Unexpected closure type"
-#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -11,6 +11,7 @@ module GHC.Exts.Heap.Closures (
-- * Closures
Closure
, GenClosure(..)
+ , StackFrame(..)
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
@@ -22,6 +23,7 @@ module GHC.Exts.Heap.Closures (
, Box(..)
, areBoxesEqual
, asBox
+ , StgStackClosure(..)
#if MIN_TOOL_VERSION_ghc(9,7,0)
, StackFrameIter(..)
#endif
@@ -50,7 +52,6 @@ import Data.Word
import GHC.Exts
import GHC.Generics
import Numeric
-
#if MIN_TOOL_VERSION_ghc(9,7,0)
import GHC.Stack.CloneStack (StackSnapshot(..), stackSnapshotToString)
import GHC.Exts.Stack.Constants
@@ -67,11 +68,8 @@ foreign import prim "reallyUnsafePtrEqualityUpToTag"
#if MIN_TOOL_VERSION_ghc(9,7,0)
-- | Iterator state for stack decoding
data StackFrameIter =
- -- | Represents a `StackClosure` / @StgStack@
- SfiStackClosure
- { stackSnapshot# :: !StackSnapshot# }
-- | Represents a closure on the stack
- | SfiClosure
+ SfiClosure
{ stackSnapshot# :: !StackSnapshot#,
index :: !WordOffset
}
@@ -82,8 +80,6 @@ data StackFrameIter =
}
instance Eq StackFrameIter where
- (SfiStackClosure s1#) == (SfiStackClosure s2#) =
- (StackSnapshot s1#) == (StackSnapshot s2#)
(SfiClosure s1# i1) == (SfiClosure s2# i2) =
(StackSnapshot s1#) == (StackSnapshot s2#)
&& i1 == i2
@@ -93,34 +89,31 @@ instance Eq StackFrameIter where
_ == _ = False
instance Show StackFrameIter where
- showsPrec _ (SfiStackClosure s#) rs =
- "SfiStackClosure { stackSnapshot# = " ++ stackSnapshotToString (StackSnapshot s#) ++ "}" ++ rs
showsPrec _ (SfiClosure s# i ) rs =
"SfiClosure { stackSnapshot# = " ++ stackSnapshotToString (StackSnapshot s#) ++ show i ++ ", " ++ "}" ++ rs
showsPrec _ (SfiPrimitive s# i ) rs =
"SfiPrimitive { stackSnapshot# = " ++ stackSnapshotToString (StackSnapshot s#) ++ show i ++ ", " ++ "}" ++ rs
--- | An arbitrary Haskell value in a safe Box.
---
--- The point is that even unevaluated thunks can safely be moved around inside
--- the Box, and when required, e.g. in 'getBoxedClosureData', the function knows
--- how far it has to evaluate the argument.
---
--- `Box`es can be used to increase (and enforce) laziness: In a graph of
--- closures they can act as a barrier of evaluation. `Closure` is an example for
--- this.
-data Box =
- -- | A heap located closure.
- Box Any
- -- | A value or reference to a value on the stack.
- | StackFrameBox StackFrameIter
-#else
+-- | A value or reference to a value on the stack.
+newtype StackFrameBox = StackFrameBox StackFrameIter
+ deriving (Eq)
+
+instance Show StackFrameBox where
+ showsPrec _ (StackFrameBox sfi) rs =
+ "(StackFrameBox " ++ show sfi ++ ")" ++ rs
+
+areStackFrameBoxesEqual :: StackFrameBox -> StackFrameBox -> Bool
+areStackFrameBoxesEqual (StackFrameBox sfi1) (StackFrameBox sfi2) =
+ sfi1 == sfi2
+areStackFrameBoxesEqual _ _ = False
+
+#endif
+
-- | An arbitrary Haskell value in a safe Box. The point is that even
-- unevaluated thunks can safely be moved around inside the Box, and when
-- required, e.g. in 'getBoxedClosureData', the function knows how far it has
-- to evaluate the argument.
data Box = Box Any
-#endif
instance Show Box where
-- From libraries/base/GHC/Ptr.lhs
@@ -132,10 +125,6 @@ instance Show Box where
tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
addr = ptr - tag
pad_out ls = '0':'x':ls
-#if MIN_TOOL_VERSION_ghc(9,7,0)
- showsPrec _ (StackFrameBox sfi) rs =
- "(StackFrameBox " ++ show sfi ++ ")" ++ rs
-#endif
-- | Boxes can be compared, but this is not pure, as different heap objects can,
-- after garbage collection, become the same object.
@@ -143,11 +132,6 @@ areBoxesEqual :: Box -> Box -> IO Bool
areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
0# -> pure False
_ -> pure True
-#if MIN_TOOL_VERSION_ghc(9,7,0)
-areBoxesEqual (StackFrameBox sfi1) (StackFrameBox sfi2) =
- pure $ sfi1 == sfi2
-areBoxesEqual _ _ = pure False
-#endif
-- |This takes an arbitrary value and puts it into a box.
-- Note that calls like
@@ -163,7 +147,6 @@ asBox x = Box (unsafeCoerce# x)
------------------------------------------------------------------------
-- Closures
-
type Closure = GenClosure Box
-- | This is the representation of a Haskell value on the heap. It reflects
@@ -369,74 +352,8 @@ data GenClosure b
#if __GLASGOW_HASKELL__ >= 811
, stack_marking :: !Word8
#endif
- -- | The frames of the stack. Only available if a cloned stack was
- -- decoded, otherwise empty.
- , stack :: ![b]
- }
-
-#if MIN_TOOL_VERSION_ghc(9,7,0)
- | UpdateFrame
- { info :: !StgInfoTable
- , updatee :: !b
- }
-
- | CatchFrame
- { info :: !StgInfoTable
- , exceptions_blocked :: Word
- , handler :: !b
- }
-
- | CatchStmFrame
- { info :: !StgInfoTable
- , catchFrameCode :: !b
- , handler :: !b
- }
-
- | CatchRetryFrame
- { info :: !StgInfoTable
- , running_alt_code :: !Word
- , first_code :: !b
- , alt_code :: !b
}
- | AtomicallyFrame
- { info :: !StgInfoTable
- , atomicallyFrameCode :: !b
- , result :: !b
- }
-
- | UnderflowFrame
- { info :: !StgInfoTable
- , nextChunk :: !b
- }
-
- | StopFrame
- { info :: !StgInfoTable }
-
- | RetSmall
- { info :: !StgInfoTable
- , payload :: ![b]
- }
-
- | RetBig
- { info :: !StgInfoTable
- , payload :: ![b]
- }
-
- | RetFun
- { info :: !StgInfoTable
- , retFunType :: RetFunType
- , retFunSize :: Word
- , retFunFun :: !b
- , retFunPayload :: ![b]
- }
-
- | RetBCO
- { info :: !StgInfoTable
- , bco :: !b -- must be a BCOClosure
- , bcoArgs :: ![b]
- }
-#endif
------------------------------------------------------------
-- Unboxed unlifted closures
@@ -491,7 +408,92 @@ data GenClosure b
| UnknownTypeWordSizedPrimitive
{ wordVal :: !Word }
- deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
+ deriving (Show, Generic, Functor, Foldable, Traversable)
+
+-- | A decoded @StgStack@ with `StackFrame`s
+--
+-- This is separate from it's `Closure` incarnation, as unification would
+-- require two kinds of boxes for bitmap encoded stack content: One for
+-- primitives and one for closures. This turned out to be a nightmare with lots
+-- of pattern matches and leaking data structures to enable access to primitives
+-- on the stack...
+data StgStackClosure = StgStackClosure
+ { ssc_info :: !StgInfoTable
+ , ssc_stack_size :: !Word32 -- ^ stack size in *words*
+ , ssc_stack_dirty :: !Word8 -- ^ non-zero => dirty
+ , ssc_stack_marking :: !Word8
+ , ssc_stack :: ![StackFrame]
+ }
+ deriving Show
+
+-- | A single stack frame
+--
+-- It doesn't use `Box`es because that would require a `Box` constructor for
+-- primitive values (bitmap encoded payloads), which introduces lots of pattern
+-- matches and complicates the whole implementation (and breaks existing code.)
+data StackFrame =
+ UpdateFrame
+ { info_tbl :: !StgInfoTable
+ , updatee :: !Closure
+ }
+
+ | CatchFrame
+ { info_tbl :: !StgInfoTable
+ , exceptions_blocked :: Word
+ , handler :: !Closure
+ }
+
+ | CatchStmFrame
+ { info_tbl :: !StgInfoTable
+ , catchFrameCode :: !Closure
+ , handler :: !Closure
+ }
+
+ | CatchRetryFrame
+ { info_tbl :: !StgInfoTable
+ , running_alt_code :: !Word
+ , first_code :: !Closure
+ , alt_code :: !Closure
+ }
+
+ | AtomicallyFrame
+ { info_tbl :: !StgInfoTable
+ , atomicallyFrameCode :: !Closure
+ , result :: !Closure
+ }
+
+ | UnderflowFrame
+ { info_tbl :: !StgInfoTable
+ , nextChunk :: !StgStackClosure
+ }
+
+ | StopFrame
+ { info_tbl :: !StgInfoTable }
+
+ | RetSmall
+ { info_tbl :: !StgInfoTable
+ , stack_payload :: ![Closure]
+ }
+
+ | RetBig
+ { info_tbl :: !StgInfoTable
+ , stack_payload :: ![Closure]
+ }
+
+ | RetFun
+ { info_tbl :: !StgInfoTable
+ , retFunType :: RetFunType
+ , retFunSize :: Word
+ , retFunFun :: !Closure
+ , retFunPayload :: ![Closure]
+ }
+
+ | RetBCO
+ { info_tbl :: !StgInfoTable
+ , bco :: !Closure -- must be a BCOClosure
+ , bcoArgs :: ![Closure]
+ }
+ deriving (Show, Generic)
data RetFunType =
ARG_GEN |
@@ -592,16 +594,5 @@ allClosures (FunClosure {..}) = ptrArgs
allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ Data.Foldable.toList weakLink
allClosures (OtherClosure {..}) = hvalues
-#if MIN_TOOL_VERSION_ghc(9,7,0)
-allClosures (StackClosure {..}) = stack
-allClosures (UpdateFrame {..}) = [updatee]
-allClosures (CatchFrame {..}) = [handler]
-allClosures (CatchStmFrame {..}) = [catchFrameCode, handler]
-allClosures (CatchRetryFrame {..}) = [first_code, alt_code]
-allClosures (AtomicallyFrame {..}) = [atomicallyFrameCode, result]
-allClosures (RetSmall {..}) = payload
-allClosures (RetBig {..}) = payload
-allClosures (RetFun {..}) = retFunFun : retFunPayload
-allClosures (RetBCO {..}) = bco : bcoArgs
-#endif
+allClosures (StackClosure {}) = []
allClosures _ = []
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Decode.hs
=====================================
@@ -234,7 +234,6 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
#if __GLASGOW_HASKELL__ >= 811
, stack_marking = FFIClosures.stack_marking fields
#endif
- , stack = []
})
| otherwise
-> fail $ "Expected 0 ptr argument to STACK, found "
=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -15,7 +15,6 @@
module GHC.Exts.Stack.Decode
( decodeStack,
- unpackStackFrameIter,
)
where
@@ -29,6 +28,7 @@ import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
import GHC.Exts.Heap.InfoTable
import GHC.Exts.Stack.Constants
+import GHC.Exts.Heap.Decode
import GHC.IO (IO (..))
import GHC.Stack.CloneStack
import GHC.Word
@@ -111,37 +111,28 @@ Technical details
foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
-getUnderflowFrameNextChunk :: StackFrameIter -> IO StackSnapshot
-getUnderflowFrameNextChunk (SfiClosure {..}) = IO $ \s ->
+getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> IO StackSnapshot
+getUnderflowFrameNextChunk stackSnapshot# index = 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 (SfiPrimitive {..}) relativeOffset = IO $ \s ->
+getWord :: StackSnapshot# -> WordOffset -> WordOffset -> IO Word
+getWord stackSnapshot# index 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
type WordGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
foreign import prim "getRetFunTypezh" getRetFunType# :: WordGetter
-getRetFunType :: StackFrameIter -> IO RetFunType
-getRetFunType (SfiClosure {..}) =
+getRetFunType :: StackSnapshot# -> WordOffset -> IO RetFunType
+getRetFunType stackSnapshot# index =
toEnum . fromInteger . toInteger
<$> IO
( \s ->
@@ -151,7 +142,6 @@ getRetFunType (SfiClosure {..}) =
s of
(# s1, rft# #) -> (# s1, W# rft# #)
)
-getRetFunType sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
type LargeBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
@@ -171,29 +161,29 @@ foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# ->
foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
-getInfoTable :: StackFrameIter -> IO StgInfoTable
-getInfoTable SfiClosure {..} =
+getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable
+getInfoTableOnStack stackSnapshot# index =
let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
in peekItbl infoTablePtr
-getInfoTable SfiStackClosure {..} =
+
+getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
+getInfoTableForStack stackSnapshot# =
peekItbl $
Ptr (getStackInfoTableAddr# stackSnapshot#)
-getInfoTable _ = error "Primitives have no info table!"
foreign import prim "getBoxedClosurezh" getBoxedClosure# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Any #)
foreign import prim "getStackFieldszh" getStackFields# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Word32#, Word8#, Word8# #)
-getStackFields :: StackFrameIter -> IO (Word32, Word8, Word8)
-getStackFields SfiStackClosure {..} = IO $ \s ->
+getStackFields :: StackSnapshot# -> IO (Word32, Word8, Word8)
+getStackFields stackSnapshot# = 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) = SfiClosure s 0 -- GHC stacks are never empty
+stackHead :: StackSnapshot -> (StackSnapshot, WordOffset)
+stackHead (StackSnapshot s#) = (StackSnapshot s#, 0 ) -- GHC stacks are never empty
-- | Advance to the next stack frame (if any)
--
@@ -202,19 +192,18 @@ stackHead (StackSnapshot s) = SfiClosure s 0 -- GHC stacks are never empty
foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
-- | Advance iterator to the next stack frame (if any)
-advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
-advanceStackFrameIter (SfiClosure {..}) =
+advanceStackFrameIter :: StackSnapshot -> WordOffset -> Maybe (StackSnapshot, WordOffset)
+advanceStackFrameIter (StackSnapshot stackSnapshot#) index =
let !(# s', i', hasNext #) = advanceStackFrameIter# stackSnapshot# (wordOffsetToWord# index)
in if I# hasNext > 0
- then Just $ SfiClosure s' (primWordToWordOffset i')
+ then Just $ (StackSnapshot s', (primWordToWordOffset i'))
else Nothing
where
primWordToWordOffset :: Word# -> WordOffset
primWordToWordOffset w# = fromIntegral (W# w#)
-advanceStackFrameIter sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
-getClosure :: StackFrameIter -> WordOffset -> IO Box
-getClosure SfiClosure {..} relativeOffset =
+getClosure :: StackSnapshot# -> WordOffset -> WordOffset -> IO Box
+getClosure stackSnapshot# index relativeOffset =
IO $ \s ->
case getBoxedClosure#
stackSnapshot#
@@ -222,15 +211,14 @@ getClosure SfiClosure {..} relativeOffset =
s of
(# s1, ptr #) ->
(# s1, Box ptr #)
-getClosure sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
-decodeLargeBitmap :: LargeBitmapGetter -> StackFrameIter -> WordOffset -> IO [Box]
-decodeLargeBitmap getterFun# sfi@(SfiClosure {..}) relativePayloadOffset = do
+decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
+decodeLargeBitmap getterFun# stackSnapshot# index 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
+ decodeBitmaps stackSnapshot# index relativePayloadOffset bitmapWords size
where
byteArrayToList :: ByteArray -> [Word]
byteArrayToList (ByteArray bArray) = go 0
@@ -242,16 +230,17 @@ decodeLargeBitmap getterFun# sfi@(SfiClosure {..}) relativePayloadOffset = do
sizeofByteArray :: ByteArray# -> Int
sizeofByteArray arr# = I# (sizeofByteArray# arr#)
-decodeLargeBitmap _ sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
-decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> IO [Box]
-decodeBitmaps (SfiClosure {..}) relativePayloadOffset bitmapWords size =
+decodeBitmaps :: StackSnapshot# -> WordOffset -> WordOffset -> [Word] -> Word -> IO [Closure]
+decodeBitmaps stackSnapshot# index relativePayloadOffset bitmapWords size =
let bes = wordsToBitmapEntries (index + relativePayloadOffset) bitmapWords size
in mapM toBitmapPayload bes
where
- toBitmapPayload :: StackFrameIter -> IO Box
- toBitmapPayload sfi at SfiPrimitive {} = pure (StackFrameBox sfi)
- toBitmapPayload sfi at SfiClosure {} = getClosure sfi 0
+ toBitmapPayload :: StackFrameIter -> IO Closure
+ toBitmapPayload sfi at SfiPrimitive {..} = do
+ w <- getWord stackSnapshot# index 0
+ pure $ UnknownTypeWordSizedPrimitive w
+ toBitmapPayload sfi at SfiClosure {..} = getBoxedClosureData =<< getClosure stackSnapshot# index 0
toBitmapPayload sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
wordsToBitmapEntries :: WordOffset -> [Word] -> Word -> [StackFrameIter]
@@ -291,151 +280,144 @@ decodeBitmaps (SfiClosure {..}) relativePayloadOffset bitmapWords size =
getIndex (SfiClosure _ i) = i
getIndex (SfiPrimitive _ i) = i
getIndex sfi' = error $ "Has no index : " ++ show sfi'
-decodeBitmaps sfi _ _ _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
-decodeSmallBitmap :: SmallBitmapGetter -> StackFrameIter -> WordOffset -> IO [Box]
-decodeSmallBitmap getterFun# sfi@(SfiClosure {..}) relativePayloadOffset =
+decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
+decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
do
(bitmap, size) <- IO $ \s ->
case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
(# s1, b#, s# #) -> (# s1, (W# b#, W# s#) #)
let bitmapWords = [bitmap | size > 0]
- decodeBitmaps sfi relativePayloadOffset bitmapWords size
-decodeSmallBitmap _ sfi _ =
- error $
- "Unexpected StackFrameIter type: " ++ show sfi
-
--- | Decode `StackFrameIter` to `Closure`
-unpackStackFrameIter :: StackFrameIter -> IO Closure
-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
- STACK -> do
- let stack' = decodeStackToBoxes (StackSnapshot stackSnapshot#)
- pure $
- StackClosure
- { info = info,
- stack_size = stack_size',
- stack_dirty = stack_dirty',
- stack_marking = stack_marking',
- stack = stack'
- }
- _ -> error $ "Expected STACK closure, got " ++ show info
- where
- decodeStackToBoxes :: StackSnapshot -> [Box]
- decodeStackToBoxes s =
- StackFrameBox (stackHead s)
- : go (advanceStackFrameIter (stackHead s))
- where
- go :: Maybe StackFrameIter -> [Box]
- go Nothing = []
- go (Just sfi') = StackFrameBox sfi' : go (advanceStackFrameIter sfi')
-unpackStackFrameIter sfi@(SfiClosure {}) = do
- info <- getInfoTable sfi
- unpackStackFrameIter' info
+ decodeBitmaps stackSnapshot# index relativePayloadOffset bitmapWords size
+
+unpackStackFrame :: (StackSnapshot, WordOffset) -> IO StackFrame
+unpackStackFrame ((StackSnapshot stackSnapshot#), index) = do
+ info <- getInfoTableOnStack stackSnapshot# index
+ unpackStackFrame' info
where
- unpackStackFrameIter' :: StgInfoTable -> IO Closure
- unpackStackFrameIter' info =
+ unpackStackFrame' :: StgInfoTable -> IO StackFrame
+ unpackStackFrame' info =
case tipe info of
RET_BCO -> do
- bco' <- getClosure sfi offsetStgClosurePayload
+ bco' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgClosurePayload
-- The arguments begin directly after the payload's one element
- bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
+ bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
pure
RetBCO
- { info = info,
+ { info_tbl = info,
bco = bco',
bcoArgs = bcoArgs'
}
RET_SMALL -> do
- payload' <- decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
+ payload' <- decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
pure $
RetSmall
- { info = info,
- payload = payload'
+ { info_tbl = info,
+ stack_payload = payload'
}
RET_BIG -> do
- payload' <- decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
+ payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
pure $
RetBig
- { info = info,
- payload = payload'
+ { info_tbl = info,
+ stack_payload = payload'
}
RET_FUN -> do
- retFunType' <- getRetFunType sfi
- retFunSize' <- getWord sfi offsetStgRetFunFrameSize
- retFunFun' <- getClosure sfi offsetStgRetFunFrameFun
+ retFunType' <- getRetFunType stackSnapshot# index
+ retFunSize' <- getWord stackSnapshot# index offsetStgRetFunFrameSize
+ retFunFun' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgRetFunFrameFun
retFunPayload' <-
if retFunType' == ARG_GEN_BIG
- then decodeLargeBitmap getRetFunLargeBitmap# sfi offsetStgRetFunFramePayload
- else decodeSmallBitmap getRetFunSmallBitmap# sfi offsetStgRetFunFramePayload
+ then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
+ else decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
pure $
RetFun
- { info = info,
+ { info_tbl = info,
retFunType = retFunType',
retFunSize = retFunSize',
retFunFun = retFunFun',
retFunPayload = retFunPayload'
}
UPDATE_FRAME -> do
- updatee' <- getClosure sfi offsetStgUpdateFrameUpdatee
+ updatee' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgUpdateFrameUpdatee
pure $
UpdateFrame
- { info = info,
+ { info_tbl = info,
updatee = updatee'
}
CATCH_FRAME -> do
- exceptions_blocked' <- getWord sfi offsetStgCatchFrameExceptionsBlocked
- handler' <- getClosure sfi offsetStgCatchFrameHandler
+ exceptions_blocked' <- getWord stackSnapshot# index offsetStgCatchFrameExceptionsBlocked
+ handler' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgCatchFrameHandler
pure $
CatchFrame
- { info = info,
+ { info_tbl = info,
exceptions_blocked = exceptions_blocked',
handler = handler'
}
UNDERFLOW_FRAME -> do
- (StackSnapshot nextChunk') <- getUnderflowFrameNextChunk sfi
+ nextChunk' <- getUnderflowFrameNextChunk stackSnapshot# index
+ stackClosure <- decodeStack nextChunk'
pure $
UnderflowFrame
- { info = info,
- nextChunk = StackFrameBox $ SfiStackClosure nextChunk'
+ { info_tbl = info,
+ nextChunk = stackClosure
}
- STOP_FRAME -> pure $ StopFrame {info = info}
+ STOP_FRAME -> pure $ StopFrame {info_tbl = info}
ATOMICALLY_FRAME -> do
- atomicallyFrameCode' <- getClosure sfi offsetStgAtomicallyFrameCode
- result' <- getClosure sfi offsetStgAtomicallyFrameResult
+ atomicallyFrameCode' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgAtomicallyFrameCode
+ result' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgAtomicallyFrameResult
pure $
AtomicallyFrame
- { info = info,
+ { info_tbl = info,
atomicallyFrameCode = atomicallyFrameCode',
result = result'
}
CATCH_RETRY_FRAME -> do
- running_alt_code' <- getWord sfi offsetStgCatchRetryFrameRunningAltCode
- first_code' <- getClosure sfi offsetStgCatchRetryFrameRunningFirstCode
- alt_code' <- getClosure sfi offsetStgCatchRetryFrameAltCode
+ running_alt_code' <- getWord stackSnapshot# index offsetStgCatchRetryFrameRunningAltCode
+ first_code' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgCatchRetryFrameRunningFirstCode
+ alt_code' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgCatchRetryFrameAltCode
pure $
CatchRetryFrame
- { info = info,
+ { info_tbl = info,
running_alt_code = running_alt_code',
first_code = first_code',
alt_code = alt_code'
}
CATCH_STM_FRAME -> do
- catchFrameCode' <- getClosure sfi offsetStgCatchSTMFrameCode
- handler' <- getClosure sfi offsetStgCatchSTMFrameHandler
+ catchFrameCode' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgCatchSTMFrameCode
+ handler' <- getBoxedClosureData =<< getClosure stackSnapshot# index offsetStgCatchSTMFrameHandler
pure $
CatchStmFrame
- { info = info,
+ { info_tbl = info,
catchFrameCode = catchFrameCode',
handler = handler'
}
x -> error $ "Unexpected closure type on stack: " ++ show x
+getClosureDataFromHeapObject
+ :: a
+ -- ^ Heap object to decode.
+ -> IO Closure
+ -- ^ Heap representation of the closure.
+getClosureDataFromHeapObject x = do
+ case unpackClosure# x 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]
+ ]
+
+ infoTable <- peekItbl infoTablePtr
+ case tipe infoTable of
+ TSO -> pure $ UnsupportedClosure infoTable
+ STACK -> pure $ UnsupportedClosure infoTable
+ _ -> getClosureDataFromHeapRep heapRep infoTablePtr ptrList
+
+-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
+getBoxedClosureData :: Box -> IO Closure
+getBoxedClosureData (Box a) = getClosureDataFromHeapObject a
+
-- | Unbox 'Int#' from 'Int'
toInt# :: Int -> Int#
toInt# (I# i) = i
@@ -451,10 +433,36 @@ wordOffsetToWord# wo = intToWord# (fromIntegral wo)
--
-- Due to the use of `Box` this decoding is lazy. The first decoded closure is
-- the representation of the @StgStack@ itself.
-decodeStack :: StackSnapshot -> IO Closure
+decodeStack :: StackSnapshot -> IO StgStackClosure
decodeStack (StackSnapshot stack#) =
- unpackStackFrameIter $
- SfiStackClosure stack#
+ unpackStack stack#
+
+unpackStack :: StackSnapshot# -> IO StgStackClosure
+unpackStack stack# = do
+ info <- getInfoTableForStack stack#
+ (stack_size', stack_dirty', stack_marking') <- getStackFields stack#
+ case tipe info of
+ STACK -> do
+ let sfis = decodeStackToBoxes (StackSnapshot stack#)
+ stack' <- mapM unpackStackFrame sfis
+ pure $
+ StgStackClosure
+ { ssc_info = info,
+ ssc_stack_size = stack_size',
+ ssc_stack_dirty = stack_dirty',
+ ssc_stack_marking = stack_marking',
+ ssc_stack = stack'
+ }
+ _ -> error $ "Expected STACK closure, got " ++ show info
+ where
+ decodeStackToBoxes :: StackSnapshot -> [(StackSnapshot, WordOffset)]
+ decodeStackToBoxes s =
+ (stackHead s)
+ : go (advanceStackFrameIter (fst (stackHead s)) (snd (stackHead s)))
+ where
+ go :: Maybe (StackSnapshot, WordOffset) -> [(StackSnapshot, WordOffset)]
+ go Nothing = []
+ go (Just r) = r : go (advanceStackFrameIter (fst r) (snd r))
#else
module GHC.Exts.Stack.Decode where
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -471,14 +471,10 @@ instance Binary Heap.WhyBlocked
instance Binary Heap.TsoFlags
#endif
-#if MIN_VERSION_base(4,17,0)
-instance Binary Heap.RetFunType
-#endif
-
instance Binary Heap.StgInfoTable
instance Binary Heap.ClosureType
instance Binary Heap.PrimType
-instance Binary a => Binary (Heap.GenClosure a)
+instance (Binary a) => Binary (Heap.GenClosure a)
data Msg = forall a . (Binary a, Show a) => Msg (Message a)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9da88173bc5eafe65ee6f338116f60e45df4fd37
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9da88173bc5eafe65ee6f338116f60e45df4fd37
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/20230329/4b9606e5/attachment-0001.html>
More information about the ghc-commits
mailing list