diff options
Diffstat (limited to 'libraries/ghc-heap/GHC')
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/Closures.hs | 150 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc | 2 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Stack.hs | 37 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc | 130 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Stack/Decode.hs | 444 |
5 files changed, 761 insertions, 2 deletions
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs index a65eb9cbed..568c2bf2b1 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -15,9 +15,18 @@ module GHC.Exts.Heap.Closures ( , WhatNext(..) , WhyBlocked(..) , TsoFlags(..) + , RetFunType(..) , allClosures , closureSize + -- * Stack + , StgStackClosure + , GenStgStackClosure(..) + , StackFrame + , GenStackFrame(..) + , StackField + , GenStackField(..) + -- * Boxes , Box(..) , areBoxesEqual @@ -95,7 +104,6 @@ areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of ------------------------------------------------------------------------ -- Closures - type Closure = GenClosure Box -- | This is the representation of a Haskell value on the heap. It reflects @@ -354,8 +362,148 @@ data GenClosure b | UnsupportedClosure { info :: !StgInfoTable } + + -- | A primitive word from a bitmap encoded stack frame payload + -- + -- The type itself cannot be restored (i.e. it might represent a Word8# + -- or an Int#). + | UnknownTypeWordSizedPrimitive + { wordVal :: !Word } deriving (Show, Generic, Functor, Foldable, Traversable) +type StgStackClosure = GenStgStackClosure Box + +-- | A decoded @StgStack@ with `StackFrame`s +-- +-- Stack related data structures (`GenStgStackClosure`, `GenStackField`, +-- `GenStackFrame`) are defined separately from `GenClosure` as their related +-- functions are very different. Though, both are closures in the sense of RTS +-- structures, their decoding logic differs: While it's safe to keep a reference +-- to a heap closure, the garbage collector does not update references to stack +-- located closures. +-- +-- Additionally, stack frames don't appear outside of the stack. Thus, keeping +-- `GenStackFrame` and `GenClosure` separated, makes these types more precise +-- (in the sense what values to expect.) +data GenStgStackClosure b = GenStgStackClosure + { ssc_info :: !StgInfoTable + , ssc_stack_size :: !Word32 -- ^ stack size in *words* + , ssc_stack_dirty :: !Word8 -- ^ non-zero => dirty + , ssc_stack_marking :: !Word8 + , ssc_stack :: ![GenStackFrame b] + } + deriving (Foldable, Functor, Generic, Show, Traversable) + +type StackField = GenStackField Box + +-- | Bitmap-encoded payload on the stack +data GenStackField b + -- | A non-pointer field + = StackWord !Word + -- | A pointer field + | StackBox !b + deriving (Foldable, Functor, Generic, Show, Traversable) + +type StackFrame = GenStackFrame Box + +-- | A single stack frame +data GenStackFrame b = + UpdateFrame + { info_tbl :: !StgInfoTable + , updatee :: !b + } + + | CatchFrame + { info_tbl :: !StgInfoTable + , exceptions_blocked :: !Word + , handler :: !b + } + + | CatchStmFrame + { info_tbl :: !StgInfoTable + , catchFrameCode :: !b + , handler :: !b + } + + | CatchRetryFrame + { info_tbl :: !StgInfoTable + , running_alt_code :: !Word + , first_code :: !b + , alt_code :: !b + } + + | AtomicallyFrame + { info_tbl :: !StgInfoTable + , atomicallyFrameCode :: !b + , result :: !b + } + + | UnderflowFrame + { info_tbl :: !StgInfoTable + , nextChunk :: !(GenStgStackClosure b) + } + + | StopFrame + { info_tbl :: !StgInfoTable } + + | RetSmall + { info_tbl :: !StgInfoTable + , stack_payload :: ![GenStackField b] + } + + | RetBig + { info_tbl :: !StgInfoTable + , stack_payload :: ![GenStackField b] + } + + | RetFun + { info_tbl :: !StgInfoTable + , retFunType :: !RetFunType + , retFunSize :: !Word + , retFunFun :: !b + , retFunPayload :: ![GenStackField b] + } + + | RetBCO + { info_tbl :: !StgInfoTable + , bco :: !b -- ^ always a BCOClosure + , bcoArgs :: ![GenStackField b] + } + deriving (Foldable, Functor, Generic, Show, Traversable) + +-- | Fun types according to @FunTypes.h@ +-- This `Enum` must be aligned with the values in @FunTypes.h@. +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, Generic) data PrimType = PInt diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc index 667301157a..1610027b38 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc +++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc @@ -37,4 +37,4 @@ data StgInfoTable = StgInfoTable { tipe :: ClosureType, srtlen :: HalfWord, code :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) diff --git a/libraries/ghc-heap/GHC/Exts/Stack.hs b/libraries/ghc-heap/GHC/Exts/Stack.hs new file mode 100644 index 0000000000..90081a522a --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Stack.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +#if MIN_TOOL_VERSION_ghc(9,7,0) +{-# LANGUAGE RecordWildCards #-} + +module GHC.Exts.Stack + ( -- * Stack inspection + decodeStack, + stackFrameSize, + ) +where + +import GHC.Exts.Heap.Closures +import GHC.Exts.Stack.Constants +import GHC.Exts.Stack.Decode +import Prelude + +-- | Get the size of the `StackFrame` in words. +-- +-- Includes header and payload. Does not follow pointers. +stackFrameSize :: StackFrame -> Int +stackFrameSize (UpdateFrame {}) = sizeStgUpdateFrame +stackFrameSize (CatchFrame {}) = sizeStgCatchFrame +stackFrameSize (CatchStmFrame {}) = sizeStgCatchSTMFrame +stackFrameSize (CatchRetryFrame {}) = sizeStgCatchRetryFrame +stackFrameSize (AtomicallyFrame {}) = sizeStgAtomicallyFrame +stackFrameSize (RetSmall {..}) = sizeStgClosure + length stack_payload +stackFrameSize (RetBig {..}) = sizeStgClosure + length stack_payload +stackFrameSize (RetFun {..}) = sizeStgRetFunFrame + length retFunPayload +-- The one additional word is a pointer to the StgBCO in the closure's payload +stackFrameSize (RetBCO {..}) = sizeStgClosure + 1 + length bcoArgs +-- The one additional word is a pointer to the next stack chunk +stackFrameSize (UnderflowFrame {}) = sizeStgClosure + 1 +stackFrameSize _ = error "Unexpected stack frame type" + +#else +module GHC.Exts.Stack where +#endif diff --git a/libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc b/libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc new file mode 100644 index 0000000000..5f85d10358 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Exts.Stack.Constants where + +#if MIN_TOOL_VERSION_ghc(9,7,0) + +import Prelude + +#include "Rts.h" +#undef BLOCK_SIZE +#undef MBLOCK_SIZE +#undef BLOCKS_PER_MBLOCK +#include "DerivedConstants.h" + +newtype ByteOffset = ByteOffset { offsetInBytes :: Int } + deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord) + +newtype WordOffset = WordOffset { offsetInWords :: Int } + deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord) + +offsetStgCatchFrameHandler :: WordOffset +offsetStgCatchFrameHandler = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader) + +offsetStgCatchFrameExceptionsBlocked :: WordOffset +offsetStgCatchFrameExceptionsBlocked = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchFrame_exceptions_blocked) + (#size StgHeader) + +sizeStgCatchFrame :: Int +sizeStgCatchFrame = bytesToWords $ + (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader) + +offsetStgCatchSTMFrameCode :: WordOffset +offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader) + +offsetStgCatchSTMFrameHandler :: WordOffset +offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader) + +sizeStgCatchSTMFrame :: Int +sizeStgCatchSTMFrame = bytesToWords $ + (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader) + +offsetStgUpdateFrameUpdatee :: WordOffset +offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $ + (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader) + +sizeStgUpdateFrame :: Int +sizeStgUpdateFrame = bytesToWords $ + (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader) + +offsetStgAtomicallyFrameCode :: WordOffset +offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $ + (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader) + +offsetStgAtomicallyFrameResult :: WordOffset +offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $ + (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader) + +sizeStgAtomicallyFrame :: Int +sizeStgAtomicallyFrame = bytesToWords $ + (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader) + +offsetStgCatchRetryFrameRunningAltCode :: WordOffset +offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader) + +offsetStgCatchRetryFrameRunningFirstCode :: WordOffset +offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader) + +offsetStgCatchRetryFrameAltCode :: WordOffset +offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader) + +sizeStgCatchRetryFrame :: Int +sizeStgCatchRetryFrame = bytesToWords $ + (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader) + +offsetStgRetFunFrameSize :: WordOffset +-- StgRetFun has no header, but only a pointer to the info table at the beginning. +offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size) + +offsetStgRetFunFrameFun :: WordOffset +offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun) + +offsetStgRetFunFramePayload :: WordOffset +offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload) + +sizeStgRetFunFrame :: Int +sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun) + +offsetStgBCOFrameInstrs :: ByteOffset +offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader) + +offsetStgBCOFrameLiterals :: ByteOffset +offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader) + +offsetStgBCOFramePtrs :: ByteOffset +offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader) + +offsetStgBCOFrameArity :: ByteOffset +offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader) + +offsetStgBCOFrameSize :: ByteOffset +offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader) + +offsetStgClosurePayload :: WordOffset +offsetStgClosurePayload = byteOffsetToWordOffset $ + (#const OFFSET_StgClosure_payload) + (#size StgHeader) + +sizeStgClosure :: Int +sizeStgClosure = bytesToWords (#size StgHeader) + +byteOffsetToWordOffset :: ByteOffset -> WordOffset +byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger + +bytesToWords :: Int -> Int +bytesToWords b = + if b `mod` bytesInWord == 0 then + fromIntegral $ b `div` bytesInWord + else + error "Unexpected struct alignment!" + +bytesInWord :: Int +bytesInWord = (#const SIZEOF_VOID_P) + +#endif diff --git a/libraries/ghc-heap/GHC/Exts/Stack/Decode.hs b/libraries/ghc-heap/GHC/Exts/Stack/Decode.hs new file mode 100644 index 0000000000..9034db6de7 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Stack/Decode.hs @@ -0,0 +1,444 @@ +{-# LANGUAGE CPP #-} +#if MIN_TOOL_VERSION_ghc(9,7,0) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module GHC.Exts.Stack.Decode + ( decodeStack, + ) +where + +import Control.Monad +import Data.Bits +import Data.Maybe +import Foreign +import GHC.Exts +import GHC.Exts.Heap (Box (..)) +import GHC.Exts.Heap.ClosureTypes +import GHC.Exts.Heap.Closures + ( RetFunType (..), + StackFrame, + GenStackFrame (..), + StgStackClosure, + GenStgStackClosure (..), + StackField, + GenStackField(..) + ) +import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS) +import GHC.Exts.Heap.InfoTable +import GHC.Exts.Stack.Constants +import GHC.IO (IO (..)) +import GHC.Stack.CloneStack +import GHC.Word +import Prelude + +{- Note [Decoding the stack] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + +The stack is represented by a chain of StgStack closures. Each of these closures +is subject to garbage collection. I.e. they can be moved in memory (in a +simplified perspective) at any time. + +The array of closures inside an StgStack (that makeup the execution stack; the +stack frames) is moved as bare memory by the garbage collector. References +(pointers) to stack frames are not updated by the garbage collector. + +As the StgStack closure is moved as whole, the relative offsets inside it stay +the same. (Though, the absolute addresses change!) + +Decoding +======== + +Stack frames are defined by their `StackSnapshot#` (`StgStack*` in RTS) and +their relative offset. This tuple is described by `StackFrameLocation`. + +`StackFrame` is an ADT for decoded stack frames. Regarding payload and fields we +have to deal with three cases: + +- If the payload can only be a closure, we put it in a `Box` for later decoding + by the heap closure functions. + +- If the payload can either be a closure or a word-sized value (this happens for + bitmap-encoded payloads), we use a `StackField` which is a sum type to + represent either a `Word` or a `Box`. + +- Fields that are just simple (i.e. non-closure) values are decoded as such. + +The decoding happens in two phases: + +1. The whole stack is decoded into `StackFrameLocation`s. + +2. All `StackFrameLocation`s are decoded into `StackFrame`s. + +`StackSnapshot#` parameters are updated by the garbage collector and thus safe +to hand around. + +The head of the stack frame array has offset (index) 0. To traverse the stack +frames the latest stack frame's offset is incremented by the closure size. The +unit of the offset is machine words (32bit or 64bit.) + +IO +== + +Unfortunately, ghc-heap decodes `Closure`s in `IO`. This leads to `StackFrames` +also being decoded in `IO`, due to references to `Closure`s. + +Technical details +================= + +- All access to StgStack/StackSnapshot# closures is made through Cmm code. This + keeps the closure from being moved by the garbage collector during the + operation. + +- As StgStacks are mainly used in Cmm and C code, much of the decoding logic is + implemented in Cmm and C. It's just easier to reuse existing helper macros and + functions, than reinventing them in Haskell. + +- Offsets and sizes of closures are imported from DerivedConstants.h via HSC. + This keeps the code very portable. +-} + +foreign import prim "getUnderflowFrameNextChunkzh" + getUnderflowFrameNextChunk# :: + StackSnapshot# -> Word# -> StackSnapshot# + +getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> StackSnapshot +getUnderflowFrameNextChunk stackSnapshot# index = + StackSnapshot (getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index)) + +foreign import prim "getWordzh" + getWord# :: + StackSnapshot# -> Word# -> Word# + +getWord :: StackSnapshot# -> WordOffset -> Word +getWord stackSnapshot# index = + W# (getWord# stackSnapshot# (wordOffsetToWord# index)) + +foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word# + +getRetFunType :: StackSnapshot# -> WordOffset -> RetFunType +getRetFunType stackSnapshot# index = + toEnum . fromInteger . toInteger $ + W# (getRetFunType# stackSnapshot# (wordOffsetToWord# index)) + +-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@) +-- +-- The first two arguments identify the location of the frame on the stack. +-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size. +type LargeBitmapGetter = StackSnapshot# -> Word# -> (# Addr#, Word# #) + +foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter + +foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter + +foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter + +-- | Gets contents of a small bitmap (fitting in one @StgWord@) +-- +-- The first two arguments identify the location of the frame on the stack. +-- Returned is the bitmap and it's size. +type SmallBitmapGetter = StackSnapshot# -> Word# -> (# Word#, Word# #) + +foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter + +foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter + +foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr# + +foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# + +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable +getInfoTableOnStack stackSnapshot# index = + let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index)) + in peekItbl infoTablePtr + +getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable +getInfoTableForStack stackSnapshot# = + peekItbl $ + Ptr (getStackInfoTableAddr# stackSnapshot#) + +foreign import prim "getStackClosurezh" + getStackClosure# :: + StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Any #) + +foreign import prim "getStackFieldszh" + getStackFields# :: + StackSnapshot# -> (# Word32#, Word8#, Word8# #) + +getStackFields :: StackSnapshot# -> (Word32, Word8, Word8) +getStackFields stackSnapshot# = + case getStackFields# stackSnapshot# of + (# sSize#, sDirty#, sMarking# #) -> + (W32# sSize#, W8# sDirty#, W8# sMarking#) + +-- | `StackFrameLocation` of the top-most stack frame +stackHead :: StackSnapshot# -> StackFrameLocation +stackHead s# = (StackSnapshot s#, 0) -- GHC stacks are never empty + +-- | Advance to the next stack frame (if any) +-- +-- The last `Int#` in the result tuple is meant to be treated as bool +-- (has_next). +foreign import prim "advanceStackFrameLocationzh" + advanceStackFrameLocation# :: + StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #) + +-- | Advance to the next stack frame (if any) +advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation +advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) = + let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index) + in if I# hasNext > 0 + then Just (StackSnapshot s', primWordToWordOffset i') + else Nothing + where + primWordToWordOffset :: Word# -> WordOffset + primWordToWordOffset w# = fromIntegral (W# w#) + +getClosureBox :: StackSnapshot# -> WordOffset -> IO Box +getClosureBox stackSnapshot# index = + -- Beware! We have to put ptr into a Box immediately. Otherwise, the garbage + -- collector might move the referenced closure, without updating our reference + -- (pointer) to it. + IO $ \s -> + case getStackClosure# + stackSnapshot# + (wordOffsetToWord# index) + s of + (# s1, ptr #) -> + (# s1, Box ptr #) + +-- | Representation of @StgLargeBitmap@ (RTS) +data LargeBitmap = LargeBitmap + { largeBitmapSize :: Word, + largebitmapWords :: Ptr Word + } + +-- | Is a bitmap entry a closure pointer or a primitive non-pointer? +data Pointerness = Pointer | NonPointer + deriving (Show) + +decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField] +decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do + let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of + (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#) + bitmapWords <- largeBitmapToList largeBitmap + decodeBitmaps + stackSnapshot# + (index + relativePayloadOffset) + (bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords) + where + largeBitmapToList :: LargeBitmap -> IO [Word] + largeBitmapToList LargeBitmap {..} = + cWordArrayToList largebitmapWords $ + (usedBitmapWords . fromIntegral) largeBitmapSize + + cWordArrayToList :: Ptr Word -> Int -> IO [Word] + cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)] + + usedBitmapWords :: Int -> Int + usedBitmapWords 0 = error "Invalid large bitmap size 0." + usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1 + + bitmapWordsPointerness :: Word -> [Word] -> [Pointerness] + bitmapWordsPointerness size _ | size <= 0 = [] + bitmapWordsPointerness _ [] = [] + bitmapWordsPointerness size (w : wds) = + bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w + ++ bitmapWordsPointerness (size - fromIntegral wORD_SIZE_IN_BITS) wds + +bitmapWordPointerness :: Word -> Word -> [Pointerness] +bitmapWordPointerness 0 _ = [] +bitmapWordPointerness bSize bitmapWord = + ( if (bitmapWord .&. 1) /= 0 + then NonPointer + else Pointer + ) + : bitmapWordPointerness + (bSize - 1) + (bitmapWord `shiftR` 1) + +decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> IO [StackField] +decodeBitmaps stack# index ps = + zipWithM toPayload ps [index ..] + where + toPayload :: Pointerness -> WordOffset -> IO StackField + toPayload p i = case p of + NonPointer -> + pure $ StackWord (getWord stack# i) + Pointer -> StackBox <$> getClosureBox stack# i + +decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField] +decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = + let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of + (# b#, s# #) -> (W# b#, W# s#) + in decodeBitmaps + stackSnapshot# + (index + relativePayloadOffset) + (bitmapWordPointerness size bitmap) + +unpackStackFrame :: StackFrameLocation -> IO StackFrame +unpackStackFrame (StackSnapshot stackSnapshot#, index) = do + info <- getInfoTableOnStack stackSnapshot# index + unpackStackFrame' info + where + unpackStackFrame' :: StgInfoTable -> IO StackFrame + unpackStackFrame' info = + case tipe info of + RET_BCO -> do + bco' <- getClosureBox stackSnapshot# (index + offsetStgClosurePayload) + -- The arguments begin directly after the payload's one element + bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) + pure + RetBCO + { info_tbl = info, + bco = bco', + bcoArgs = bcoArgs' + } + RET_SMALL -> do + payload' <- decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload + pure $ + RetSmall + { info_tbl = info, + stack_payload = payload' + } + RET_BIG -> do + payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload + pure $ + RetBig + { info_tbl = info, + stack_payload = payload' + } + RET_FUN -> do + let retFunType' = getRetFunType stackSnapshot# index + retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize) + retFunFun' <- getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun) + retFunPayload' <- + if retFunType' == ARG_GEN_BIG + then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload + else decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload + pure $ + RetFun + { info_tbl = info, + retFunType = retFunType', + retFunSize = retFunSize', + retFunFun = retFunFun', + retFunPayload = retFunPayload' + } + UPDATE_FRAME -> do + updatee' <- getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) + pure $ + UpdateFrame + { info_tbl = info, + updatee = updatee' + } + CATCH_FRAME -> do + let exceptions_blocked' = getWord stackSnapshot# (index + offsetStgCatchFrameExceptionsBlocked) + handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) + pure $ + CatchFrame + { info_tbl = info, + exceptions_blocked = exceptions_blocked', + handler = handler' + } + UNDERFLOW_FRAME -> do + let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index + stackClosure <- decodeStack nextChunk' + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + STOP_FRAME -> pure $ StopFrame {info_tbl = info} + ATOMICALLY_FRAME -> do + atomicallyFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) + result' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) + pure $ + AtomicallyFrame + { info_tbl = info, + atomicallyFrameCode = atomicallyFrameCode', + result = result' + } + CATCH_RETRY_FRAME -> do + let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode) + first_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) + alt_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) + pure $ + CatchRetryFrame + { info_tbl = info, + running_alt_code = running_alt_code', + first_code = first_code', + alt_code = alt_code' + } + CATCH_STM_FRAME -> do + catchFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) + handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) + pure $ + CatchStmFrame + { info_tbl = info, + catchFrameCode = catchFrameCode', + handler = handler' + } + x -> error $ "Unexpected closure type on stack: " ++ show x + +-- | Unbox 'Int#' from 'Int' +toInt# :: Int -> Int# +toInt# (I# i) = i + +-- | Convert `Int` to `Word#` +intToWord# :: Int -> Word# +intToWord# i = int2Word# (toInt# i) + +wordOffsetToWord# :: WordOffset -> Word# +wordOffsetToWord# wo = intToWord# (fromIntegral wo) + +-- | Location of a stackframe on the stack +-- +-- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom +-- of the stack. +type StackFrameLocation = (StackSnapshot, WordOffset) + +-- | Decode `StackSnapshot` to a `StgStackClosure` +-- +-- The return value is the representation of the @StgStack@ itself. +-- +-- See /Note [Decoding the stack]/. +decodeStack :: StackSnapshot -> IO StgStackClosure +decodeStack (StackSnapshot stack#) = do + info <- getInfoTableForStack stack# + case tipe info of + STACK -> do + let (stack_size', stack_dirty', stack_marking') = getStackFields stack# + sfls = stackFrameLocations stack# + stack' <- mapM unpackStackFrame sfls + pure $ + GenStgStackClosure + { 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 + stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] + stackFrameLocations s# = + stackHead s# + : go (advanceStackFrameLocation (stackHead s#)) + where + go :: Maybe StackFrameLocation -> [StackFrameLocation] + go Nothing = [] + go (Just r) = r : go (advanceStackFrameLocation r) + +#else +module GHC.Exts.Stack.Decode where +#endif |