Stack.hs

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 decodeInfoTable getBitmap rs = do
  GenStackFrames <$> get_frames 0 rs
  where
    get_frames sp raw@(RawStack c) = do
      st_it <- decodeInfoTable (coerce raw)
      bm <- getBitmap sp
      let res = B.runGetIncremental (getFrame bm st_it) `pushChunk` c
      case res of
        Fail _rem _offset err -> error err
        Partial _inp -> error "Not enough input"
        Done more offset v
          | BS.null more -> return []
          | otherwise -> (v:) <$> get_frames (sp + (fromIntegral offset)) (RawStack more)

getFrame :: PtrBitmap
         -> StgInfoTableWithPtr
         -> Get (DebugStackFrame ClosurePtr)
getFrame st_bitmap itbl =
    case tipe (decodedTable itbl) of
      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.
        error "getStack: RET_BCO"
      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)
        _itblPtr <- replicateM (headerSize ty) getWord64le
        fields <- traversePtrBitmap decodeField st_bitmap
        return (DebugStackFrame itbl fields)
  where
    decodeField True  = SPtr . mkClosurePtr <$> getWord
    decodeField False = SNonPtr <$> getWord

    headerSize RET_FUN = 3
    headerSize RET_BCO = 2
    headerSize _ = 1

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