{-# LANGUAGE CPP #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}

module GHC.Internal.Stack.Decode.Compat (
  StackFrameLocation,
  StackSnapshot#,
  StackInfoTable (..),
  getInfoTableForStack,
  getInfoTableOnStack,
  advanceStackFrameLocation,
  stackHead,
  Box (..),
  getClosureBox,
) where

import GHC.Exts
import GHC.Stack.CloneStack (StackSnapshot (..))

-- See Note [No way-dependent imports]
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
#endif
import GHC.Internal.Heap.Closures.Compat
import qualified GHC.Internal.InfoProv.Types as InfoProv
import GHC.Internal.Stack.Constants.Compat (WordOffset)

{-
Note [No way-dependent imports]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`ghc -M` currently assumes that the imports for a module are the same
in every way.  This is arguably a bug, but breaking this assumption by
importing different things in different ways can cause trouble.  For
example, this module in the profiling way imports and uses
GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the
vanilla way, there were intermittent build failures due to this module
being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf
in the profiling way. (#15197)
-}

type StackFrameLocation = (StackSnapshot, WordOffset)

data StackInfoTable = StackInfoTable
  { StackInfoTable -> Ptr StgInfoTable
infoTableStructPtr :: Ptr {-InfoProv.-} StgInfoTable
  , StackInfoTable -> Ptr StgInfoTable
infoTablePtr :: Ptr InfoProv.StgInfoTable
  , StackInfoTable -> StgInfoTable
infoTable :: StgInfoTable
  }

-- | Get the 'StgInfoTable' of the stack frame.
-- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.
getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StackInfoTable
getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StackInfoTable
getInfoTableOnStack StackSnapshot#
stackSnapshot# WordOffset
index = do
  let
    !(# Addr#
itbl_struct#, Addr#
itbl_ptr_ipe_key# #) = StackSnapshot# -> Word# -> (# Addr#, Addr# #)
getInfoTableAddrs# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index)
    itbl_struct :: Ptr StgInfoTable
itbl_struct = Addr# -> Ptr StgInfoTable
forall a. Addr# -> Ptr a
Ptr Addr#
itbl_struct#
    itbl_ptr :: Ptr StgInfoTable
itbl_ptr = Addr# -> Ptr StgInfoTable
forall a. Addr# -> Ptr a
Ptr Addr#
itbl_ptr_ipe_key#

  itbl <- Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
itbl_struct
  pure
    StackInfoTable
      { infoTableStructPtr = itbl_struct
      , infoTablePtr = itbl_ptr
      , infoTable = itbl
      }

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#)

-- | Advance to the next stack frame (if any)
advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation
advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation
advanceStackFrameLocation ((StackSnapshot StackSnapshot#
stackSnapshot#), WordOffset
index) =
  case StackSnapshot#
-> Word# -> (# (# #) | (# StackSnapshot#, Word# #) #)
advanceStackFrameLocation# StackSnapshot#
stackSnapshot# (WordOffset -> Word#
wordOffsetToWord# WordOffset
index) of
    (# (# #) | #) ->
      Maybe StackFrameLocation
forall a. Maybe a
Nothing
    (# | (# StackSnapshot#
s', Word#
i' #) #) ->
      StackFrameLocation -> Maybe StackFrameLocation
forall a. a -> Maybe a
Just (StackSnapshot# -> StackSnapshot
StackSnapshot StackSnapshot#
s', Word# -> WordOffset
primWordToWordOffset Word#
i')
 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#)

-- | `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

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

-- | 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# #) #)

foreign import prim "getInfoTableAddrszh"
  getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)

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

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

-- ----------------------------------------------------------------------------
-- Utilities that really should live somewhere else
-- ----------------------------------------------------------------------------

-- | 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)