module GHC.Debug.Decode.Stack
  ( decodeStack
  ) where

import Data.Word
import qualified Data.ByteString as BS

import Data.Binary.Get as B

import GHC.Debug.Types
import Control.Monad

import Data.Coerce

decodeStack :: Monad m
            => (RawClosure -> m StgInfoTableWithPtr) -- ^ How to decode the info table for the stack frame
            -> (Word32 -> m PtrBitmap) -- ^ How to decode the bitmap for the stack frame at a given offset
            -> RawStack
            -> m StackFrames
decodeStack :: forall (m :: * -> *).
Monad m =>
(RawClosure -> m StgInfoTableWithPtr)
-> (Word32 -> m PtrBitmap) -> RawStack -> m StackFrames
decodeStack RawClosure -> m StgInfoTableWithPtr
decodeInfoTable Word32 -> m PtrBitmap
getBitmap RawStack
rs = do
  forall srt b. [DebugStackFrame srt b] -> GenStackFrames srt b
GenStackFrames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word32 -> RawStack -> m [DebugStackFrame SrtCont ClosurePtr]
get_frames Word32
0 RawStack
rs
  where
    get_frames :: Word32 -> RawStack -> m [DebugStackFrame SrtCont ClosurePtr]
get_frames Word32
sp raw :: RawStack
raw@(RawStack ByteString
c) = do
      StgInfoTableWithPtr
st_it <- RawClosure -> m StgInfoTableWithPtr
decodeInfoTable (coerce :: forall a b. Coercible a b => a -> b
coerce RawStack
raw)
      PtrBitmap
bm <- Word32 -> m PtrBitmap
getBitmap Word32
sp
      let res :: Decoder (DebugStackFrame SrtCont ClosurePtr)
res = forall a. Get a -> Decoder a
B.runGetIncremental (PtrBitmap
-> StgInfoTableWithPtr -> Get (DebugStackFrame SrtCont ClosurePtr)
getFrame PtrBitmap
bm StgInfoTableWithPtr
st_it) forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
c
      case Decoder (DebugStackFrame SrtCont ClosurePtr)
res of
        Fail ByteString
_rem ByteOffset
_offset String
err -> forall a. HasCallStack => String -> a
error String
err
        Partial Maybe ByteString -> Decoder (DebugStackFrame SrtCont ClosurePtr)
_inp -> forall a. HasCallStack => String -> a
error String
"Not enough input"
        Done ByteString
more ByteOffset
offset DebugStackFrame SrtCont ClosurePtr
v
          | ByteString -> Bool
BS.null ByteString
more -> forall (m :: * -> *) a. Monad m => a -> m a
return []
          | Bool
otherwise -> (DebugStackFrame SrtCont ClosurePtr
vforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word32 -> RawStack -> m [DebugStackFrame SrtCont ClosurePtr]
get_frames (Word32
sp forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
offset)) (ByteString -> RawStack
RawStack ByteString
more)

getFrame :: PtrBitmap
         -> StgInfoTableWithPtr
         -> Get (DebugStackFrame SrtCont ClosurePtr)
getFrame :: PtrBitmap
-> StgInfoTableWithPtr -> Get (DebugStackFrame SrtCont ClosurePtr)
getFrame PtrBitmap
st_bitmap StgInfoTableWithPtr
itbl =
    case StgInfoTable -> ClosureType
tipe (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itbl) of
      ClosureType
RET_BCO ->
        -- TODO: In the case of a RET_BCO frame we must decode the frame as a BCO
        -- MP: If you trigger this case, then the decoding logic might
        -- already work but I have never encountered a stack frame with
        -- this type to test it. You might also need to modify `stub.cpp`
        -- but that should be straightforward.
        forall a. HasCallStack => String -> a
error String
"getStack: RET_BCO"
      ClosureType
ty -> do
        -- In all other cases we request the pointer bitmap from the debuggee
        -- and decode as appropriate.
        --traceShowM (headerSize ty, ty, st_bitmap, itbl)
        [Word64]
_itblPtr <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall {a}. Num a => ClosureType -> a
headerSize ClosureType
ty) Get Word64
getWord64le
        [FieldValue ClosurePtr]
fields <- forall (m :: * -> *) a.
Monad m =>
(Bool -> m a) -> PtrBitmap -> m [a]
traversePtrBitmap Bool -> Get (FieldValue ClosurePtr)
decodeField PtrBitmap
st_bitmap
        return (forall srt b.
StgInfoTableWithPtr
-> srt -> [FieldValue b] -> DebugStackFrame srt b
DebugStackFrame StgInfoTableWithPtr
itbl (StgInfoTableWithPtr -> SrtCont
tableId StgInfoTableWithPtr
itbl) [FieldValue ClosurePtr]
fields)
  where
    decodeField :: Bool -> Get (FieldValue ClosurePtr)
decodeField Bool
True  = forall b. b -> FieldValue b
SPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ClosurePtr
mkClosurePtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord
    decodeField Bool
False = forall b. Word64 -> FieldValue b
SNonPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord

    headerSize :: ClosureType -> a
headerSize ClosureType
RET_FUN = a
3
    headerSize ClosureType
RET_BCO = a
2
    headerSize ClosureType
_ = a
1

getWord :: Get Word64
getWord :: Get Word64
getWord = Get Word64
getWord64le -- TODO word size