ghc-heap 9.8.1 → 9.10.1

raw patch · 10 files changed

+1055/−6 lines, 10 filesdep +ghc-internalPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-internal

API changes (from Hackage documentation)

Files

• GHC/Exts/Heap.hs +3/−2
• GHC/Exts/Heap/ClosureTypes.hs +4/−0
• GHC/Exts/Heap/Closures.hs +110/−1
• GHC/Exts/Heap/InfoTable/Types.hsc +1/−1
• GHC/Exts/Stack.hs +37/−0
• GHC/Exts/Stack/Constants.hsc +126/−0
• GHC/Exts/Stack/Decode.hs +431/−0
• cbits/Stack.cmm +182/−0
• cbits/Stack_c.c +151/−0
• ghc-heap.cabal +10/−2

@@ -317,8 +317,9 @@             _ -> fail $ "Expected at least 3 ptrs to MVAR, found "                         ++ show (length pts) -        BLOCKING_QUEUE ->-            pure $ OtherClosure itbl pts rawHeapWords+        BLOCKING_QUEUE+          | [_link, bh, _owner, msg] <- pts ->+            pure $ BlockingQueueClosure itbl _link bh _owner msg          WEAK -> case pts of             pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure

@@ -7,6 +7,9 @@     ) where  import Prelude -- See note [Why do we import Prelude here?]+#if __GLASGOW_HASKELL__ >= 909+import GHC.Internal.ClosureTypes+#else import GHC.Generics  {- ---------------------------------------------@@ -83,6 +86,7 @@     | CONTINUATION     | N_CLOSURE_TYPES  deriving (Enum, Eq, Ord, Show, Generic)+#endif  -- | Return the size of the closures header in words closureTypeHeaderSize :: ClosureType -> Int

@@ -18,6 +18,14 @@     , allClosures     , closureSize +    -- * Stack+    , StgStackClosure+    , GenStgStackClosure(..)+    , StackFrame+    , GenStackFrame(..)+    , StackField+    , GenStackField(..)+     -- * Boxes     , Box(..)     , areBoxesEqual@@ -95,7 +103,6 @@  ------------------------------------------------------------------------ -- Closures- type Closure = GenClosure Box  -- | This is the representation of a Haskell value on the heap. It reflects@@ -354,8 +361,110 @@   | 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           :: ![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+      , 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+      , 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)  data PrimType   = PInt

@@ -37,4 +37,4 @@    tipe   :: ClosureType,    srtlen :: HalfWord,    code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE-  } deriving (Show, Generic)+  } deriving (Eq, Show, Generic)

@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+#if MIN_TOOL_VERSION_ghc(9,9,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

@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module GHC.Exts.Stack.Constants where++#if MIN_TOOL_VERSION_ghc(9,9,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)++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

@@ -0,0 +1,431 @@+{-# LANGUAGE CPP #-}+#if MIN_TOOL_VERSION_ghc(9,9,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+  ( 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.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 "isArgGenBigRetFunTypezh" isArgGenBigRetFunType# :: StackSnapshot# -> Word# -> Int#++isArgGenBigRetFunType :: StackSnapshot# -> WordOffset -> Bool+isArgGenBigRetFunType stackSnapshot# index =+  I# (isArgGenBigRetFunType# stackSnapshot# (wordOffsetToWord# index)) > 0++-- | 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# ->  Any++foreign import prim "getStackFieldszh"+  getStackFields# ::+    StackSnapshot# -> Word32#++getStackFields :: StackSnapshot# -> Word32+getStackFields stackSnapshot# =+  case getStackFields# stackSnapshot# of+    sSize# -> W32# sSize#++-- | `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 -> Box+getClosureBox stackSnapshot# index =+        case getStackClosure# stackSnapshot# (wordOffsetToWord# index) of+          -- c needs to be strictly evaluated, otherwise a thunk gets boxed (and+          -- will later be decoded as such)+          !c -> Box c++-- | 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+  pure $ 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] -> [StackField]+decodeBitmaps stack# index ps =+  zipWith toPayload ps [index ..]+  where+    toPayload :: Pointerness -> WordOffset -> StackField+    toPayload p i = case p of+      NonPointer -> StackWord (getWord stack# i)+      Pointer -> StackBox (getClosureBox stack# i)++decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> [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+          let 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 ->+          let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload+          in+            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 retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize)+              retFunFun' = getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun)+          retFunPayload' <-+            if isArgGenBigRetFunType stackSnapshot# index == True+              then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload+              else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload+          pure $+            RetFun+              { info_tbl = info,+                retFunSize = retFunSize',+                retFunFun = retFunFun',+                retFunPayload = retFunPayload'+              }+        UPDATE_FRAME ->+          let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)+          in+            pure $+              UpdateFrame+                { info_tbl = info,+                  updatee = updatee'+                }+        CATCH_FRAME -> do+          let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)+          pure $+            CatchFrame+              { info_tbl = info,+                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+          let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)+              result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)+          pure $+            AtomicallyFrame+              { info_tbl = info,+                atomicallyFrameCode = atomicallyFrameCode',+                result = result'+              }+        CATCH_RETRY_FRAME ->+          let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode)+              first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)+              alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)+          in+            pure $+              CatchRetryFrame+                { info_tbl = info,+                  running_alt_code = running_alt_code',+                  first_code = first_code',+                  alt_code = alt_code'+                }+        CATCH_STM_FRAME ->+          let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)+              handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)+          in+            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' = getStackFields stack#+          sfls = stackFrameLocations stack#+      stack' <- mapM unpackStackFrame sfls+      pure $+        GenStgStackClosure+          { ssc_info = info,+            ssc_stack_size = stack_size',+            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

@@ -0,0 +1,182 @@+// Uncomment to enable assertions during development+// #define DEBUG 1++#include "Cmm.h"++// StgStack_marking was not available in the Stage0 compiler at the time of+// writing. Because, it has been added to derivedConstants when Stack.cmm was+// developed.+#if defined(StgStack_marking)++// Returns the next stackframe's StgStack* and offset in it. And, an indicator+// if this frame is the last one (`hasNext` bit.)+// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)+advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {+  W_ frameSize;+  (frameSize) = ccall stackFrameSize(stack, offsetWords);++  P_ nextClosurePtr;+  nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize));++  P_ stackArrayPtr;+  stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack;++  P_ stackBottom;+  W_ stackSize, stackSizeInBytes;+  stackSize = TO_W_(StgStack_stack_size(stack));+  stackSizeInBytes = WDS(stackSize);+  stackBottom = stackSizeInBytes + stackArrayPtr;++  P_ newStack;+  W_ newOffsetWords, hasNext;+  if(nextClosurePtr < stackBottom) (likely: True) {+    newStack = stack;+    newOffsetWords = offsetWords + frameSize;+    hasNext = 1;+  } else {+    P_ underflowFrameStack;+    (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords);+    if (underflowFrameStack == NULL) (likely: True) {+      newStack = NULL;+      newOffsetWords = NULL;+      hasNext = NULL;+    } else {+      newStack = underflowFrameStack;+      newOffsetWords = NULL;+      hasNext = 1;+    }+  }++  return (newStack, newOffsetWords, hasNext);+}++// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords)+getSmallBitmapzh(P_ stack, W_ offsetWords) {+  P_ c;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  W_ bitmap, size;+  (bitmap) = ccall getBitmapWord(c);+  (size) = ccall getBitmapSize(c);++  return (bitmap, size);+}+++// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords)+getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) {+  P_ c;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  W_ bitmap, size, specialType;+  (bitmap) = ccall getRetFunBitmapWord(c);+  (size) = ccall getRetFunBitmapSize(c);++  return (bitmap, size);+}++// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords)+getLargeBitmapzh(P_ stack, W_ offsetWords) {+  P_ c, words;+  W_ size;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  (words) = ccall getLargeBitmap(MyCapability(), c);+  (size) = ccall getLargeBitmapSize(c);++  return (words, size);+}++// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords)+getBCOLargeBitmapzh(P_ stack, W_ offsetWords) {+  P_ c, words;+  W_ size;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  (words) = ccall getBCOLargeBitmap(MyCapability(), c);+  (size) = ccall getBCOLargeBitmapSize(c);++  return (words, size);+}++// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords)+getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) {+  P_ c, words;+  W_ size;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  (words) = ccall getRetFunLargeBitmap(MyCapability(), c);+  (size) = ccall getRetFunSize(c);++  return (words, size);+}++// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords)+getWordzh(P_ stack, W_ offsetWords) {+  P_ wordAddr;+  wordAddr = (StgStack_sp(stack) + WDS(offsetWords));+  return (W_[wordAddr]);+}++// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords)+getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) {+  P_ closurePtr;+  closurePtr = (StgStack_sp(stack) + WDS(offsetWords));+  ASSERT(LOOKS_LIKE_CLOURE_PTR(closurePtr));++  P_ next_chunk;+  (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);+  ASSERT(LOOKS_LIKE_CLOURE_PTR(next_chunk));+  return (next_chunk);+}++// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords)+isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {+  P_ c;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  W_ type;+  (type) = ccall isArgGenBigRetFunType(c);+  return (type);+}++// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords)+getInfoTableAddrzh(P_ stack, W_ offsetWords) {+  P_ p, info;+  p = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));+  info = %GET_STD_INFO(UNTAG(p));++  return (info);+}++// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)+getStackInfoTableAddrzh(P_ stack) {+  P_ info;+  info = %GET_STD_INFO(UNTAG(stack));+  return (info);+}++// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords)+getStackClosurezh(P_ stack, W_ offsetWords) {+  P_ ptr;+  ptr = StgStack_sp(stack) + WDS(offsetWords);++  P_ closure;+  (closure) = ccall getStackClosure(ptr);+  return (closure);+}++// (bits32) getStackFieldszh(StgStack* stack)+getStackFieldszh(P_ stack){+  bits32 size;+  size = StgStack_stack_size(stack);+  return (size);+}+#endif

@@ -0,0 +1,151 @@+#include "MachDeps.h"+#include "Rts.h"+#include "RtsAPI.h"+#include "rts/Messages.h"+#include "rts/Types.h"+#include "rts/storage/ClosureTypes.h"+#include "rts/storage/Closures.h"+#include "rts/storage/FunTypes.h"+#include "rts/storage/InfoTables.h"++StgWord stackFrameSize(StgStack *stack, StgWord offset) {+  StgClosure *c = (StgClosure *)stack->sp + offset;+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));+  return stack_frame_sizeW(c);+}++StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {+  StgClosure *frame = (StgClosure *)stack->sp + offset;+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));+  const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);++  if (info->i.type == UNDERFLOW_FRAME) {+    return ((StgUnderflowFrame *)frame)->next_chunk;+  } else {+    return NULL;+  }+}++// Only exists to make the get_itbl macro available in Haskell code (via FFI).+const StgInfoTable *getItbl(StgClosure *closure) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));+  return get_itbl(closure);+};++StgWord getBitmapSize(StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  const StgInfoTable *info = get_itbl(c);+  StgWord bitmap = info->layout.bitmap;+  return BITMAP_SIZE(bitmap);+}++StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));++  const StgFunInfoTable *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 getBitmapWord(StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  const StgInfoTable *info = get_itbl(c);+  StgWord bitmap = info->layout.bitmap;+  StgWord bitmapWord = BITMAP_BITS(bitmap);+  return bitmapWord;+}++StgWord getRetFunBitmapWord(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_BITS(fun_info->f.b.bitmap);+  case ARG_GEN_BIG:+    // Cannot do more than warn and exit.+    errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun);+    stg_exit(EXIT_INTERNAL_ERROR);+  default:+    return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);+  }+}++StgWord getLargeBitmapSize(StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  const StgInfoTable *info = get_itbl(c);+  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);+  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));++  StgBCO *bco = (StgBCO *)*c->payload;++  return BCO_BITMAP_SIZE(bco);+}++StgWord *getLargeBitmap(Capability *cap, StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));+  const StgInfoTable *info = get_itbl(c);+  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);++  return bitmap->bitmap;+}++StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));++  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);++  return bitmap->bitmap;+}++StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  StgBCO *bco = (StgBCO *)*c->payload;+  StgLargeBitmap *bitmap = BCO_BITMAP(bco);++  return bitmap->bitmap;+}++StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {+  return frame->next_chunk;+}++StgWord isArgGenBigRetFunType(StgRetFun *ret_fun) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));++  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  return fun_info->f.fun_type == ARG_GEN_BIG;+}++StgClosure *getStackClosure(StgClosure **c) { return *c; }

@@ -1,6 +1,6 @@ cabal-version:  3.0 name:           ghc-heap-version:        9.8.1+version:        9.10.1 license:        BSD-3-Clause license-file:   LICENSE maintainer:     libraries@haskell.org@@ -25,11 +25,16 @@   build-depends:    base             >= 4.9.0 && < 5.0                   , ghc-prim         > 0.2 && < 0.12                   , rts              == 1.0.*-                  , containers       >= 0.6.2.1 && < 0.7+                  , containers       >= 0.6.2.1 && < 0.8 +  if impl(ghc >= 9.9)+    build-depends:  ghc-internal     >= 9.1001 && < 9.1002+   ghc-options:      -Wall   if !os(ghcjs)     cmm-sources:      cbits/HeapPrim.cmm+                      cbits/Stack.cmm+  c-sources:        cbits/Stack_c.c    default-extensions: NoImplicitPrelude @@ -48,3 +53,6 @@                     GHC.Exts.Heap.ProfInfo.PeekProfInfo                     GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled                     GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled+                    GHC.Exts.Stack.Constants+                    GHC.Exts.Stack+                    GHC.Exts.Stack.Decode