Decode.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}

module GHC.Internal.Stack.Decode (
  -- * High-level stack decoders
  decode,
  decodeStack,
  decodeStackWithIpe,
  -- * Stack decoder helpers
  decodeStackWithFrameUnpack,
  -- * StackEntry
  StackEntry(..),
  -- * Pretty printing
  prettyStackEntry,
  prettyStackFrameWithIpe,
  )
where

import GHC.Internal.Base
import GHC.Internal.Show
import GHC.Internal.Real
import GHC.Internal.Word
import GHC.Internal.Num
import GHC.Internal.Data.Bits
import GHC.Internal.Data.Functor
import GHC.Internal.Data.Maybe (catMaybes)
import GHC.Internal.Data.List
import GHC.Internal.Data.Tuple
import GHC.Internal.Foreign.Ptr
import GHC.Internal.Foreign.Storable
import GHC.Internal.Exts
import GHC.Internal.Unsafe.Coerce

import GHC.Internal.ClosureTypes
import GHC.Internal.Heap.Closures
  ( Box (..),
    StackFrame,
    GenStackFrame (..),
    StgStackClosure,
    GenStgStackClosure (..),
    StackField,
    GenStackField(..)
  )
import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
import GHC.Internal.Stack.Annotation
-- See Note [No way-dependent imports]
#if defined(PROFILING)
import GHC.Internal.Stack.Constants ()
import GHC.Internal.Stack.ConstantsProf
import GHC.Internal.Heap.InfoTable ()
import GHC.Internal.Heap.InfoTableProf
#else
import GHC.Internal.Heap.InfoTable
import GHC.Internal.Heap.InfoTableProf ()
import GHC.Internal.Stack.Constants
import GHC.Internal.Stack.ConstantsProf ()
#endif
import GHC.Internal.Stack.CloneStack
import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)

{- 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 "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)

foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#

-- | Get the 'StgInfoTable' of the stack frame.
-- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.
getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv)
getInfoTableOnStack stackSnapshot# index =
  let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
   in
    (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#)

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 stackFrameLoc = do
  unpackStackFrameTo stackFrameLoc
    (\ info _ nextChunk -> do
      stackClosure <- decodeStack nextChunk
      pure $
        UnderflowFrame
          { info_tbl = info,
            nextChunk = stackClosure
          }
    )
    (\ frame _ -> pure frame)

unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)]
unpackStackFrameWithIpe stackFrameLoc = do
  unpackStackFrameTo stackFrameLoc
    (\ info mIpe nextChunk@(StackSnapshot stack#) -> do
      framesWithIpe <- decodeStackWithIpe nextChunk
      pure
        [ ( UnderflowFrame
            { info_tbl = info,
              nextChunk =
                GenStgStackClosure
                  { ssc_info = info,
                    ssc_stack_size = getStackFields stack#,
                    ssc_stack = map fst framesWithIpe
                  }
            }
          , mIpe
          )
        ]
    )
    (\ frame mIpe -> pure [(frame, mIpe)])

unpackStackFrameTo ::
  forall a .
  StackFrameLocation ->
  -- ^ Decode the given 'StackFrame'.
  (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
  -- ^ How to handle 'UNDERFLOW_FRAME's.
  (StackFrame -> Maybe InfoProv -> IO a) ->
  -- ^ How to handle all other 'StackFrame' values.
  IO a
unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
  unpackStackFrame' info
    (unpackUnderflowFrame info m_info_prov)
    (`finaliseStackFrame` m_info_prov)
  where
    unpackStackFrame' ::
      StgInfoTable ->
      (StackSnapshot -> IO a) ->
      (StackFrame -> IO a) ->
      IO a
    unpackStackFrame' info mkUnderflowResult mkStackFrameResult =
      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)
          mkStackFrameResult
            RetBCO
              { info_tbl = info,
                bco = bco',
                bcoArgs = bcoArgs'
              }
        RET_SMALL ->
          let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
          in
            mkStackFrameResult $
              RetSmall
                { info_tbl = info,
                  stack_payload = payload'
                }
        RET_BIG -> do
          payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
          mkStackFrameResult $
            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
          mkStackFrameResult $
            RetFun
              { info_tbl = info,
                retFunSize = retFunSize',
                retFunFun = retFunFun',
                retFunPayload = retFunPayload'
              }
        UPDATE_FRAME ->
          let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
          in
            mkStackFrameResult $
              UpdateFrame
                { info_tbl = info,
                  updatee = updatee'
                }
        CATCH_FRAME -> do
          let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
          mkStackFrameResult $
            CatchFrame
              { info_tbl = info,
                handler = handler'
              }
        UNDERFLOW_FRAME -> do
          let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
          mkUnderflowResult nextChunk'
        STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
        ATOMICALLY_FRAME -> do
          let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
              result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
          mkStackFrameResult $
            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
            mkStackFrameResult $
              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
            mkStackFrameResult $
              CatchStmFrame
                { info_tbl = info,
                  catchFrameCode = catchFrameCode',
                  handler = handler'
                }
        ANN_FRAME ->
          let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
           in
             mkStackFrameResult $
               AnnFrame
                { info_tbl = info,
                  annotation = annotation
                }
        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)

-- ----------------------------------------------------------------------------
-- Simplified source location representation of provenance information
-- ----------------------------------------------------------------------------

-- | Representation for the source location where a return frame was pushed on the stack.
-- This happens every time when a @case ... of@ scrutinee is evaluated.
data StackEntry = StackEntry
  { functionName :: String,
    moduleName :: String,
    srcLoc :: String,
    closureType :: ClosureType
  }
  deriving (Show, Eq)

toStackEntry :: InfoProv -> StackEntry
toStackEntry infoProv =
  StackEntry
  { functionName = ipLabel infoProv,
    moduleName = ipMod infoProv,
    srcLoc = ipLoc infoProv,
    closureType = ipDesc infoProv
  }

-- ----------------------------------------------------------------------------
-- Stack decoders
-- ----------------------------------------------------------------------------

-- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry').
-- The stack trace is created from return frames with according 'InfoProvEnt'
-- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are
-- no 'InfoProvEnt' entries, an empty list is returned.
--
-- Please note:
--
--   * To gather 'StackEntry' from libraries, these have to be
--     compiled with @-finfo-table-map@, too.
--   * Due to optimizations by GHC (e.g. inlining) the stacktrace may change
--     with different GHC parameters and versions.
--   * The stack trace is empty (by design) if there are no return frames on
--     the stack. (These are pushed every time when a @case ... of@ scrutinee
--     is evaluated.)
--
-- @since base-4.17.0.0
decode :: StackSnapshot -> IO [StackEntry]
decode stackSnapshot =
  (map toStackEntry . catMaybes . map snd . reverse) <$> decodeStackWithIpe stackSnapshot


-- | 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 snapshot@(StackSnapshot stack#) = do
  (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot
  pure
    GenStgStackClosure
      { ssc_info = stackInfo,
        ssc_stack_size = getStackFields stack#,
        ssc_stack = ssc_stack
      }

decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)]
decodeStackWithIpe snapshot =
  concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot

-- ----------------------------------------------------------------------------
-- Write your own stack decoder!
-- ----------------------------------------------------------------------------

decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a])
decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
  info <- getInfoTableForStack stack#
  case tipe info of
    STACK -> do
      let sfls = stackFrameLocations stack#
      stack' <- mapM unpackFrame sfls
      pure (info, 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)

-- ----------------------------------------------------------------------------
-- Pretty printing functions for stack entries, stack frames and provenance info
-- ----------------------------------------------------------------------------

prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
prettyStackFrameWithIpe (frame, mipe) =
  case frame of
    AnnFrame {annotation = Box someStackAnno } ->
      case unsafeCoerce someStackAnno of
        SomeStackAnnotation ann ->
          Just $ displayStackAnnotation ann
    _ ->
      (prettyStackEntry . toStackEntry) <$> mipe

prettyStackEntry :: StackEntry -> String
prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
  mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"