{-# 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# -> WordOffset -> StackSnapshot
getUnderflowFrameNextChunk StackSnapshot#
stackSnapshot# WordOffset
index =
  StackSnapshot# -> StackSnapshot
StackSnapshot (StackSnapshot# -> Word# -> StackSnapshot#
getUnderflowFrameNextChunk# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index))

foreign import prim "getWordzh"
  getWord# ::
    StackSnapshot# -> Word# -> Word#

getWord :: StackSnapshot# -> WordOffset -> Word
getWord :: StackSnapshot# -> WordOffset -> Word
getWord StackSnapshot#
stackSnapshot# WordOffset
index =
  Word# -> Word
W# (StackSnapshot# -> Word# -> Word#
getWord# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index))

foreign import prim "isArgGenBigRetFunTypezh" isArgGenBigRetFunType# :: StackSnapshot# -> Word# -> Int#

isArgGenBigRetFunType :: StackSnapshot# -> WordOffset -> Bool
isArgGenBigRetFunType :: StackSnapshot# -> WordOffset -> Bool
isArgGenBigRetFunType StackSnapshot#
stackSnapshot# WordOffset
index =
  Int# -> Int
I# (StackSnapshot# -> Word# -> Int#
isArgGenBigRetFunType# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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# -> WordOffset -> IO StgInfoTable
getInfoTableOnStack StackSnapshot#
stackSnapshot# WordOffset
index =
  let infoTablePtr :: Ptr StgInfoTable
infoTablePtr = Addr# -> Ptr StgInfoTable
forall a. Addr# -> Ptr a
Ptr (StackSnapshot# -> Word# -> Addr#
getInfoTableAddr# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index))
   in Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
infoTablePtr

getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
getInfoTableForStack StackSnapshot#
stackSnapshot# =
  Ptr StgInfoTable -> IO StgInfoTable
peekItbl (Ptr StgInfoTable -> IO StgInfoTable)
-> Ptr StgInfoTable -> IO StgInfoTable
forall a b. (a -> b) -> a -> b
$
    Addr# -> Ptr StgInfoTable
forall a. Addr# -> Ptr a
Ptr (StackSnapshot# -> Addr#
getStackInfoTableAddr# StackSnapshot#
stackSnapshot#)

foreign import prim "getStackClosurezh"
  getStackClosure# ::
    StackSnapshot# -> Word# ->  Any

foreign import prim "getStackFieldszh"
  getStackFields# ::
    StackSnapshot# -> Word32#

getStackFields :: StackSnapshot# -> Word32
getStackFields :: StackSnapshot# -> Word32
getStackFields StackSnapshot#
stackSnapshot# =
  case StackSnapshot# -> Word32#
getStackFields# StackSnapshot#
stackSnapshot# of
    Word32#
sSize# -> Word32# -> Word32
W32# Word32#
sSize#

-- | `StackFrameLocation` of the top-most stack frame
stackHead :: StackSnapshot# -> StackFrameLocation
stackHead :: StackSnapshot# -> StackFrameLocation
stackHead StackSnapshot#
s# = (StackSnapshot# -> StackSnapshot
StackSnapshot StackSnapshot#
s#, WordOffset
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 :: StackFrameLocation -> Maybe StackFrameLocation
advanceStackFrameLocation ((StackSnapshot StackSnapshot#
stackSnapshot#), WordOffset
index) =
  let !(# StackSnapshot#
s', Word#
i', Int#
hasNext #) = StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
advanceStackFrameLocation# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index)
   in if Int# -> Int
I# Int#
hasNext Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then StackFrameLocation -> Maybe StackFrameLocation
forall a. a -> Maybe a
Just (StackSnapshot# -> StackSnapshot
StackSnapshot StackSnapshot#
s', Word# -> WordOffset
primWordToWordOffset Word#
i')
        else Maybe StackFrameLocation
forall a. Maybe a
Nothing
  where
    primWordToWordOffset :: Word# -> WordOffset
    primWordToWordOffset :: Word# -> WordOffset
primWordToWordOffset Word#
w# = Word -> WordOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word# -> Word
W# Word#
w#)

getClosureBox :: StackSnapshot# -> WordOffset -> Box
getClosureBox :: StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# WordOffset
index =
        case StackSnapshot# -> Word# -> Any
getStackClosure# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index) of
          -- c needs to be strictly evaluated, otherwise a thunk gets boxed (and
          -- will later be decoded as such)
          !Any
c -> Any -> Box
Box Any
c

-- | Representation of @StgLargeBitmap@ (RTS)
data LargeBitmap = LargeBitmap
  { LargeBitmap -> Word
largeBitmapSize :: Word,
    LargeBitmap -> Ptr Word
largebitmapWords :: Ptr Word
  }

-- | Is a bitmap entry a closure pointer or a primitive non-pointer?
data Pointerness = Pointer | NonPointer
  deriving (Int -> Pointerness -> ShowS
[Pointerness] -> ShowS
Pointerness -> String
(Int -> Pointerness -> ShowS)
-> (Pointerness -> String)
-> ([Pointerness] -> ShowS)
-> Show Pointerness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pointerness -> ShowS
showsPrec :: Int -> Pointerness -> ShowS
$cshow :: Pointerness -> String
show :: Pointerness -> String
$cshowList :: [Pointerness] -> ShowS
showList :: [Pointerness] -> ShowS
Show)

decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
decodeLargeBitmap :: LargeBitmapGetter
-> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
decodeLargeBitmap LargeBitmapGetter
getterFun# StackSnapshot#
stackSnapshot# WordOffset
index WordOffset
relativePayloadOffset = do
  let largeBitmap :: LargeBitmap
largeBitmap = case LargeBitmapGetter
getterFun# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index) of
        (# Addr#
wordsAddr#, Word#
size# #) -> Word -> Ptr Word -> LargeBitmap
LargeBitmap (Word# -> Word
W# Word#
size#) (Addr# -> Ptr Word
forall a. Addr# -> Ptr a
Ptr Addr#
wordsAddr#)
  bitmapWords <- LargeBitmap -> IO [Word]
largeBitmapToList LargeBitmap
largeBitmap
  pure $ decodeBitmaps
          stackSnapshot#
          (index + relativePayloadOffset)
          (bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords)
  where
    largeBitmapToList :: LargeBitmap -> IO [Word]
    largeBitmapToList :: LargeBitmap -> IO [Word]
largeBitmapToList LargeBitmap {Word
Ptr Word
largeBitmapSize :: LargeBitmap -> Word
largebitmapWords :: LargeBitmap -> Ptr Word
largeBitmapSize :: Word
largebitmapWords :: Ptr Word
..} =
      Ptr Word -> Int -> IO [Word]
cWordArrayToList Ptr Word
largebitmapWords (Int -> IO [Word]) -> Int -> IO [Word]
forall a b. (a -> b) -> a -> b
$
        (Int -> Int
usedBitmapWords (Int -> Int) -> (Word -> Int) -> Word -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Word
largeBitmapSize

    cWordArrayToList :: Ptr Word -> Int -> IO [Word]
    cWordArrayToList :: Ptr Word -> Int -> IO [Word]
cWordArrayToList Ptr Word
ptr Int
size = (Int -> IO Word) -> [Int] -> IO [Word]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Ptr Word -> Int -> IO Word
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word
ptr) [Int
0 .. (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]

    usedBitmapWords :: Int -> Int
    usedBitmapWords :: Int -> Int
usedBitmapWords Int
0 = String -> Int
forall a. HasCallStack => String -> a
error String
"Invalid large bitmap size 0."
    usedBitmapWords Int
size = (Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wORD_SIZE_IN_BITS) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

    bitmapWordsPointerness :: Word -> [Word] -> [Pointerness]
    bitmapWordsPointerness :: Word -> [Word] -> [Pointerness]
bitmapWordsPointerness Word
size [Word]
_ | Word
size Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
0 = []
    bitmapWordsPointerness Word
_ [] = []
    bitmapWordsPointerness Word
size (Word
w : [Word]
wds) =
      Word -> Word -> [Pointerness]
bitmapWordPointerness (Word -> Word -> Word
forall a. Ord a => a -> a -> a
min Word
size (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wORD_SIZE_IN_BITS)) Word
w
        [Pointerness] -> [Pointerness] -> [Pointerness]
forall a. [a] -> [a] -> [a]
++ Word -> [Word] -> [Pointerness]
bitmapWordsPointerness (Word
size Word -> Word -> Word
forall a. Num a => a -> a -> a
- Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wORD_SIZE_IN_BITS) [Word]
wds

bitmapWordPointerness :: Word -> Word -> [Pointerness]
bitmapWordPointerness :: Word -> Word -> [Pointerness]
bitmapWordPointerness Word
0 Word
_ = []
bitmapWordPointerness Word
bSize Word
bitmapWord =
  ( if (Word
bitmapWord Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
1) Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
0
      then Pointerness
NonPointer
      else Pointerness
Pointer
  )
    Pointerness -> [Pointerness] -> [Pointerness]
forall a. a -> [a] -> [a]
: Word -> Word -> [Pointerness]
bitmapWordPointerness
      (Word
bSize Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1)
      (Word
bitmapWord Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)

decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> [StackField]
decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> [StackField]
decodeBitmaps StackSnapshot#
stack# WordOffset
index [Pointerness]
ps =
  (Pointerness -> WordOffset -> StackField)
-> [Pointerness] -> [WordOffset] -> [StackField]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pointerness -> WordOffset -> StackField
toPayload [Pointerness]
ps [WordOffset
index ..]
  where
    toPayload :: Pointerness -> WordOffset -> StackField
    toPayload :: Pointerness -> WordOffset -> StackField
toPayload Pointerness
p WordOffset
i = case Pointerness
p of
      Pointerness
NonPointer -> Word -> StackField
forall b. Word -> GenStackField b
StackWord (StackSnapshot# -> WordOffset -> Word
getWord StackSnapshot#
stack# WordOffset
i)
      Pointerness
Pointer -> Box -> StackField
forall b. b -> GenStackField b
StackBox (StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stack# WordOffset
i)

decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> [StackField]
decodeSmallBitmap :: SmallBitmapGetter
-> StackSnapshot# -> WordOffset -> WordOffset -> [StackField]
decodeSmallBitmap SmallBitmapGetter
getterFun# StackSnapshot#
stackSnapshot# WordOffset
index WordOffset
relativePayloadOffset =
  let (Word
bitmap, Word
size) = case SmallBitmapGetter
getterFun# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index) of
        (# Word#
b#, Word#
s# #) -> (Word# -> Word
W# Word#
b#, Word# -> Word
W# Word#
s#)
  in StackSnapshot# -> WordOffset -> [Pointerness] -> [StackField]
decodeBitmaps
      StackSnapshot#
stackSnapshot#
      (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
relativePayloadOffset)
      (Word -> Word -> [Pointerness]
bitmapWordPointerness Word
size Word
bitmap)

unpackStackFrame :: StackFrameLocation -> IO StackFrame
unpackStackFrame :: StackFrameLocation -> IO StackFrame
unpackStackFrame (StackSnapshot StackSnapshot#
stackSnapshot#, WordOffset
index) = do
  info <- StackSnapshot# -> WordOffset -> IO StgInfoTable
getInfoTableOnStack StackSnapshot#
stackSnapshot# WordOffset
index
  unpackStackFrame' info
  where
    unpackStackFrame' :: StgInfoTable -> IO StackFrame
    unpackStackFrame' :: StgInfoTable -> IO StackFrame
unpackStackFrame' StgInfoTable
info =
      case StgInfoTable -> ClosureType
tipe StgInfoTable
info of
        ClosureType
RET_BCO -> do
          let bco' :: Box
bco' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgClosurePayload)
          -- The arguments begin directly after the payload's one element
          bcoArgs' <- LargeBitmapGetter
-> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
decodeLargeBitmap LargeBitmapGetter
getBCOLargeBitmap# StackSnapshot#
stackSnapshot# WordOffset
index (WordOffset
offsetStgClosurePayload WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
1)
          pure
            RetBCO
              { info_tbl = info,
                bco = bco',
                bcoArgs = bcoArgs'
              }
        ClosureType
RET_SMALL ->
          let payload' :: [StackField]
payload' = SmallBitmapGetter
-> StackSnapshot# -> WordOffset -> WordOffset -> [StackField]
decodeSmallBitmap SmallBitmapGetter
getSmallBitmap# StackSnapshot#
stackSnapshot# WordOffset
index WordOffset
offsetStgClosurePayload
          in
            StackFrame -> IO StackFrame
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackFrame -> IO StackFrame) -> StackFrame -> IO StackFrame
forall a b. (a -> b) -> a -> b
$
              RetSmall
                { info_tbl :: StgInfoTable
info_tbl = StgInfoTable
info,
                  stack_payload :: [StackField]
stack_payload = [StackField]
payload'
                }
        ClosureType
RET_BIG -> do
          payload' <- LargeBitmapGetter
-> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
decodeLargeBitmap LargeBitmapGetter
getLargeBitmap# StackSnapshot#
stackSnapshot# WordOffset
index WordOffset
offsetStgClosurePayload
          pure $
            RetBig
              { info_tbl = info,
                stack_payload = payload'
              }
        ClosureType
RET_FUN -> do
          let retFunSize' :: Word
retFunSize' = StackSnapshot# -> WordOffset -> Word
getWord StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgRetFunFrameSize)
              retFunFun' :: Box
retFunFun' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgRetFunFrameFun)
          retFunPayload' <-
            if StackSnapshot# -> WordOffset -> Bool
isArgGenBigRetFunType StackSnapshot#
stackSnapshot# WordOffset
index Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True
              then LargeBitmapGetter
-> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
decodeLargeBitmap LargeBitmapGetter
getRetFunLargeBitmap# StackSnapshot#
stackSnapshot# WordOffset
index WordOffset
offsetStgRetFunFramePayload
              else [StackField] -> IO [StackField]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([StackField] -> IO [StackField])
-> [StackField] -> IO [StackField]
forall a b. (a -> b) -> a -> b
$ SmallBitmapGetter
-> StackSnapshot# -> WordOffset -> WordOffset -> [StackField]
decodeSmallBitmap SmallBitmapGetter
getRetFunSmallBitmap# StackSnapshot#
stackSnapshot# WordOffset
index WordOffset
offsetStgRetFunFramePayload
          pure $
            RetFun
              { info_tbl = info,
                retFunSize = retFunSize',
                retFunFun = retFunFun',
                retFunPayload = retFunPayload'
              }
        ClosureType
UPDATE_FRAME ->
          let updatee' :: Box
updatee' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgUpdateFrameUpdatee)
          in
            StackFrame -> IO StackFrame
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackFrame -> IO StackFrame) -> StackFrame -> IO StackFrame
forall a b. (a -> b) -> a -> b
$
              UpdateFrame
                { info_tbl :: StgInfoTable
info_tbl = StgInfoTable
info,
                  updatee :: Box
updatee = Box
updatee'
                }
        ClosureType
CATCH_FRAME -> do
          let handler' :: Box
handler' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgCatchFrameHandler)
          StackFrame -> IO StackFrame
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackFrame -> IO StackFrame) -> StackFrame -> IO StackFrame
forall a b. (a -> b) -> a -> b
$
            CatchFrame
              { info_tbl :: StgInfoTable
info_tbl = StgInfoTable
info,
                handler :: Box
handler = Box
handler'
              }
        ClosureType
UNDERFLOW_FRAME -> do
          let nextChunk' :: StackSnapshot
nextChunk' = StackSnapshot# -> WordOffset -> StackSnapshot
getUnderflowFrameNextChunk StackSnapshot#
stackSnapshot# WordOffset
index
          stackClosure <- StackSnapshot -> IO StgStackClosure
decodeStack StackSnapshot
nextChunk'
          pure $
            UnderflowFrame
              { info_tbl = info,
                nextChunk = stackClosure
              }
        ClosureType
STOP_FRAME -> StackFrame -> IO StackFrame
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackFrame -> IO StackFrame) -> StackFrame -> IO StackFrame
forall a b. (a -> b) -> a -> b
$ StopFrame {info_tbl :: StgInfoTable
info_tbl = StgInfoTable
info}
        ClosureType
ATOMICALLY_FRAME -> do
          let atomicallyFrameCode' :: Box
atomicallyFrameCode' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgAtomicallyFrameCode)
              result' :: Box
result' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgAtomicallyFrameResult)
          StackFrame -> IO StackFrame
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackFrame -> IO StackFrame) -> StackFrame -> IO StackFrame
forall a b. (a -> b) -> a -> b
$
            AtomicallyFrame
              { info_tbl :: StgInfoTable
info_tbl = StgInfoTable
info,
                atomicallyFrameCode :: Box
atomicallyFrameCode = Box
atomicallyFrameCode',
                result :: Box
result = Box
result'
              }
        ClosureType
CATCH_RETRY_FRAME ->
          let running_alt_code' :: Word
running_alt_code' = StackSnapshot# -> WordOffset -> Word
getWord StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgCatchRetryFrameRunningAltCode)
              first_code' :: Box
first_code' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgCatchRetryFrameRunningFirstCode)
              alt_code' :: Box
alt_code' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgCatchRetryFrameAltCode)
          in
            StackFrame -> IO StackFrame
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackFrame -> IO StackFrame) -> StackFrame -> IO StackFrame
forall a b. (a -> b) -> a -> b
$
              CatchRetryFrame
                { info_tbl :: StgInfoTable
info_tbl = StgInfoTable
info,
                  running_alt_code :: Word
running_alt_code = Word
running_alt_code',
                  first_code :: Box
first_code = Box
first_code',
                  alt_code :: Box
alt_code = Box
alt_code'
                }
        ClosureType
CATCH_STM_FRAME ->
          let catchFrameCode' :: Box
catchFrameCode' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgCatchSTMFrameCode)
              handler' :: Box
handler' = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stackSnapshot# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgCatchSTMFrameHandler)
          in
            StackFrame -> IO StackFrame
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StackFrame -> IO StackFrame) -> StackFrame -> IO StackFrame
forall a b. (a -> b) -> a -> b
$
              CatchStmFrame
                { info_tbl :: StgInfoTable
info_tbl = StgInfoTable
info,
                  catchFrameCode :: Box
catchFrameCode = Box
catchFrameCode',
                  handler :: Box
handler = Box
handler'
                }
        ClosureType
x -> String -> IO StackFrame
forall a. HasCallStack => String -> a
error (String -> IO StackFrame) -> String -> IO StackFrame
forall a b. (a -> b) -> a -> b
$ String
"Unexpected closure type on stack: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ClosureType -> String
forall a. Show a => a -> String
show ClosureType
x

-- | Unbox 'Int#' from 'Int'
toInt# :: Int -> Int#
toInt# :: Int -> Int#
toInt# (I# Int#
i) = Int#
i

-- | Convert `Int` to `Word#`
intToWord# :: Int -> Word#
intToWord# :: Int -> Word#
intToWord# Int
i = Int# -> Word#
int2Word# (Int -> Int#
toInt# Int
i)

wordOffsetToWord# :: WordOffset -> Word#
wordOffsetToWord# :: WordOffset -> Word#
wordOffsetToWord# WordOffset
wo = Int -> Word#
intToWord# (WordOffset -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOffset
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 -> IO StgStackClosure
decodeStack (StackSnapshot StackSnapshot#
stack#) = do
  info <- StackSnapshot# -> IO StgInfoTable
getInfoTableForStack StackSnapshot#
stack#
  case tipe info of
    ClosureType
STACK -> do
      let stack_size' :: Word32
stack_size' = StackSnapshot# -> Word32
getStackFields StackSnapshot#
stack#
          sfls :: [StackFrameLocation]
sfls = StackSnapshot# -> [StackFrameLocation]
stackFrameLocations StackSnapshot#
stack#
      stack' <- (StackFrameLocation -> IO StackFrame)
-> [StackFrameLocation] -> IO [StackFrame]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM StackFrameLocation -> IO StackFrame
unpackStackFrame [StackFrameLocation]
sfls
      pure $
        GenStgStackClosure
          { ssc_info = info,
            ssc_stack_size = stack_size',
            ssc_stack = stack'
          }
    ClosureType
_ -> String -> IO StgStackClosure
forall a. HasCallStack => String -> a
error (String -> IO StgStackClosure) -> String -> IO StgStackClosure
forall a b. (a -> b) -> a -> b
$ String
"Expected STACK closure, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ StgInfoTable -> String
forall a. Show a => a -> String
show StgInfoTable
info
  where
    stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
    stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
stackFrameLocations StackSnapshot#
s# =
      StackSnapshot# -> StackFrameLocation
stackHead StackSnapshot#
s#
        StackFrameLocation -> [StackFrameLocation] -> [StackFrameLocation]
forall a. a -> [a] -> [a]
: Maybe StackFrameLocation -> [StackFrameLocation]
go (StackFrameLocation -> Maybe StackFrameLocation
advanceStackFrameLocation (StackSnapshot# -> StackFrameLocation
stackHead StackSnapshot#
s#))
      where
        go :: Maybe StackFrameLocation -> [StackFrameLocation]
        go :: Maybe StackFrameLocation -> [StackFrameLocation]
go Maybe StackFrameLocation
Nothing = []
        go (Just StackFrameLocation
r) = StackFrameLocation
r StackFrameLocation -> [StackFrameLocation] -> [StackFrameLocation]
forall a. a -> [a] -> [a]
: Maybe StackFrameLocation -> [StackFrameLocation]
go (StackFrameLocation -> Maybe StackFrameLocation
advanceStackFrameLocation StackFrameLocation
r)

#else
module GHC.Exts.Stack.Decode where
#endif