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
  [DebugStackFrame ClosurePtr] -> StackFrames
forall b. [DebugStackFrame b] -> GenStackFrames b
GenStackFrames ([DebugStackFrame ClosurePtr] -> StackFrames)
-> m [DebugStackFrame ClosurePtr] -> m StackFrames
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word32 -> RawStack -> m [DebugStackFrame ClosurePtr]
get_frames Word32
0 RawStack
rs
  where
    get_frames :: Word32 -> RawStack -> m [DebugStackFrame ClosurePtr]
get_frames Word32
sp raw :: RawStack
raw@(RawStack ByteString
c) = do
      StgInfoTableWithPtr
st_it <- RawClosure -> m StgInfoTableWithPtr
decodeInfoTable (RawStack -> RawClosure
coerce RawStack
raw)
      PtrBitmap
bm <- Word32 -> m PtrBitmap
getBitmap Word32
sp
      let res :: Decoder (DebugStackFrame ClosurePtr)
res = Get (DebugStackFrame ClosurePtr)
-> Decoder (DebugStackFrame ClosurePtr)
forall a. Get a -> Decoder a
B.runGetIncremental (PtrBitmap
-> StgInfoTableWithPtr -> Get (DebugStackFrame ClosurePtr)
getFrame PtrBitmap
bm StgInfoTableWithPtr
st_it) Decoder (DebugStackFrame ClosurePtr)
-> ByteString -> Decoder (DebugStackFrame ClosurePtr)
forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
c
      case Decoder (DebugStackFrame ClosurePtr)
res of
        Fail ByteString
_rem ByteOffset
_offset String
err -> String -> m [DebugStackFrame ClosurePtr]
forall a. HasCallStack => String -> a
error String
err
        Partial Maybe ByteString -> Decoder (DebugStackFrame ClosurePtr)
_inp -> String -> m [DebugStackFrame ClosurePtr]
forall a. HasCallStack => String -> a
error String
"Not enough input"
        Done ByteString
more ByteOffset
offset DebugStackFrame ClosurePtr
v
          | ByteString -> Bool
BS.null ByteString
more -> [DebugStackFrame ClosurePtr] -> m [DebugStackFrame ClosurePtr]
forall (m :: * -> *) a. Monad m => a -> m a
return []
          | Bool
otherwise -> (DebugStackFrame ClosurePtr
vDebugStackFrame ClosurePtr
-> [DebugStackFrame ClosurePtr] -> [DebugStackFrame ClosurePtr]
forall a. a -> [a] -> [a]
:) ([DebugStackFrame ClosurePtr] -> [DebugStackFrame ClosurePtr])
-> m [DebugStackFrame ClosurePtr] -> m [DebugStackFrame ClosurePtr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word32 -> RawStack -> m [DebugStackFrame ClosurePtr]
get_frames (Word32
sp Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ (ByteOffset -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
offset)) (ByteString -> RawStack
RawStack ByteString
more)

getFrame :: PtrBitmap
         -> StgInfoTableWithPtr
         -> Get (DebugStackFrame ClosurePtr)
getFrame :: PtrBitmap
-> StgInfoTableWithPtr -> Get (DebugStackFrame 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.
        String -> Get (DebugStackFrame ClosurePtr)
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 <- Int -> Get Word64 -> Get [Word64]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (ClosureType -> Int
forall {a}. Num a => ClosureType -> a
headerSize ClosureType
ty) Get Word64
getWord64le
        [FieldValue ClosurePtr]
fields <- (Bool -> Get (FieldValue ClosurePtr))
-> PtrBitmap -> Get [FieldValue ClosurePtr]
forall (m :: * -> *) a.
Monad m =>
(Bool -> m a) -> PtrBitmap -> m [a]
traversePtrBitmap Bool -> Get (FieldValue ClosurePtr)
decodeField PtrBitmap
st_bitmap
        return (StgInfoTableWithPtr
-> [FieldValue ClosurePtr] -> DebugStackFrame ClosurePtr
forall b.
StgInfoTableWithPtr -> [FieldValue b] -> DebugStackFrame b
DebugStackFrame StgInfoTableWithPtr
itbl [FieldValue ClosurePtr]
fields)
  where
    decodeField :: Bool -> Get (FieldValue ClosurePtr)
decodeField Bool
True  = ClosurePtr -> FieldValue ClosurePtr
forall b. b -> FieldValue b
SPtr (ClosurePtr -> FieldValue ClosurePtr)
-> (Word64 -> ClosurePtr) -> Word64 -> FieldValue ClosurePtr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ClosurePtr
mkClosurePtr (Word64 -> FieldValue ClosurePtr)
-> Get Word64 -> Get (FieldValue ClosurePtr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord
    decodeField Bool
False = Word64 -> FieldValue ClosurePtr
forall b. Word64 -> FieldValue b
SNonPtr (Word64 -> FieldValue ClosurePtr)
-> Get Word64 -> Get (FieldValue ClosurePtr)
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