{-# LANGUAGE MagicHash #-}

module GHC.Stack.Profiler.Internal.Stack.Decode (
  decodeStackWithIpProvId,
) where

import Data.Maybe (catMaybes)
import qualified Data.Text as Text
import Unsafe.Coerce (unsafeCoerce)

import GHC.Internal.ClosureTypes.Compat
import GHC.Internal.Stack.Constants.Compat
import GHC.Internal.Stack.Decode.Compat as Decode
import GHC.Internal.Stack.Types
import GHC.Stack.Annotation.Experimental.Compat
import GHC.Stack.CloneStack (StackSnapshot (..))

import GHC.Exts.Heap.InfoTable.Types

import GHC.Stack.Profiler.Core (IpeId (..), SourceLocation (..), StackItem (..))
import GHC.Stack.Profiler.Internal.Stack.Compat (lookupIpeIdForStackFrame)

decodeStackWithIpProvId :: StackSnapshot -> IO [StackItem]
decodeStackWithIpProvId :: StackSnapshot -> IO [StackItem]
decodeStackWithIpProvId (StackSnapshot StackSnapshot#
stack#) = do
  info <- StackSnapshot# -> IO StgInfoTable
getInfoTableForStack StackSnapshot#
stack#
  case tipe info of
    ClosureType
STACK -> do
      let
        sfls :: [StackFrameLocation]
sfls = StackSnapshot# -> [StackFrameLocation]
stackFrameLocations StackSnapshot#
stack#
      stack' <- [StackFrameLocation] -> IO [StackItem]
stackFrameLocationItems [StackFrameLocation]
sfls
      pure stack'
    ClosureType
_ -> [Char] -> IO [StackItem]
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO [StackItem]) -> [Char] -> IO [StackItem]
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected STACK closure, got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StgInfoTable -> [Char]
forall a. Show a => a -> [Char]
show StgInfoTable
info
 where
  stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
  stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
stackFrameLocations StackSnapshot#
s# =
    StackSnapshot# -> StackFrameLocation
stackHead StackSnapshot#
s#
      StackFrameLocation -> [StackFrameLocation] -> [StackFrameLocation]
forall a. a -> [a] -> [a]
: Maybe StackFrameLocation -> [StackFrameLocation]
go (StackFrameLocation -> Maybe StackFrameLocation
advanceStackFrameLocation (StackSnapshot# -> StackFrameLocation
stackHead StackSnapshot#
s#))
   where
    go :: Maybe StackFrameLocation -> [StackFrameLocation]
    go :: Maybe StackFrameLocation -> [StackFrameLocation]
go Maybe StackFrameLocation
Nothing = []
    go (Just StackFrameLocation
r) = StackFrameLocation
r StackFrameLocation -> [StackFrameLocation] -> [StackFrameLocation]
forall a. a -> [a] -> [a]
: Maybe StackFrameLocation -> [StackFrameLocation]
go (StackFrameLocation -> Maybe StackFrameLocation
advanceStackFrameLocation StackFrameLocation
r)

stackFrameLocationItems :: [StackFrameLocation] -> IO [StackItem]
stackFrameLocationItems :: [StackFrameLocation] -> IO [StackItem]
stackFrameLocationItems [StackFrameLocation]
frames =
  [Maybe StackItem] -> [StackItem]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe StackItem] -> [StackItem])
-> IO [Maybe StackItem] -> IO [StackItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StackFrameLocation -> IO (Maybe StackItem))
-> [StackFrameLocation] -> IO [Maybe StackItem]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse StackFrameLocation -> IO (Maybe StackItem)
stackFrameLocationItem [StackFrameLocation]
frames

stackFrameLocationItem :: StackFrameLocation -> IO (Maybe StackItem)
stackFrameLocationItem :: StackFrameLocation -> IO (Maybe StackItem)
stackFrameLocationItem (StackSnapshot StackSnapshot#
stack#, WordOffset
index) = do
  stackItbl <- StackSnapshot# -> WordOffset -> IO StackInfoTable
getInfoTableOnStack StackSnapshot#
stack# WordOffset
index
  case tipe (infoTable stackItbl) of
    ClosureType
ANN_FRAME ->
      let
        Box Any
annotation = StackSnapshot# -> WordOffset -> Box
getClosureBox StackSnapshot#
stack# (WordOffset
index WordOffset -> WordOffset -> WordOffset
forall a. Num a => a -> a -> a
+ WordOffset
offsetStgAnnFrameAnn)
      in
        Maybe StackItem -> IO (Maybe StackItem)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe StackItem -> IO (Maybe StackItem))
-> Maybe StackItem -> IO (Maybe StackItem)
forall a b. (a -> b) -> a -> b
$ StackItem -> Maybe StackItem
forall a. a -> Maybe a
Just (StackItem -> Maybe StackItem) -> StackItem -> Maybe StackItem
forall a b. (a -> b) -> a -> b
$ SomeStackAnnotation -> StackItem
stackAnnotationToStackItem (Any -> SomeStackAnnotation
forall a b. a -> b
unsafeCoerce Any
annotation)
    ClosureType
_ ->
      (Word64 -> StackItem) -> Maybe Word64 -> Maybe StackItem
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IpeId -> StackItem
IpeId (IpeId -> StackItem) -> (Word64 -> IpeId) -> Word64 -> StackItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> IpeId
MkIpeId) (Maybe Word64 -> Maybe StackItem)
-> IO (Maybe Word64) -> IO (Maybe StackItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StackInfoTable -> IO (Maybe Word64)
lookupIpeIdForStackFrame StackInfoTable
stackItbl

stackAnnotationToStackItem :: SomeStackAnnotation -> StackItem
stackAnnotationToStackItem :: SomeStackAnnotation -> StackItem
stackAnnotationToStackItem SomeStackAnnotation
someStackAnnotation =
  let
    message :: [Char]
message = SomeStackAnnotation -> [Char]
showStackAnnotationDescription SomeStackAnnotation
someStackAnnotation
    sourceLoc :: Maybe SourceLocation
sourceLoc = do
      srcLoc <- SomeStackAnnotation -> Maybe SrcLoc
showStackAnnotationLocation SomeStackAnnotation
someStackAnnotation
      Just $
        MkSourceLocation
          { line = fromIntegral $ srcLocStartLine srcLoc
          , column = fromIntegral $ srcLocStartCol srcLoc
          , fileName = Text.pack $ srcLocFile srcLoc
          }
  in
    [Char] -> Maybe SourceLocation -> StackItem
UserAnnotation [Char]
message Maybe SourceLocation
sourceLoc