GitLab

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC

Commits:

d4002865

by fendor at 2025-07-17T15:24:57+02:00

WIP: Introduce stack frame annotation helpers and extend ghc-heap stack decoder

bf1f28d0

by fendor at 2025-07-17T15:25:01+02:00

WIP: base: extend Backtraces to allow configuration of stack decoders

7235ceab

by fendor at 2025-07-17T15:25:02+02:00

WIP: move iterator based stack decoder to ghc-internal

25 changed files:

libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
libraries/ghc-heap/cbits/Stack.cmm
libraries/ghc-heap/tests/stack-annotation/all.T
libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs
libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs
libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout
+ libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs
+ libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs
+ libraries/ghc-internal/cbits/HeapPrim.cmm
+ libraries/ghc-internal/cbits/Stack.cmm
+ libraries/ghc-internal/cbits/Stack_c.c
libraries/ghc-internal/ghc-internal.cabal.in
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
+ libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
+ libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
+ libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
+ libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
+ libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
+ libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
+ libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs

Changes:

libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs

@@ -3,65 +3,93 @@
  {-# LANGUAGE MagicHash #-}
  {-# LANGUAGE UnboxedTuples #-}
  {-# LANGUAGE ImplicitParams #-}
 -module GHC.Stack.Annotation.Experimental where
 +module GHC.Stack.Annotation.Experimental (
 +  IsStackAnnotation(..),
 +  SomeStackAnnotation(..),
 +  -- * Source Location annotations
 +  SrcLocAnnotation,
 +  UnknownSrcLocAnnotation,
 +  -- * Stack annotations
 +  annotateStack,
 +  annotateShow,
 +  annotateCallStack,
 +  annotateStackM,
 +  annotateStringM,
 +  annotateStackShowM,
 +  annotateCallStackM,
 +  ) where
  import Data.Typeable
  import GHC.Exts
  import GHC.IO
 -import GHC.Internal.Stack.Types
 +import GHC.Internal.Stack
 +import GHC.Internal.Stack.Annotation
 -data StackAnnotation where
 -  StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation
 +data StringAnnotation where
 +  StringAnnotation :: String -> StringAnnotation
 -class IsStackAnnotation a where
 -  display :: a -> String
 +instance IsStackAnnotation StringAnnotation where
 +  displayStackAnnotation (StringAnnotation str) = str
 -instance IsStackAnnotation StackAnnotation where
 -  display (StackAnnotation a) = show a
 +-- ----------------------------------------------------------------------------
 +-- Source location annotations
 +-- ----------------------------------------------------------------------------
 -newtype SrcLocAnno = MkSrcLocAnno SrcLoc
 +newtype SrcLocAnnotation = SrcLocAnnotation SrcLoc
 -data UnknownSrcLocAnno = UnknownSrcLocAnno
 +data UnknownSrcLocAnnotation = UnknownSrcLocAnnotation
    deriving Show
 -instance Show SrcLocAnno where
 -  show (MkSrcLocAnno l) =
 -    concat
 -      [ srcLocPackage l
 -      , ":"
 -      , srcLocModule l
 -      , " "
 -      , srcLocFile l
 -      , ":"
 -      , show $ srcLocStartLine l
 -      , "-"
 -      , show $ srcLocStartCol l
 -      , ":"
 -      , show $ srcLocEndLine l
 -      , "-"
 -      , show $ srcLocEndCol l
 -      ]
+-
 -instance IsStackAnnotation SrcLocAnno where
 -  display = show
+-
 -instance IsStackAnnotation UnknownSrcLocAnno where
 -  display UnknownSrcLocAnno = "UnknownSrcLocAnno"
 +instance Show SrcLocAnnotation where
 +  show (SrcLocAnnotation l) = prettySrcLoc l
++
 +instance IsStackAnnotation SrcLocAnnotation where
 +  displayStackAnnotation = show
++
 +instance IsStackAnnotation UnknownSrcLocAnnotation where
 +  displayStackAnnotation UnknownSrcLocAnnotation = "<no location info>"
++
 +-- ----------------------------------------------------------------------------
 +-- Annotate the CallStack!
 +-- ----------------------------------------------------------------------------
  {-# NOINLINE annotateStack #-}
 -annotateStack :: forall a b. (Typeable a, Show a) => a -> b -> b
 +-- TODO @fendor: it seems the pure interface doesnt work,
 +-- investigate more and then decide what to do
 +annotateStack :: forall a b. (Typeable a, IsStackAnnotation a) => a -> b -> b
  annotateStack ann b = unsafePerformIO $
    annotateStackM ann (pure b)
 -annotateStackM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b
 +{-# NOINLINE annotateCallStack #-}
 +-- TODO @fendor: it seems the pure interface doesnt work,
 +-- investigate more and then decide what to do
 +annotateCallStack :: HasCallStack => b -> b
 +annotateCallStack b = unsafePerformIO $
 +  annotateCallStackM (pure b)
++
 +-- TODO @fendor: it seems the pure interface doesnt work,
 +-- investigate more and then decide what to do
 +annotateShow :: forall a b . (Typeable a, Show a) => a -> b -> b
 +annotateShow ann =
 +  annotateStack (StringAnnotation $ show ann)
++
 +annotateStackM :: forall a b . (Typeable a, IsStackAnnotation a) => a -> IO b -> IO b
  annotateStackM ann (IO act) =
 -  IO $ \s -> annotateStack# (StackAnnotation ann) act s
 +  IO $ \s -> annotateStack# (SomeStackAnnotation ann) act s
++
 +annotateStringM :: forall b . String -> IO b -> IO b
 +annotateStringM ann =
 +  annotateStackM (StringAnnotation ann)
++
 +annotateStackShowM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b
 +annotateStackShowM ann =
 +  annotateStringM (show ann)
  annotateCallStackM :: HasCallStack => IO a -> IO a
  annotateCallStackM act =
    let
      cs = getCallStack ?callStack
    in case cs of
 -    [] -> annotateStackM UnknownSrcLocAnno act
 -    [(_, srcLoc)] -> annotateStackM (MkSrcLocAnno srcLoc) act
 -    (_:(_, srcLoc):_) -> annotateStackM (MkSrcLocAnno srcLoc) act
 +    [] -> annotateStackM UnknownSrcLocAnnotation act
 +    [(_, srcLoc)] -> annotateStackM (SrcLocAnnotation srcLoc) act
 +    (_:(_, srcLoc):_) -> annotateStackM (SrcLocAnnotation srcLoc) act

libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc

@@ -24,7 +24,7 @@ import Foreign
  -- | Read an InfoTable from the heap into a haskell type.
  -- WARNING: This code assumes it is passed a pointer to a "standard" info
 --- table. If tables_next_to_code is enabled, it will look 1 byte before the
 +-- table. If tables_next_to_code is disabled, it will look 1 word before the
  -- start for the entry field.
  peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
  peekItbl a0 = do

libraries/ghc-heap/GHC/Exts/Stack/Decode.hs

@@ -15,6 +15,7 @@
  module GHC.Exts.Stack.Decode
    ( decodeStack,
 +    decodeStackWithIpe,
+   )
  where
@@ -23,10 +24,10 @@ import Data.Bits
  import Data.Maybe
  import Foreign
  import GHC.Exts
 -import GHC.Exts.Heap (Box (..))
  import GHC.Exts.Heap.ClosureTypes
  import GHC.Exts.Heap.Closures
 -  ( StackFrame,
 +  ( Box (..),
 +    StackFrame,
      GenStackFrame (..),
      StgStackClosure,
      GenStgStackClosure (..),
@@ -36,6 +37,7 @@ import GHC.Exts.Heap.Closures
  import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
  import GHC.Exts.Heap.InfoTable
  import GHC.Exts.Stack.Constants
 +import qualified GHC.Internal.InfoProv.Types as IPE
  import GHC.Stack.CloneStack
  import GHC.Word
  import Prelude
@@ -150,14 +152,17 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
  foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
 -foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#
 +foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)
  foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
 -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable
 +-- | Get the 'StgInfoTable' of the stack frame.
 +-- Additionally, provides 'IPE.InfoProv' for the 'StgInfoTable' if there is any.
 +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe IPE.InfoProv)
  getInfoTableOnStack stackSnapshot# index =
 -  let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
 -   in peekItbl infoTablePtr
 +  let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
 +   in
 +    (,) <$> peekItbl (Ptr itbl_struct#) <*> IPE.lookupIPE (Ptr itbl_ptr#)
  getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
  getInfoTableForStack stackSnapshot# =
@@ -276,18 +281,49 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
        (bitmapWordPointerness size bitmap)
  unpackStackFrame :: StackFrameLocation -> IO StackFrame
 -unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
 -  info <- getInfoTableOnStack stackSnapshot# index
 +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 IPE.InfoProv)]
 +unpackStackFrameWithIpe stackFrameLoc = do
 +  unpackStackFrameTo stackFrameLoc
 +    (\ _ nextChunk -> do
 +      decodeStackWithIpe nextChunk
 +    )
 +    (\ frame mIpe -> pure [(frame, mIpe)])
++
 +unpackStackFrameTo ::
 +  StackFrameLocation ->
 +  (StgInfoTable -> StackSnapshot -> IO a) ->
 +  (StackFrame -> Maybe IPE.InfoProv -> IO a) ->
 +  IO a
 +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
 +  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
    unpackStackFrame' info
 +    unpackUnderflowFrame
 +    (`finaliseStackFrame` m_info_prov)
    where
 -    unpackStackFrame' :: StgInfoTable -> IO StackFrame
 -    unpackStackFrame' info =
 +    unpackStackFrame' ::
 +      StgInfoTable ->
 +      (StgInfoTable -> StackSnapshot -> IO a) ->
 +      (StackFrame -> IO a) ->
 +      IO a
 +    unpackStackFrame' info unpackUnderflowFrame 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)
 -          pure
 +          mkStackFrameResult
              RetBCO
                { info_tbl = info,
                  bco = bco',
@@ -296,14 +332,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
          RET_SMALL ->
            let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
            in
 -            pure $
 +            mkStackFrameResult $
                RetSmall
                  { info_tbl = info,
                    stack_payload = payload'
+                 }
          RET_BIG -> do
            payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
 -          pure $
 +          mkStackFrameResult $
              RetBig
                { info_tbl = info,
                  stack_payload = payload'
@@ -315,7 +351,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
              if isArgGenBigRetFunType stackSnapshot# index == True
                then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
                else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
 -          pure $
 +          mkStackFrameResult $
              RetFun
                { info_tbl = info,
                  retFunSize = retFunSize',
@@ -325,31 +361,26 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
          UPDATE_FRAME ->
            let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
            in
 -            pure $
 +            mkStackFrameResult $
                UpdateFrame
                  { info_tbl = info,
                    updatee = updatee'
+                 }
          CATCH_FRAME -> do
            let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
 -          pure $
 +          mkStackFrameResult $
              CatchFrame
                { info_tbl = info,
                  handler = handler'
+               }
          UNDERFLOW_FRAME -> do
            let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
 -          stackClosure <- decodeStack nextChunk'
 -          pure $
 -            UnderflowFrame
 -              { info_tbl = info,
 -                nextChunk = stackClosure
 -              }
 -        STOP_FRAME -> pure $ StopFrame {info_tbl = info}
 +          unpackUnderflowFrame info nextChunk'
 +        STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
          ATOMICALLY_FRAME -> do
            let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
                result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
 -          pure $
 +          mkStackFrameResult $
              AtomicallyFrame
                { info_tbl = info,
                  atomicallyFrameCode = atomicallyFrameCode',
@@ -360,7 +391,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
                first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
                alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
            in
 -            pure $
 +            mkStackFrameResult $
                CatchRetryFrame
                  { info_tbl = info,
                    running_alt_code = running_alt_code',
@@ -371,7 +402,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
            let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
                handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
            in
 -            pure $
 +            mkStackFrameResult $
                CatchStmFrame
                  { info_tbl = info,
                    catchFrameCode = catchFrameCode',
@@ -380,7 +411,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
          ANN_FRAME ->
            let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
             in
 -             pure $
 +             mkStackFrameResult $
                 AnnFrame
                  { info_tbl = info,
                    annotation = annotation
@@ -410,19 +441,27 @@ type StackFrameLocation = (StackSnapshot, WordOffset)
  --
  -- See /Note [Decoding the stack]/.
  decodeStack :: StackSnapshot -> IO StgStackClosure
 -decodeStack (StackSnapshot stack#) = do
 +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 IPE.InfoProv)]
 +decodeStackWithIpe snapshot =
 +  concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
++
 +decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a])
 +decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
    info <- getInfoTableForStack stack#
    case tipe info of
      STACK -> do
 -      let stack_size' = getStackFields stack#
 -          sfls = stackFrameLocations stack#
 -      stack' <- mapM unpackStackFrame sfls
 -      pure $
 -        GenStgStackClosure
 -          { ssc_info = info,
 -            ssc_stack_size = stack_size',
 -            ssc_stack = stack'
 -          }
 +      let sfls = stackFrameLocations stack#
 +      stack' <- mapM unpackFrame sfls
 +      pure (info, stack')
      _ -> error $ "Expected STACK closure, got " ++ show info
    where
      stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]

libraries/ghc-heap/cbits/Stack.cmm

@@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {
    return (type);
+ }
 -// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords)
 -getInfoTableAddrzh(P_ stack, W_ offsetWords) {
 -  P_ p, info;
 +// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords)
 +getInfoTableAddrszh(P_ stack, W_ offsetWords) {
 +  P_ p, info_struct, info_ptr;
    p = StgStack_sp(stack) + WDS(offsetWords);
    ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 -  info = %GET_STD_INFO(UNTAG(p));
+-
 -  return (info);
 +  info_struct = %GET_STD_INFO(UNTAG(p));
 +  info_ptr = %INFO_PTR(UNTAG(p));
 +  return (info_struct, info_ptr);
+ }
  // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)

libraries/ghc-heap/tests/stack-annotation/all.T

  test('ann_frame001', normal, compile_and_run, [''])
  test('ann_frame002', normal, compile_and_run, [''])
 +test('ann_frame003', normal, compile_and_run, [''])
 +test('ann_frame004', normal, compile_and_run, [''])

libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs

@@ -7,7 +7,7 @@ import System.IO.Unsafe
  import Unsafe.Coerce
  hello :: Int -> Int -> Int
 -hello x y = annotateStack (x,y) $
 +hello x y = annotateShow (x,y) $
    decodeAndPrintAnnotationFrames $!
      x + y + 42
  {-# OPAQUE hello #-}
@@ -17,9 +17,9 @@ decodeAndPrintAnnotationFrames :: a -> a
  decodeAndPrintAnnotationFrames a = unsafePerformIO $ do
    stack <- GHC.Stack.CloneStack.cloneMyStack
    decoded <- GHC.Exts.Stack.Decode.decodeStack stack
 -  print [ show a
 +  print [ displayStackAnnotation a
          | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded
 -        , StackAnnotation a <- pure $ unsafeCoerce ann
 +        , SomeStackAnnotation a <- pure $ unsafeCoerce ann
+         ]
    pure a
@@ -30,13 +30,13 @@ main = do
  {-# INLINE tailCallEx #-}
  tailCallEx :: Int -> Int -> Int
 -tailCallEx a b = annotateStack "tailCallEx" $ foo a b
 +tailCallEx a b = annotateShow "tailCallEx" $ foo a b
  {-# INLINE foo #-}
  foo :: Int -> Int -> Int
 -foo a b = annotateStack "foo" $ bar $ a * b
 +foo a b = annotateShow "foo" $ bar $ a * b
 -bar c = annotateStack "bar" $
 +bar c = annotateShow "bar" $
    decodeAndPrintAnnotationFrames $
      c + c

libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs

@@ -12,17 +12,7 @@ import qualified GHC.Internal.Stack.CloneStack as CloneStack
  import System.IO.Unsafe
  import Unsafe.Coerce
+-
 -{-# NOINLINE decodeAnnotationFrames #-}
 -decodeAnnotationFrames :: IO [String]
 -decodeAnnotationFrames = do
 -  stack <- CloneStack.cloneMyStack
 -  decoded <- Decode.decodeStack stack
 -  pure
 -      [ show a
 -      | AnnFrame _ (Box ann) <- ssc_stack decoded
 -      , StackAnnotation a <- [unsafeCoerce ann]
 -      ]
 +import GHC.Exts.Heap.Closures (GenStgStackClosure)
  {-# NOINLINE printAnnotationStack #-}
  printAnnotationStack :: [String] -> IO ()
@@ -47,8 +37,8 @@ baz = annotateCallStackM $ do
    decodeAnnotationFrames >>= printAnnotationStack
  bar :: IO ()
 -bar = annotateCallStackM $ annotateStackM "bar" $ do
 -  putStrLn "Some more ork in bar"
 +bar = annotateCallStackM $ annotateStringM "bar" $ do
 +  putStrLn "Some more work in bar"
    print (fib 21)
    decodeAnnotationFrames >>= printAnnotationStack
@@ -56,3 +46,23 @@ fib :: Int -> Int
  fib n
    | n <= 1 = 1
    | otherwise = fib (n - 1) + fib (n - 2)
++
 +{-# NOINLINE decodeAnnotationFrames #-}
 +decodeAnnotationFrames :: IO [String]
 +decodeAnnotationFrames = do
 +  stack <- CloneStack.cloneMyStack
 +  decoded <- Decode.decodeStack stack
 +  pure $ unwindStack decoded
++
 +unwindStack :: GenStgStackClosure Box -> [String]
 +unwindStack stack_closure =
 +  [ ann
 +  | a <- ssc_stack stack_closure
 +  , ann <- case a of
 +          AnnFrame _ (Box ann) ->
 +            [ displayStackAnnotation a
 +            | SomeStackAnnotation a <- [unsafeCoerce ann]
 +            ]
 +          UnderflowFrame _ underflow_stack_closure -> unwindStack underflow_stack_closure
 +          _ -> []
 +  ]

libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout

  Start some work
  Annotation stack:
 -main:Main ann_frame002.hs:35-7:35-10
 -main:Main ann_frame002.hs:35-3:35-6
 +ann_frame002.hs:25:7 in main:Main
 +ann_frame002.hs:25:3 in main:Main
  Finish some work
  Some more ork in bar
  Annotation stack:
 -"bar"
 -main:Main ann_frame002.hs:50-7:50-25
 +bar
 +ann_frame002.hs:40:7 in main:Main

libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs

++
 +import GHC.Stack.Annotation.Experimental
 +import Control.Exception.Backtrace
++
 +hello :: Int -> Int -> Int
 +hello x y = annotateShow (x,y) $
 +    x + y + 42
 +{-# OPAQUE hello #-}
++
 +main :: IO ()
 +main = do
 +  setBacktraceMechanismState IPEBacktrace True
 +  print $ hello 2 3
 +  print $ tailCallEx 4 5
++
 +{-# INLINE tailCallEx #-}
 +tailCallEx :: Int -> Int -> Int
 +tailCallEx a b = annotateShow "tailCallEx" $
 +  foo a b
++
 +{-# INLINE foo #-}
 +foo :: Int -> Int -> Int
 +foo a b = annotateShow "foo" $
 +  bar $ a * b
++
 +bar c = annotateShow "bar" $
 +  error $ show $ c + c
++

libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs

++
 +{-# LANGUAGE ScopedTypeVariables #-}
 +{-# OPTIONS_GHC -ddump-to-file -ddump-stg-final -ddump-simpl -dsuppress-all #-}
 +import Control.Monad
 +import GHC.Stack.Types
 +import Control.Exception
 +import Control.Exception.Backtrace
 +import GHC.Stack.Annotation.Experimental
++
 +main :: IO ()
 +main = do
 +  setBacktraceMechanismState IPEBacktrace True
 +  -- foo baz
 +  bar
++
 +foo :: HasCallStack => IO () -> IO ()
 +foo act = annotateCallStackM $ do
 +  putStrLn "Start some work"
 +  act
 +  putStrLn "Finish some work"
++
 +baz :: HasCallStack => IO ()
 +baz = annotateCallStackM $ do
 +  print (fib 20)
 +  throwIO $ ErrorCall "baz is interrupted"
++
 +bar :: IO ()
 +bar = annotateCallStackM $ annotateStringM "bar" $ do
 +  putStrLn "Some more work in bar"
 +  print (annotateCallStack $ fib 21)
++
 +fib :: Int -> Int
 +fib n
 +  | n <= 1 = 1
 +  | n >= 21 = throw $ ErrorCall "This fib implementation supports only up to the 21st fibonacci number"
 +  | otherwise = fib (n - 1) + fib (n - 2)

libraries/ghc-internal/cbits/HeapPrim.cmm

 +#include "Cmm.h"
++
 +aToWordzh (P_ clos)
 +{
 +    return (clos);
 +}
++
 +reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)
 +{
 +    clos1 = UNTAG(clos1);
 +    clos2 = UNTAG(clos2);
 +    return (clos1 == clos2);
 +}

libraries/ghc-internal/cbits/Stack.cmm

 +// Uncomment to enable assertions during development
 +// #define DEBUG 1
++
 +#include "Cmm.h"
++
 +// StgStack_marking was not available in the Stage0 compiler at the time of
 +// writing. Because, it has been added to derivedConstants when Stack.cmm was
 +// developed.
 +#if defined(StgStack_marking)
++
 +// Returns the next stackframe's StgStack* and offset in it. And, an indicator
 +// if this frame is the last one (`hasNext` bit.)
 +// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)
 +advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {
 +  W_ frameSize;
 +  (frameSize) = ccall stackFrameSize(stack, offsetWords);
++
 +  P_ nextClosurePtr;
 +  nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize));
++
 +  P_ stackArrayPtr;
 +  stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack;
++
 +  P_ stackBottom;
 +  W_ stackSize, stackSizeInBytes;
 +  stackSize = TO_W_(StgStack_stack_size(stack));
 +  stackSizeInBytes = WDS(stackSize);
 +  stackBottom = stackSizeInBytes + stackArrayPtr;
++
 +  P_ newStack;
 +  W_ newOffsetWords, hasNext;
 +  if(nextClosurePtr < stackBottom) (likely: True) {
 +    newStack = stack;
 +    newOffsetWords = offsetWords + frameSize;
 +    hasNext = 1;
 +  } else {
 +    P_ underflowFrameStack;
 +    (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords);
 +    if (underflowFrameStack == NULL) (likely: True) {
 +      newStack = NULL;
 +      newOffsetWords = NULL;
 +      hasNext = NULL;
 +    } else {
 +      newStack = underflowFrameStack;
 +      newOffsetWords = NULL;
 +      hasNext = 1;
 +    }
 +  }
++
 +  return (newStack, newOffsetWords, hasNext);
 +}
++
 +// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords)
 +getSmallBitmapzh(P_ stack, W_ offsetWords) {
 +  P_ c;
 +  c = StgStack_sp(stack) + WDS(offsetWords);
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  W_ bitmap, size;
 +  (bitmap) = ccall getBitmapWord(c);
 +  (size) = ccall getBitmapSize(c);
++
 +  return (bitmap, size);
 +}
++
++
 +// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords)
 +getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) {
 +  P_ c;
 +  c = StgStack_sp(stack) + WDS(offsetWords);
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  W_ bitmap, size, specialType;
 +  (bitmap) = ccall getRetFunBitmapWord(c);
 +  (size) = ccall getRetFunBitmapSize(c);
++
 +  return (bitmap, size);
 +}
++
 +// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords)
 +getLargeBitmapzh(P_ stack, W_ offsetWords) {
 +  P_ c, words;
 +  W_ size;
 +  c = StgStack_sp(stack) + WDS(offsetWords);
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  (words) = ccall getLargeBitmap(MyCapability(), c);
 +  (size) = ccall getLargeBitmapSize(c);
++
 +  return (words, size);
 +}
++
 +// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords)
 +getBCOLargeBitmapzh(P_ stack, W_ offsetWords) {
 +  P_ c, words;
 +  W_ size;
 +  c = StgStack_sp(stack) + WDS(offsetWords);
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  (words) = ccall getBCOLargeBitmap(MyCapability(), c);
 +  (size) = ccall getBCOLargeBitmapSize(c);
++
 +  return (words, size);
 +}
++
 +// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords)
 +getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) {
 +  P_ c, words;
 +  W_ size;
 +  c = StgStack_sp(stack) + WDS(offsetWords);
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  (words) = ccall getRetFunLargeBitmap(MyCapability(), c);
 +  (size) = ccall getRetFunSize(c);
++
 +  return (words, size);
 +}
++
 +// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords)
 +getWordzh(P_ stack, W_ offsetWords) {
 +  P_ wordAddr;
 +  wordAddr = (StgStack_sp(stack) + WDS(offsetWords));
 +  return (W_[wordAddr]);
 +}
++
 +// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords)
 +getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) {
 +  P_ closurePtr;
 +  closurePtr = (StgStack_sp(stack) + WDS(offsetWords));
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));
++
 +  P_ next_chunk;
 +  (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(next_chunk));
 +  return (next_chunk);
 +}
++
 +// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords)
 +isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {
 +  P_ c;
 +  c = StgStack_sp(stack) + WDS(offsetWords);
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  W_ type;
 +  (type) = ccall isArgGenBigRetFunType(c);
 +  return (type);
 +}
++
 +// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords)
 +getInfoTableAddrszh(P_ stack, W_ offsetWords) {
 +  P_ p, info_struct, info_ptr;
 +  p = StgStack_sp(stack) + WDS(offsetWords);
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
 +  info_struct = %GET_STD_INFO(UNTAG(p));
 +  info_ptr = %INFO_PTR(UNTAG(p));
 +  return (info_struct, info_ptr);
 +}
++
 +// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)
 +getStackInfoTableAddrzh(P_ stack) {
 +  P_ info;
 +  info = %GET_STD_INFO(UNTAG(stack));
 +  return (info);
 +}
++
 +// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords)
 +getStackClosurezh(P_ stack, W_ offsetWords) {
 +  P_ ptr;
 +  ptr = StgStack_sp(stack) + WDS(offsetWords);
++
 +  P_ closure;
 +  (closure) = ccall getStackClosure(ptr);
 +  return (closure);
 +}
++
 +// (bits32) getStackFieldszh(StgStack* stack)
 +getStackFieldszh(P_ stack){
 +  bits32 size;
 +  size = StgStack_stack_size(stack);
 +  return (size);
 +}
 +#endif

libraries/ghc-internal/cbits/Stack_c.c

 +#include "MachDeps.h"
 +#include "Rts.h"
 +#include "RtsAPI.h"
 +#include "rts/Messages.h"
 +#include "rts/Types.h"
 +#include "rts/storage/ClosureTypes.h"
 +#include "rts/storage/Closures.h"
 +#include "rts/storage/FunTypes.h"
 +#include "rts/storage/InfoTables.h"
++
 +StgWord stackFrameSize(StgStack *stack, StgWord offset) {
 +  StgClosure *c = (StgClosure *)stack->sp + offset;
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
 +  return stack_frame_sizeW(c);
 +}
++
 +StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
 +  StgClosure *frame = (StgClosure *)stack->sp + offset;
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));
 +  const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
++
 +  if (info->i.type == UNDERFLOW_FRAME) {
 +    return ((StgUnderflowFrame *)frame)->next_chunk;
 +  } else {
 +    return NULL;
 +  }
 +}
++
 +// Only exists to make the get_itbl macro available in Haskell code (via FFI).
 +const StgInfoTable *getItbl(StgClosure *closure) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
 +  return get_itbl(closure);
 +};
++
 +StgWord getBitmapSize(StgClosure *c) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  const StgInfoTable *info = get_itbl(c);
 +  StgWord bitmap = info->layout.bitmap;
 +  return BITMAP_SIZE(bitmap);
 +}
++
 +StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
++
 +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 +  switch (fun_info->f.fun_type) {
 +  case ARG_GEN:
 +    return BITMAP_SIZE(fun_info->f.b.bitmap);
 +  case ARG_GEN_BIG:
 +    return GET_FUN_LARGE_BITMAP(fun_info)->size;
 +  default:
 +    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 +  }
 +}
++
 +StgWord getBitmapWord(StgClosure *c) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  const StgInfoTable *info = get_itbl(c);
 +  StgWord bitmap = info->layout.bitmap;
 +  StgWord bitmapWord = BITMAP_BITS(bitmap);
 +  return bitmapWord;
 +}
++
 +StgWord getRetFunBitmapWord(StgRetFun *ret_fun) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
++
 +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 +  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 +  switch (fun_info->f.fun_type) {
 +  case ARG_GEN:
 +    return BITMAP_BITS(fun_info->f.b.bitmap);
 +  case ARG_GEN_BIG:
 +    // Cannot do more than warn and exit.
 +    errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun);
 +    stg_exit(EXIT_INTERNAL_ERROR);
 +  default:
 +    return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
 +  }
 +}
++
 +StgWord getLargeBitmapSize(StgClosure *c) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  const StgInfoTable *info = get_itbl(c);
 +  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
 +  return bitmap->size;
 +}
++
 +StgWord getRetFunSize(StgRetFun *ret_fun) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
++
 +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 +  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 +  switch (fun_info->f.fun_type) {
 +  case ARG_GEN:
 +    return BITMAP_SIZE(fun_info->f.b.bitmap);
 +  case ARG_GEN_BIG:
 +    return GET_FUN_LARGE_BITMAP(fun_info)->size;
 +  default:
 +    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
 +  }
 +}
++
 +StgWord getBCOLargeBitmapSize(StgClosure *c) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  StgBCO *bco = (StgBCO *)*c->payload;
++
 +  return BCO_BITMAP_SIZE(bco);
 +}
++
 +StgWord *getLargeBitmap(Capability *cap, StgClosure *c) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
 +  const StgInfoTable *info = get_itbl(c);
 +  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
++
 +  return bitmap->bitmap;
 +}
++
 +StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
++
 +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 +  StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);
++
 +  return bitmap->bitmap;
 +}
++
 +StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
++
 +  StgBCO *bco = (StgBCO *)*c->payload;
 +  StgLargeBitmap *bitmap = BCO_BITMAP(bco);
++
 +  return bitmap->bitmap;
 +}
++
 +StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {
 +  return frame->next_chunk;
 +}
++
 +StgWord isArgGenBigRetFunType(StgRetFun *ret_fun) {
 +  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
++
 +  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
 +  return fun_info->f.fun_type == ARG_GEN_BIG;
 +}
++
 +StgClosure *getStackClosure(StgClosure **c) { return *c; }

libraries/ghc-internal/ghc-internal.cabal.in

@@ -231,6 +231,12 @@ Library
          GHC.Internal.GHCi
          GHC.Internal.GHCi.Helpers
          GHC.Internal.Generics
 +        GHC.Internal.Heap.Closures
 +        GHC.Internal.Heap.Constants
 +        GHC.Internal.Heap.InfoTable
 +        GHC.Internal.Heap.InfoTable.Types
 +        GHC.Internal.Heap.InfoTableProf
 +        GHC.Internal.Heap.ProfInfo.Types
          GHC.Internal.InfoProv
          GHC.Internal.InfoProv.Types
          GHC.Internal.IO
@@ -283,14 +289,17 @@ Library
          GHC.Internal.RTS.Flags
          GHC.Internal.RTS.Flags.Test
          GHC.Internal.ST
 -        GHC.Internal.Stack.CloneStack
          GHC.Internal.StaticPtr
          GHC.Internal.STRef
          GHC.Internal.Show
          GHC.Internal.Stable
          GHC.Internal.StableName
          GHC.Internal.Stack
 +        GHC.Internal.Stack.Annotation
          GHC.Internal.Stack.CCS
 +        GHC.Internal.Stack.CloneStack
 +        GHC.Internal.Stack.Constants
 +        GHC.Internal.Stack.Decode
          GHC.Internal.Stack.Types
          GHC.Internal.Stats
          GHC.Internal.Storable
@@ -449,9 +458,12 @@ Library
            cbits/popcnt.c
            cbits/vectorQuotRem.c
            cbits/word2float.c
 +          cbits/Stack_c.c
        cmm-sources:
            cbits/StackCloningDecoding.cmm
 +          cbits/Stack.cmm
 +          cbits/HeapPrim.cmm
      if arch(javascript)
        js-sources:

libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs

@@ -7,6 +7,8 @@ module GHC.Internal.Exception.Backtrace where
  import GHC.Internal.Base
  import GHC.Internal.Data.OldList
 +import GHC.Internal.Data.Functor
 +import GHC.Internal.Data.Maybe
  import GHC.Internal.IORef
  import GHC.Internal.IO.Unsafe (unsafePerformIO)
  import GHC.Internal.Exception.Context
@@ -16,6 +18,7 @@ import qualified GHC.Internal.Stack as HCS
  import qualified GHC.Internal.ExecutionStack as ExecStack
  import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
  import qualified GHC.Internal.Stack.CloneStack as CloneStack
 +import qualified GHC.Internal.Stack.Decode as Decode
  import qualified GHC.Internal.Stack.CCS as CCS
  -- | How to collect a backtrace when an exception is thrown.
@@ -37,6 +40,14 @@ data EnabledBacktraceMechanisms =
        , ipeBacktraceEnabled          :: !Bool
+       }
 +data DisplayBacktraceMechanisms =
 +    DisplayBacktraceMechanisms
 +      { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String
 +      , displayHasCallStackBacktrace :: HCS.CallStack -> String
 +      , displayExecutionBacktrace :: [ExecStack.Location] -> String
 +      , displayIpeBacktrace :: CloneStack.StackSnapshot -> String
 +      }
++
  defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms
  defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms
    { costCentreBacktraceEnabled   = False
@@ -45,6 +56,19 @@ defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms
    , ipeBacktraceEnabled          = False
+   }
 +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms
 +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms
 +  { displayCostCentreBacktrace   = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings
 +  , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
 +  , displayExecutionBacktrace    = unlines . map (indent 2 . flip ExecStack.showLocation "")
 +  , displayIpeBacktrace          = unlines . mapMaybe (fmap (indent 2) . Decode.prettyStackFrameWithIpe) . unsafePerformIO . Decode.decodeStackWithIpe
 +  }
 +  where
 +    indent :: Int -> String -> String
 +    indent n s  = replicate n ' ' ++ s
++
 +    prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
++
  backtraceMechanismEnabled :: BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool
  backtraceMechanismEnabled bm =
    case bm of
@@ -69,6 +93,11 @@ enabledBacktraceMechanismsRef =
      unsafePerformIO $ newIORef defaultEnabledBacktraceMechanisms
  {-# NOINLINE enabledBacktraceMechanismsRef #-}
 +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms
 +displayBacktraceMechanismsRef =
 +    unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms
 +{-# NOINLINE displayBacktraceMechanismsRef #-}
++
  -- | Returns the currently enabled 'BacktraceMechanism's.
  getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms
  getEnabledBacktraceMechanisms = readIORef enabledBacktraceMechanismsRef
@@ -86,37 +115,41 @@ setBacktraceMechanismState bm enabled = do
      _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled)
      return ()
 +-- TODO @fendor
 +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms
 +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef
++
 +-- TODO @fendor:
 +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO ()
 +setDisplayBacktraceMechanismsState dbm = do
 +    _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm)
 +    return ()
++
  -- | A collection of backtraces.
  data Backtraces =
      Backtraces {
          btrCostCentre :: Maybe (Ptr CCS.CostCentreStack),
 +        btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String,
          btrHasCallStack :: Maybe HCS.CallStack,
 +        btrDisplayHasCallStack :: HCS.CallStack -> String,
          btrExecutionStack :: Maybe [ExecStack.Location],
 -        btrIpe :: Maybe [CloneStack.StackEntry]
 +        btrDisplayExecutionStack :: [ExecStack.Location] -> String,
 +        btrIpe :: Maybe CloneStack.StackSnapshot,
 +        btrDisplayIpe :: CloneStack.StackSnapshot -> String
+     }
  -- | Render a set of backtraces to a human-readable string.
  displayBacktraces :: Backtraces -> String
  displayBacktraces bts = concat
 -    [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc
 -    , displayOne "Native stack backtrace" btrExecutionStack displayExec
 -    , displayOne "IPE backtrace" btrIpe displayIpe
 -    , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc
 +    [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre
 +    , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack
 +    , displayOne "IPE backtrace" btrIpe btrDisplayIpe
 +    , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack
+     ]
    where
 -    indent :: Int -> String -> String
 -    indent n s  = replicate n ' ' ++ s
+-
 -    -- The unsafePerformIO here is safe as we don't currently unload cost-centres.
 -    displayCc   = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings
 -    displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "")
 -    displayIpe  = unlines . map (indent 2 . CloneStack.prettyStackEntry)
 -    displayHsc  = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
 -      where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
+-
 -    displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
 +    displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String
      displayOne label getBt displ
 -      | Just bt <- getBt bts = concat [label, ":\n", displ bt]
 +      | Just bt <- getBt bts = concat [label, ":\n", displ bts bt]
        | otherwise            = ""
  instance ExceptionAnnotation Backtraces where
@@ -125,12 +158,14 @@ instance ExceptionAnnotation Backtraces where
  -- | Collect a set of 'Backtraces'.
  collectBacktraces :: (?callStack :: CallStack) => IO Backtraces
  collectBacktraces = HCS.withFrozenCallStack $ do
 -    getEnabledBacktraceMechanisms >>= collectBacktraces'
 +    bm <- getEnabledBacktraceMechanisms
 +    dpm <- getDisplayBacktraceMechanisms
 +    collectBacktraces' bm dpm
  collectBacktraces'
      :: (?callStack :: CallStack)
 -    => EnabledBacktraceMechanisms -> IO Backtraces
 -collectBacktraces' enabled = HCS.withFrozenCallStack $ do
 +    => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces
 +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do
      let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a)
          collect mech f
            | backtraceMechanismEnabled mech enabled = f
@@ -144,14 +179,17 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do
      ipe <- collect IPEBacktrace $ do
          stack <- CloneStack.cloneMyStack
 -        stackEntries <- CloneStack.decode stack
 -        return (Just stackEntries)
 +        return (Just stack)
      hcs <- collect HasCallStackBacktrace $ do
          return (Just ?callStack)
      return (Backtraces { btrCostCentre = ccs
 +                       , btrDisplayCostCentre = displayCostCentreBacktrace renderers
                         , btrHasCallStack = hcs
 +                       , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers
                         , btrExecutionStack = exec
 +                       , btrDisplayExecutionStack = displayExecutionBacktrace renderers
                         , btrIpe = ipe
 +                       , btrDisplayIpe = displayIpeBacktrace renderers
                         })

libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs

 +{-# LANGUAGE CPP #-}
 +{-# LANGUAGE ForeignFunctionInterface #-}
 +{-# LANGUAGE GHCForeignImportPrim #-}
 +{-# LANGUAGE MagicHash #-}
 +{-# LANGUAGE RecordWildCards #-}
 +{-# LANGUAGE UnliftedFFITypes #-}
 +{-# LANGUAGE DeriveGeneric #-}
 +{-# LANGUAGE DeriveTraversable #-}
 +-- Late cost centres introduce a thunk in the asBox function, which leads to
 +-- an additional wrapper being added to any value placed inside a box.
 +-- This can be removed once our boot compiler is no longer affected by #25212
 +{-# OPTIONS_GHC -fno-prof-late  #-}
 +{-# LANGUAGE NamedFieldPuns #-}
++
 +module GHC.Internal.Heap.Closures (
 +    -- * Closures
 +      Closure
 +    , GenClosure(..)
 +    , getClosureInfoTbl
 +    , getClosureInfoTbl_maybe
 +    , getClosurePtrArgs
 +    , getClosurePtrArgs_maybe
 +    , PrimType(..)
 +    , WhatNext(..)
 +    , WhyBlocked(..)
 +    , TsoFlags(..)
 +    , allClosures
 +    , closureSize
++
 +    -- * Stack
 +    , StgStackClosure
 +    , GenStgStackClosure(..)
 +    , StackFrame
 +    , GenStackFrame(..)
 +    , StackField
 +    , GenStackField(..)
++
 +    -- * Boxes
 +    , Box(..)
 +    , areBoxesEqual
 +    , asBox
 +    ) where
++
 +import GHC.Internal.Base
 +import GHC.Internal.Show
++
 +import GHC.Internal.Heap.Constants
 +#if defined(PROFILING)
 +import GHC.Internal.Heap.InfoTable () -- see Note [No way-dependent imports]
 +import GHC.Internal.Heap.InfoTableProf
 +#else
 +import GHC.Internal.Heap.InfoTable
 +import GHC.Internal.Heap.InfoTableProf () -- see Note [No way-dependent imports]
++
 +{-
 +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)
 +-}
 +#endif
++
 +import GHC.Internal.Heap.ProfInfo.Types
++
 +import GHC.Internal.Data.Bits
 +import GHC.Internal.Data.Foldable (Foldable, toList)
 +import GHC.Internal.Data.Traversable (Traversable)
 +import GHC.Internal.Int
 +import GHC.Internal.Num
 +import GHC.Internal.Real
 +import GHC.Internal.Word
 +import GHC.Internal.Exts
 +import GHC.Internal.Generics
 +import GHC.Internal.Numeric
 +import GHC.Internal.Stack (HasCallStack)
++
 +------------------------------------------------------------------------
 +-- Boxes
++
 +foreign import prim "aToWordzh" aToWord# :: Any -> Word#
++
 +foreign import prim "reallyUnsafePtrEqualityUpToTag"
 +    reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
++
 +-- | An arbitrary Haskell value in a safe Box. The point is that even
 +-- unevaluated thunks can safely be moved around inside the Box, and when
 +-- required, e.g. in 'getBoxedClosureData', the function knows how far it has
 +-- to evaluate the argument.
 +data Box = Box Any
++
 +instance Show Box where
 +-- From libraries/base/GHC/Ptr.lhs
 +   showsPrec _ (Box a) rs =
 +    -- unsafePerformIO (print "↓" >> pClosure a) `seq`
 +    pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
 +     where
 +       ptr  = W# (aToWord# a)
 +       tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
 +       addr = ptr - tag
 +       pad_out ls = '0':'x':ls
++
 +-- |This takes an arbitrary value and puts it into a box.
 +-- Note that calls like
 +--
 +-- > asBox (head list)
 +--
 +-- will put the thunk \"head list\" into the box, /not/ the element at the head
 +-- of the list. For that, use careful case expressions:
 +--
 +-- > case list of x:_ -> asBox x
 +asBox :: a -> Box
 +asBox x = Box (unsafeCoerce# x)
++
 +-- | Boxes can be compared, but this is not pure, as different heap objects can,
 +-- after garbage collection, become the same object.
 +areBoxesEqual :: Box -> Box -> IO Bool
 +areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
 +    0# -> pure False
 +    _  -> pure True
++
++
 +------------------------------------------------------------------------
 +-- Closures
 +type Closure = GenClosure Box
++
 +-- | This is the representation of a Haskell value on the heap. It reflects
 +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Closures.h>
 +--
 +-- The data type is parametrized by `b`: the type to store references in.
 +-- Usually this is a 'Box' with the type synonym 'Closure'.
 +--
 +-- All Heap objects have the same basic layout. A header containing a pointer to
 +-- the info table and a payload with various fields. The @info@ field below
 +-- always refers to the info table pointed to by the header. The remaining
 +-- fields are the payload.
 +--
 +-- See
 +-- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects>
 +-- for more information.
 +data GenClosure b
 +  = -- | A data constructor
 +    ConstrClosure
 +        { info       :: !StgInfoTable
 +        , ptrArgs    :: ![b]            -- ^ Pointer arguments
 +        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
 +        , pkg        :: !String         -- ^ Package name
 +        , modl       :: !String         -- ^ Module name
 +        , name       :: !String         -- ^ Constructor name
 +        }
++
 +    -- | A function
 +  | FunClosure
 +        { info       :: !StgInfoTable
 +        , ptrArgs    :: ![b]            -- ^ Pointer arguments
 +        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
 +        }
++
 +    -- | A thunk, an expression not obviously in head normal form
 +  | ThunkClosure
 +        { info       :: !StgInfoTable
 +        , ptrArgs    :: ![b]            -- ^ Pointer arguments
 +        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
 +        }
++
 +    -- | A thunk which performs a simple selection operation
 +  | SelectorClosure
 +        { info       :: !StgInfoTable
 +        , selectee   :: !b              -- ^ Pointer to the object being
 +                                        --   selected from
 +        }
++
 +    -- | An unsaturated function application
 +  | PAPClosure
 +        { info       :: !StgInfoTable
 +        , arity      :: !HalfWord       -- ^ Arity of the partial application
 +        , n_args     :: !HalfWord       -- ^ Size of the payload in words
 +        , fun        :: !b              -- ^ Pointer to a 'FunClosure'
 +        , payload    :: ![b]            -- ^ Sequence of already applied
 +                                        --   arguments
 +        }
++
 +    -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported
 +    -- functions fun actually find the name here.
 +    -- At least the other direction works via "lookupSymbol
 +    -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
 +    -- | A function application
 +  | APClosure
 +        { info       :: !StgInfoTable
 +        , arity      :: !HalfWord       -- ^ Always 0
 +        , n_args     :: !HalfWord       -- ^ Size of payload in words
 +        , fun        :: !b              -- ^ Pointer to a 'FunClosure'
 +        , payload    :: ![b]            -- ^ Sequence of already applied
 +                                        --   arguments
 +        }
++
 +    -- | A suspended thunk evaluation
 +  | APStackClosure
 +        { info       :: !StgInfoTable
 +        , fun        :: !b              -- ^ Function closure
 +        , payload    :: ![b]            -- ^ Stack right before suspension
 +        }
++
 +    -- | A pointer to another closure, introduced when a thunk is updated
 +    -- to point at its value
 +  | IndClosure
 +        { info       :: !StgInfoTable
 +        , indirectee :: !b              -- ^ Target closure
 +        }
++
 +   -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code
 +   -- interpreter (e.g. as used by GHCi)
 +  | BCOClosure
 +        { info       :: !StgInfoTable
 +        , instrs     :: !b              -- ^ A pointer to an ArrWords
 +                                        --   of instructions
 +        , literals   :: !b              -- ^ A pointer to an ArrWords
 +                                        --   of literals
 +        , bcoptrs    :: !b              -- ^ A pointer to an ArrWords
 +                                        --   of byte code objects
 +        , arity      :: !HalfWord       -- ^ The arity of this BCO
 +        , size       :: !HalfWord       -- ^ The size of this BCO in words
 +        , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the
 +                                        --   pointerhood of its args/free vars
 +        }
++
 +    -- | A thunk under evaluation by another thread
 +  | BlackholeClosure
 +        { info       :: !StgInfoTable
 +        , indirectee :: !b              -- ^ The target closure
 +        }
++
 +    -- | A @ByteArray#@
 +  | ArrWordsClosure
 +        { info       :: !StgInfoTable
 +        , bytes      :: !Word           -- ^ Size of array in bytes
 +        , arrWords   :: ![Word]         -- ^ Array payload
 +        }
++
 +    -- | A @MutableByteArray#@
 +  | MutArrClosure
 +        { info       :: !StgInfoTable
 +        , mccPtrs    :: !Word           -- ^ Number of pointers
 +        , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h
 +        , mccPayload :: ![b]            -- ^ Array payload
 +        -- Card table ignored
 +        }
++
 +    -- | A @SmallMutableArray#@
 +    --
 +    -- @since 8.10.1
 +  | SmallMutArrClosure
 +        { info       :: !StgInfoTable
 +        , mccPtrs    :: !Word           -- ^ Number of pointers
 +        , mccPayload :: ![b]            -- ^ Array payload
 +        }
++
 +  -- | An @MVar#@, with a queue of thread state objects blocking on them
 +  | MVarClosure
 +    { info       :: !StgInfoTable
 +    , queueHead  :: !b              -- ^ Pointer to head of queue
 +    , queueTail  :: !b              -- ^ Pointer to tail of queue
 +    , value      :: !b              -- ^ Pointer to closure
 +    }
++
 +    -- | An @IOPort#@, with a queue of thread state objects blocking on them
 +  | IOPortClosure
 +        { info       :: !StgInfoTable
 +        , queueHead  :: !b              -- ^ Pointer to head of queue
 +        , queueTail  :: !b              -- ^ Pointer to tail of queue
 +        , value      :: !b              -- ^ Pointer to closure
 +        }
++
 +    -- | A @MutVar#@
 +  | MutVarClosure
 +        { info       :: !StgInfoTable
 +        , var        :: !b              -- ^ Pointer to contents
 +        }
++
 +    -- | An STM blocking queue.
 +  | BlockingQueueClosure
 +        { info       :: !StgInfoTable
 +        , link       :: !b              -- ^ ?? Here so it looks like an IND
 +        , blackHole  :: !b              -- ^ The blackhole closure
 +        , owner      :: !b              -- ^ The owning thread state object
 +        , queue      :: !b              -- ^ ??
 +        }
++
 +  | WeakClosure
 +        { info        :: !StgInfoTable
 +        , cfinalizers :: !b
 +        , key         :: !b
 +        , value       :: !b
 +        , finalizer   :: !b
 +        , weakLink    :: !(Maybe b) -- ^ next weak pointer for the capability
 +        }
++
 +  -- | Representation of StgTSO: A Thread State Object. The values for
 +  -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@.
 +  | TSOClosure
 +      { info                :: !StgInfoTable
 +      -- pointers
 +      , link                :: !b
 +      , global_link         :: !b
 +      , tsoStack            :: !b -- ^ stackobj from StgTSO
 +      , trec                :: !b
 +      , blocked_exceptions  :: !b
 +      , bq                  :: !b
 +      , thread_label        :: !(Maybe b)
 +      -- values
 +      , what_next           :: !WhatNext
 +      , why_blocked         :: !WhyBlocked
 +      , flags               :: ![TsoFlags]
 +      , threadId            :: !Word64
 +      , saved_errno         :: !Word32
 +      , tso_dirty           :: !Word32 -- ^ non-zero => dirty
 +      , alloc_limit         :: !Int64
 +      , tot_stack_size      :: !Word32
 +      , prof                :: !(Maybe StgTSOProfInfo)
 +      }
++
 +  -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'.
 +  | StackClosure
 +      { info            :: !StgInfoTable
 +      , stack_size      :: !Word32 -- ^ stack size in *words*
 +      , stack_dirty     :: !Word8 -- ^ non-zero => dirty
 +      , stack_marking   :: !Word8
 +      }
++
 +    ------------------------------------------------------------
 +    -- Unboxed unlifted closures
++
 +    -- | Primitive Int
 +  | IntClosure
 +        { ptipe      :: PrimType
 +        , intVal     :: !Int }
++
 +    -- | Primitive Word
 +  | WordClosure
 +        { ptipe      :: PrimType
 +        , wordVal    :: !Word }
++
 +    -- | Primitive Int64
 +  | Int64Closure
 +        { ptipe      :: PrimType
 +        , int64Val   :: !Int64 }
++
 +    -- | Primitive Word64
 +  | Word64Closure
 +        { ptipe      :: PrimType
 +        , word64Val  :: !Word64 }
++
 +    -- | Primitive Addr
 +  | AddrClosure
 +        { ptipe      :: PrimType
 +        , addrVal    :: !(Ptr ()) }
++
 +    -- | Primitive Float
 +  | FloatClosure
 +        { ptipe      :: PrimType
 +        , floatVal   :: !Float }
++
 +    -- | Primitive Double
 +  | DoubleClosure
 +        { ptipe      :: PrimType
 +        , doubleVal  :: !Double }
++
 +    -----------------------------------------------------------
 +    -- Anything else
++
 +    -- | Another kind of closure
 +  | OtherClosure
 +        { info       :: !StgInfoTable
 +        , hvalues    :: ![b]
 +        , rawWords   :: ![Word]
 +        }
++
 +  | UnsupportedClosure
 +        { info       :: !StgInfoTable
 +        }
++
 +    -- | A primitive word from a bitmap encoded stack frame payload
 +    --
 +    -- The type itself cannot be restored (i.e. it might represent a Word8#
 +    -- or an Int#).
 +  |  UnknownTypeWordSizedPrimitive
 +        { wordVal :: !Word }
 +  deriving (Show, Generic, Functor, Foldable, Traversable)
++
 +-- | Get the info table for a heap closure, or Nothing for a prim value
 +--
 +-- @since 9.14.1
 +getClosureInfoTbl_maybe :: GenClosure b -> Maybe StgInfoTable
 +{-# INLINE getClosureInfoTbl_maybe #-} -- Ensure we can get rid of the just box
 +getClosureInfoTbl_maybe closure = case closure of
 +  ConstrClosure{info} ->Just info
 +  FunClosure{info} ->Just info
 +  ThunkClosure{info} ->Just info
 +  SelectorClosure{info} ->Just info
 +  PAPClosure{info} ->Just info
 +  APClosure{info} ->Just info
 +  APStackClosure{info} ->Just info
 +  IndClosure{info} ->Just info
 +  BCOClosure{info} ->Just info
 +  BlackholeClosure{info} ->Just info
 +  ArrWordsClosure{info} ->Just info
 +  MutArrClosure{info} ->Just info
 +  SmallMutArrClosure{info} ->Just info
 +  MVarClosure{info} ->Just info
 +  IOPortClosure{info} ->Just info
 +  MutVarClosure{info} ->Just info
 +  BlockingQueueClosure{info} ->Just info
 +  WeakClosure{info} ->Just info
 +  TSOClosure{info} ->Just info
 +  StackClosure{info} ->Just info
++
 +  IntClosure{} -> Nothing
 +  WordClosure{} -> Nothing
 +  Int64Closure{} -> Nothing
 +  Word64Closure{} -> Nothing
 +  AddrClosure{} -> Nothing
 +  FloatClosure{} -> Nothing
 +  DoubleClosure{} -> Nothing
++
 +  OtherClosure{info} -> Just info
 +  UnsupportedClosure {info} -> Just info
++
 +  UnknownTypeWordSizedPrimitive{} -> Nothing
++
 +-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a
 +-- heap closure.
 +--
 +-- @since 9.14.1
 +getClosureInfoTbl :: HasCallStack => GenClosure b -> StgInfoTable
 +getClosureInfoTbl closure = case getClosureInfoTbl_maybe closure of
 +  Just info -> info
 +  Nothing -> error "getClosureInfoTbl - Closure without info table"
++
 +-- | Get the info table for a heap closure, or Nothing for a prim value
 +--
 +-- @since 9.14.1
 +getClosurePtrArgs_maybe :: GenClosure b -> Maybe [b]
 +{-# INLINE getClosurePtrArgs_maybe #-} -- Ensure we can get rid of the just box
 +getClosurePtrArgs_maybe closure = case closure of
 +  ConstrClosure{ptrArgs} -> Just ptrArgs
 +  FunClosure{ptrArgs} -> Just ptrArgs
 +  ThunkClosure{ptrArgs} -> Just ptrArgs
 +  SelectorClosure{} -> Nothing
 +  PAPClosure{} -> Nothing
 +  APClosure{} -> Nothing
 +  APStackClosure{} -> Nothing
 +  IndClosure{} -> Nothing
 +  BCOClosure{} -> Nothing
 +  BlackholeClosure{} -> Nothing
 +  ArrWordsClosure{} -> Nothing
 +  MutArrClosure{} -> Nothing
 +  SmallMutArrClosure{} -> Nothing
 +  MVarClosure{} -> Nothing
 +  IOPortClosure{} -> Nothing
 +  MutVarClosure{} -> Nothing
 +  BlockingQueueClosure{} -> Nothing
 +  WeakClosure{} -> Nothing
 +  TSOClosure{} -> Nothing
 +  StackClosure{} -> Nothing
++
 +  IntClosure{} -> Nothing
 +  WordClosure{} -> Nothing
 +  Int64Closure{} -> Nothing
 +  Word64Closure{} -> Nothing
 +  AddrClosure{} -> Nothing
 +  FloatClosure{} -> Nothing
 +  DoubleClosure{} -> Nothing
++
 +  OtherClosure{} -> Nothing
 +  UnsupportedClosure{} -> Nothing
++
 +  UnknownTypeWordSizedPrimitive{} -> Nothing
++
 +-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a
 +-- heap closure.
 +--
 +-- @since 9.14.1
 +getClosurePtrArgs :: HasCallStack => GenClosure b -> [b]
 +getClosurePtrArgs closure = case getClosurePtrArgs_maybe closure of
 +  Just ptrs -> ptrs
 +  Nothing -> error "getClosurePtrArgs - Closure without ptrArgs field"
++
 +type StgStackClosure = GenStgStackClosure Box
++
 +-- | A decoded @StgStack@ with `StackFrame`s
 +--
 +-- Stack related data structures (`GenStgStackClosure`, `GenStackField`,
 +-- `GenStackFrame`) are defined separately from `GenClosure` as their related
 +-- functions are very different. Though, both are closures in the sense of RTS
 +-- structures, their decoding logic differs: While it's safe to keep a reference
 +-- to a heap closure, the garbage collector does not update references to stack
 +-- located closures.
 +--
 +-- Additionally, stack frames don't appear outside of the stack. Thus, keeping
 +-- `GenStackFrame` and `GenClosure` separated, makes these types more precise
 +-- (in the sense what values to expect.)
 +data GenStgStackClosure b = GenStgStackClosure
 +      { ssc_info            :: !StgInfoTable
 +      , ssc_stack_size      :: !Word32 -- ^ stack size in *words*
 +      , ssc_stack           :: ![GenStackFrame b]
 +      }
 +  deriving (Foldable, Functor, Generic, Show, Traversable)
++
 +type StackField = GenStackField Box
++
 +-- | Bitmap-encoded payload on the stack
 +data GenStackField b
 +    -- | A non-pointer field
 +    = StackWord !Word
 +    -- | A pointer field
 +    | StackBox  !b
 +  deriving (Foldable, Functor, Generic, Show, Traversable)
++
 +type StackFrame = GenStackFrame Box
++
 +-- | A single stack frame
 +data GenStackFrame b =
 +   UpdateFrame
 +      { info_tbl           :: !StgInfoTable
 +      , updatee            :: !b
 +      }
++
 +  | CatchFrame
 +      { info_tbl            :: !StgInfoTable
 +      , handler             :: !b
 +      }
++
 +  | CatchStmFrame
 +      { info_tbl            :: !StgInfoTable
 +      , catchFrameCode      :: !b
 +      , handler             :: !b
 +      }
++
 +  | CatchRetryFrame
 +      { info_tbl            :: !StgInfoTable
 +      , running_alt_code    :: !Word
 +      , first_code          :: !b
 +      , alt_code            :: !b
 +      }
++
 +  | AtomicallyFrame
 +      { info_tbl            :: !StgInfoTable
 +      , atomicallyFrameCode :: !b
 +      , result              :: !b
 +      }
++
 +  | UnderflowFrame
 +      { info_tbl            :: !StgInfoTable
 +      , nextChunk           :: !(GenStgStackClosure b)
 +      }
++
 +  | StopFrame
 +      { info_tbl            :: !StgInfoTable }
++
 +  | RetSmall
 +      { info_tbl            :: !StgInfoTable
 +      , stack_payload       :: ![GenStackField b]
 +      }
++
 +  | RetBig
 +      { info_tbl            :: !StgInfoTable
 +      , stack_payload       :: ![GenStackField b]
 +      }
++
 +  | RetFun
 +      { info_tbl            :: !StgInfoTable
 +      , retFunSize          :: !Word
 +      , retFunFun           :: !b
 +      , retFunPayload       :: ![GenStackField b]
 +      }
++
 +  | RetBCO
 +      { info_tbl            :: !StgInfoTable
 +      , bco                 :: !b -- ^ always a BCOClosure
 +      , bcoArgs             :: ![GenStackField b]
 +      }
 +  | AnnFrame
 +      { info_tbl            :: !StgInfoTable
 +      , annotation          :: !b
 +      }
 +  deriving (Foldable, Functor, Generic, Show, Traversable)
++
 +data PrimType
 +  = PInt
 +  | PWord
 +  | PInt64
 +  | PWord64
 +  | PAddr
 +  | PFloat
 +  | PDouble
 +  deriving (Eq, Show, Generic, Ord)
++
 +data WhatNext
 +  = ThreadRunGHC
 +  | ThreadInterpret
 +  | ThreadKilled
 +  | ThreadComplete
 +  | WhatNextUnknownValue Word16 -- ^ Please report this as a bug
 +  deriving (Eq, Show, Generic, Ord)
++
 +data WhyBlocked
 +  = NotBlocked
 +  | BlockedOnMVar
 +  | BlockedOnMVarRead
 +  | BlockedOnBlackHole
 +  | BlockedOnRead
 +  | BlockedOnWrite
 +  | BlockedOnDelay
 +  | BlockedOnSTM
 +  | BlockedOnDoProc
 +  | BlockedOnCCall
 +  | BlockedOnCCall_Interruptible
 +  | BlockedOnMsgThrowTo
 +  | ThreadMigrating
 +  | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug
 +  deriving (Eq, Show, Generic, Ord)
++
 +data TsoFlags
 +  = TsoLocked
 +  | TsoBlockx
 +  | TsoInterruptible
 +  | TsoStoppedOnBreakpoint
 +  | TsoMarked
 +  | TsoSqueezed
 +  | TsoAllocLimit
 +  | TsoStopNextBreakpoint
 +  | TsoStopAfterReturn
 +  | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
 +  deriving (Eq, Show, Generic, Ord)
++
 +-- | For generic code, this function returns all referenced closures.
 +allClosures :: GenClosure b -> [b]
 +allClosures (ConstrClosure {..}) = ptrArgs
 +allClosures (ThunkClosure {..}) = ptrArgs
 +allClosures (SelectorClosure {..}) = [selectee]
 +allClosures (IndClosure {..}) = [indirectee]
 +allClosures (BlackholeClosure {..}) = [indirectee]
 +allClosures (APClosure {..}) = fun:payload
 +allClosures (PAPClosure {..}) = fun:payload
 +allClosures (APStackClosure {..}) = fun:payload
 +allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]
 +allClosures (ArrWordsClosure {}) = []
 +allClosures (MutArrClosure {..}) = mccPayload
 +allClosures (SmallMutArrClosure {..}) = mccPayload
 +allClosures (MutVarClosure {..}) = [var]
 +allClosures (MVarClosure {..}) = [queueHead,queueTail,value]
 +allClosures (IOPortClosure {..}) = [queueHead,queueTail,value]
 +allClosures (FunClosure {..}) = ptrArgs
 +allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
 +allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ GHC.Internal.Data.Foldable.toList weakLink
 +allClosures (OtherClosure {..}) = hvalues
 +allClosures _ = []
++
 +-- | Get the size of the top-level closure in words.
 +-- Includes header and payload. Does not follow pointers.
 +--
 +-- @since 8.10.1
 +closureSize :: Box -> Int
 +closureSize (Box x) = I# (closureSize# x)

libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc

 +{-# LANGUAGE CPP #-}
++
 +module GHC.Internal.Heap.Constants
 +    ( wORD_SIZE
 +    , tAG_MASK
 +    , wORD_SIZE_IN_BITS
 +    ) where
++
 +#include "MachDeps.h"
++
 +import GHC.Internal.Data.Bits
 +import GHC.Internal.Int
 +import GHC.Internal.Num
++
 +wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int
 +wORD_SIZE = #const SIZEOF_HSWORD
 +wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS
 +tAG_MASK = (1 `shift` #const TAG_BITS) - 1

libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc

 +module GHC.Internal.Heap.InfoTable
 +    ( module GHC.Internal.Heap.InfoTable.Types
 +    , itblSize
 +    , peekItbl
 +    , pokeItbl
 +    ) where
++
 +#include "Rts.h"
++
 +import GHC.Internal.Base
 +import GHC.Internal.Data.Either
 +import GHC.Internal.Real
 +import GHC.Internal.Enum
++
 +import GHC.Internal.Heap.InfoTable.Types
 +#if !defined(TABLES_NEXT_TO_CODE)
 +import GHC.Internal.Heap.Constants
 +import GHC.Internal.Data.Maybe
 +#endif
 +import GHC.Internal.Foreign.Ptr
 +import GHC.Internal.Foreign.Storable
 +import GHC.Internal.Foreign.Marshal.Array
++
 +-------------------------------------------------------------------------
 +-- Profiling specific code
 +--
 +-- The functions that follow all rely on PROFILING. They are duplicated in
 +-- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This
 +-- allows hsc2hs to generate values for both profiling and non-profiling builds.
++
 +-- | Read an InfoTable from the heap into a haskell type.
 +-- WARNING: This code assumes it is passed a pointer to a "standard" info
 +-- table. If tables_next_to_code is disabled, it will look 1 word before the
 +-- start for the entry field.
 +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
 +peekItbl a0 = do
 +#if !defined(TABLES_NEXT_TO_CODE)
 +  let ptr = a0 `plusPtr` (negate wORD_SIZE)
 +  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr
 +#else
 +  let ptr = a0
 +      entry' = Nothing
 +#endif
 +  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
 +  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
 +  tipe'   <- (#peek struct StgInfoTable_, type) ptr
 +  srtlen' <- (#peek struct StgInfoTable_, srt) a0
 +  return StgInfoTable
 +    { entry  = entry'
 +    , ptrs   = ptrs'
 +    , nptrs  = nptrs'
 +    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
 +    , srtlen = srtlen'
 +    , code   = Nothing
 +    }
++
 +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
 +pokeItbl a0 itbl = do
 +#if !defined(TABLES_NEXT_TO_CODE)
 +  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
 +#endif
 +  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
 +  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
 +  (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl)))
 +  (#poke StgInfoTable, srt) a0 (srtlen itbl)
 +#if defined(TABLES_NEXT_TO_CODE)
 +  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)
 +  case code itbl of
 +    Nothing -> return ()
 +    Just (Left xs) -> pokeArray code_offset xs
 +    Just (Right xs) -> pokeArray code_offset xs
 +#endif
 +  where
 +    toHalfWord :: Int -> HalfWord
 +    toHalfWord i = fromIntegral i
++
 +-- | Size in bytes of a standard InfoTable
 +itblSize :: Int
 +itblSize = (#size struct StgInfoTable_)

libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc

 +{-# LANGUAGE DeriveGeneric #-}
 +{-# LANGUAGE DerivingStrategies #-}
 +{-# LANGUAGE GeneralizedNewtypeDeriving #-}
++
 +module GHC.Internal.Heap.InfoTable.Types
 +    ( StgInfoTable(..)
 +    , EntryFunPtr
 +    , HalfWord(..)
 +    , ItblCodes
 +    ) where
++
 +#include "Rts.h"
++
 +import GHC.Internal.Base
 +import GHC.Internal.Generics
 +import GHC.Internal.ClosureTypes
 +import GHC.Internal.Foreign.Ptr
 +import GHC.Internal.Foreign.Storable
 +import GHC.Internal.Enum
 +import GHC.Internal.Num
 +import GHC.Internal.Word
 +import GHC.Internal.Show
 +import GHC.Internal.Real
 +import GHC.Internal.Data.Either
++
 +type ItblCodes = Either [Word8] [Word32]
++
 +#include "ghcautoconf.h"
 +-- Ultra-minimalist version specially for constructors
 +#if SIZEOF_VOID_P == 8
 +type HalfWord' = Word32
 +#elif SIZEOF_VOID_P == 4
 +type HalfWord' = Word16
 +#else
 +#error Unknown SIZEOF_VOID_P
 +#endif
++
 +newtype HalfWord = HalfWord HalfWord'
 +    deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable)
++
 +type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
++
 +-- | This is a somewhat faithful representation of an info table. See
 +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/InfoTables.h>
 +-- for more details on this data structure.
 +data StgInfoTable = StgInfoTable {
 +   entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE
 +   ptrs   :: HalfWord,
 +   nptrs  :: HalfWord,
 +   tipe   :: ClosureType,
 +   srtlen :: HalfWord,
 +   code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE
 +  } deriving (Eq, Show, Generic)

libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc

 +module GHC.Internal.Heap.InfoTableProf
 +    ( module GHC.Internal.Heap.InfoTable.Types
 +    , itblSize
 +    , peekItbl
 +    , pokeItbl
 +    ) where
++
 +-- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl.
 +-- Manually defining PROFILING gives the #peek and #poke macros an accurate
 +-- representation of StgInfoTable_ when hsc2hs runs.
 +#define PROFILING
 +#include "Rts.h"
++
 +import GHC.Internal.Base
 +import GHC.Internal.Data.Either
 +import GHC.Internal.Real
 +import GHC.Internal.Enum
++
 +import GHC.Internal.Heap.InfoTable.Types
 +#if !defined(TABLES_NEXT_TO_CODE)
 +import GHC.Internal.Heap.Constants
 +import GHC.Internal.Data.Maybe
 +#endif
 +import GHC.Internal.Foreign.Ptr
 +import GHC.Internal.Foreign.Storable
 +import GHC.Internal.Foreign.Marshal.Array
++
 +-- | Read an InfoTable from the heap into a haskell type.
 +-- WARNING: This code assumes it is passed a pointer to a "standard" info
 +-- table. If tables_next_to_code is enabled, it will look 1 byte before the
 +-- start for the entry field.
 +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
 +peekItbl a0 = do
 +#if !defined(TABLES_NEXT_TO_CODE)
 +  let ptr = a0 `plusPtr` (negate wORD_SIZE)
 +  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr
 +#else
 +  let ptr = a0
 +      entry' = Nothing
 +#endif
 +  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
 +  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
 +  tipe'   <- (#peek struct StgInfoTable_, type) ptr
 +  srtlen' <- (#peek struct StgInfoTable_, srt) a0
 +  return StgInfoTable
 +    { entry  = entry'
 +    , ptrs   = ptrs'
 +    , nptrs  = nptrs'
 +    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
 +    , srtlen = srtlen'
 +    , code   = Nothing
 +    }
++
 +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
 +pokeItbl a0 itbl = do
 +#if !defined(TABLES_NEXT_TO_CODE)
 +  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
 +#endif
 +  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
 +  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
 +  (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))
 +  (#poke StgInfoTable, srt) a0 (srtlen itbl)
 +#if defined(TABLES_NEXT_TO_CODE)
 +  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)
 +  case code itbl of
 +    Nothing -> return ()
 +    Just (Left xs) -> pokeArray code_offset xs
 +    Just (Right xs) -> pokeArray code_offset xs
 +#endif
++
 +itblSize :: Int
 +itblSize = (#size struct StgInfoTable_)

libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs

 +{-# LANGUAGE DeriveGeneric #-}
++
 +module GHC.Internal.Heap.ProfInfo.Types where
++
 +import GHC.Internal.Base
 +import GHC.Internal.Word
 +import GHC.Internal.Generics
 +import GHC.Internal.Show
++
 +-- | This is a somewhat faithful representation of StgTSOProfInfo. See
 +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h>
 +-- for more details on this data structure.
 +newtype StgTSOProfInfo = StgTSOProfInfo {
 +    cccs :: Maybe CostCentreStack
 +} deriving (Show, Generic, Eq, Ord)
++
 +-- | This is a somewhat faithful representation of CostCentreStack. See
 +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>
 +-- for more details on this data structure.
 +data CostCentreStack = CostCentreStack {
 +    ccs_ccsID :: Int,
 +    ccs_cc :: CostCentre,
 +    ccs_prevStack :: Maybe CostCentreStack,
 +    ccs_indexTable :: Maybe IndexTable,
 +    ccs_root :: Maybe CostCentreStack,
 +    ccs_depth :: Word,
 +    ccs_scc_count :: Word64,
 +    ccs_selected :: Word,
 +    ccs_time_ticks :: Word,
 +    ccs_mem_alloc :: Word64,
 +    ccs_inherited_alloc :: Word64,
 +    ccs_inherited_ticks :: Word
 +} deriving (Show, Generic, Eq, Ord)
++
 +-- | This is a somewhat faithful representation of CostCentre. See
 +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>
 +-- for more details on this data structure.
 +data CostCentre = CostCentre {
 +    cc_ccID :: Int,
 +    cc_label :: String,
 +    cc_module :: String,
 +    cc_srcloc :: Maybe String,
 +    cc_mem_alloc :: Word64,
 +    cc_time_ticks :: Word,
 +    cc_is_caf :: Bool,
 +    cc_link :: Maybe CostCentre
 +} deriving (Show, Generic, Eq, Ord)
++
 +-- | This is a somewhat faithful representation of IndexTable. See
 +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>
 +-- for more details on this data structure.
 +data IndexTable = IndexTable {
 +    it_cc :: CostCentre,
 +    it_ccs :: Maybe CostCentreStack,
 +    it_next :: Maybe IndexTable,
 +    it_back_edge :: Bool
 +} deriving (Show, Generic, Eq, Ord)

libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs

 +{-# LANGUAGE GADTs #-}
 +{-# LANGUAGE ScopedTypeVariables #-}
 +module GHC.Internal.Stack.Annotation (
 +  IsStackAnnotation(..),
 +  SomeStackAnnotation(..),
 +  )
 +  where
++
 +import GHC.Internal.Base
 +import GHC.Internal.Data.Typeable
++
 +-- ----------------------------------------------------------------------------
 +-- IsStackAnnotation
 +-- ----------------------------------------------------------------------------
++
 +class IsStackAnnotation a where
 +  displayStackAnnotation :: a -> String
++
 +-- ----------------------------------------------------------------------------
 +-- Annotations
 +-- ----------------------------------------------------------------------------
++
 +{- |
 +The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
 +When the call stack is annotated with a value of type @a@, behind the scenes it is
 +encapsulated in a @SomeStackAnnotation@.
 +-}
 +data SomeStackAnnotation where
 +  SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation
++
 +instance IsStackAnnotation SomeStackAnnotation where
 +  displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a

libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs

@@ -18,8 +18,8 @@ module GHC.Internal.Stack.CloneStack (
    StackEntry(..),
    cloneMyStack,
    cloneThreadStack,
 -  decode,
 -  prettyStackEntry
 +  decode, -- TODO @fendor: deprecate
 +  toStackEntry, -- TODO @fendor: deprecate
    ) where
  import GHC.Internal.MVar
@@ -40,7 +40,7 @@ import GHC.Internal.ClosureTypes
  --
  -- @since base-4.17.0.0
  data StackSnapshot = StackSnapshot !StackSnapshot#
+-
 +-- TODO @fendor: deprecate
  foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #)
  foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
@@ -208,6 +208,7 @@ cloneThreadStack (ThreadId tid#) = do
  -- | 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.
 +-- TODO @fendor: deprecate
  data StackEntry = StackEntry
    { functionName :: String,
      moduleName :: String,
@@ -232,9 +233,11 @@ data StackEntry = StackEntry
  --     is evaluated.)
  --
  -- @since base-4.17.0.0
 +-- TODO @fendor: deprecate
  decode :: StackSnapshot -> IO [StackEntry]
  decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot
 +-- TODO @fendor: deprecate
  toStackEntry :: InfoProv -> StackEntry
  toStackEntry infoProv =
    StackEntry
@@ -244,6 +247,7 @@ toStackEntry infoProv =
      closureType = ipDesc infoProv
+   }
 +-- TODO @fendor: deprecate
  getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry]
  getDecodedStackArray (StackSnapshot s) =
    IO $ \s0 -> case decodeStack# s s0 of
@@ -263,6 +267,7 @@ getDecodedStackArray (StackSnapshot s) =
      wordSize = sizeOf (nullPtr :: Ptr ())
 +-- TODO @fendor: deprecate
  prettyStackEntry :: StackEntry -> String
  prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
      "  " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"

libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc

 +{-# LANGUAGE CPP #-}
 +{-# LANGUAGE DerivingStrategies #-}
 +{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 +module GHC.Internal.Stack.Constants where
++
 +import GHC.Internal.Base
 +import GHC.Internal.Enum
 +import GHC.Internal.Num
 +import GHC.Internal.Show
 +import GHC.Internal.Real
++
 +#include "Rts.h"
 +#undef BLOCK_SIZE
 +#undef MBLOCK_SIZE
 +#undef BLOCKS_PER_MBLOCK
 +#include "DerivedConstants.h"
++
 +newtype ByteOffset = ByteOffset { offsetInBytes :: Int }
 +  deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
++
 +newtype WordOffset = WordOffset { offsetInWords :: Int }
 +  deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
++
 +offsetStgCatchFrameHandler :: WordOffset
 +offsetStgCatchFrameHandler = byteOffsetToWordOffset $
 +  (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
++
 +sizeStgCatchFrame :: Int
 +sizeStgCatchFrame = bytesToWords $
 +  (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader)
++
 +offsetStgCatchSTMFrameCode :: WordOffset
 +offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $
 +  (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
++
 +offsetStgCatchSTMFrameHandler :: WordOffset
 +offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $
 +  (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
++
 +sizeStgCatchSTMFrame :: Int
 +sizeStgCatchSTMFrame = bytesToWords $
 +  (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader)
++
 +offsetStgUpdateFrameUpdatee :: WordOffset
 +offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $
 +  (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
++
 +sizeStgUpdateFrame :: Int
 +sizeStgUpdateFrame = bytesToWords $
 +  (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader)
++
 +offsetStgAtomicallyFrameCode :: WordOffset
 +offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $
 +  (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
++
 +offsetStgAtomicallyFrameResult :: WordOffset
 +offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $
 +  (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
++
 +sizeStgAtomicallyFrame :: Int
 +sizeStgAtomicallyFrame = bytesToWords $
 +  (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader)
++
 +offsetStgCatchRetryFrameRunningAltCode :: WordOffset
 +offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $
 +  (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
++
 +offsetStgCatchRetryFrameRunningFirstCode :: WordOffset
 +offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $
 +  (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
++
 +offsetStgCatchRetryFrameAltCode :: WordOffset
 +offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $
 +  (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
++
 +sizeStgCatchRetryFrame :: Int
 +sizeStgCatchRetryFrame = bytesToWords $
 +  (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader)
++
 +offsetStgRetFunFrameSize :: WordOffset
 +-- StgRetFun has no header, but only a pointer to the info table at the beginning.
 +offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size)
++
 +offsetStgRetFunFrameFun :: WordOffset
 +offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun)
++
 +offsetStgRetFunFramePayload :: WordOffset
 +offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload)
++
 +sizeStgRetFunFrame :: Int
 +sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun)
++
 +sizeStgAnnFrame :: Int
 +sizeStgAnnFrame = bytesToWords $
 +  (#const SIZEOF_StgAnnFrame_NoHdr) + (#size StgHeader)
++
 +offsetStgAnnFrameAnn :: WordOffset
 +offsetStgAnnFrameAnn = byteOffsetToWordOffset $
 +  (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader)
++
 +offsetStgBCOFrameInstrs :: ByteOffset
 +offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
++
 +offsetStgBCOFrameLiterals :: ByteOffset
 +offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader)
++
 +offsetStgBCOFramePtrs :: ByteOffset
 +offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader)
++
 +offsetStgBCOFrameArity :: ByteOffset
 +offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader)
++
 +offsetStgBCOFrameSize :: ByteOffset
 +offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader)
++
 +offsetStgClosurePayload :: WordOffset
 +offsetStgClosurePayload = byteOffsetToWordOffset $
 +  (#const OFFSET_StgClosure_payload) + (#size StgHeader)
++
 +sizeStgClosure :: Int
 +sizeStgClosure = bytesToWords (#size StgHeader)
++
 +byteOffsetToWordOffset :: ByteOffset -> WordOffset
 +byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger
++
 +bytesToWords :: Int -> Int
 +bytesToWords b =
 +  if b `mod` bytesInWord == 0 then
 +      fromIntegral $ b `div` bytesInWord
 +    else
 +      error "Unexpected struct alignment!"
++
 +bytesInWord :: Int
 +bytesInWord = (#const SIZEOF_VOID_P)
++

libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs

 +{-# LANGUAGE CPP #-}
 +{-# LANGUAGE BangPatterns #-}
 +{-# LANGUAGE DuplicateRecordFields #-}
 +{-# LANGUAGE FlexibleInstances #-}
 +{-# LANGUAGE GHCForeignImportPrim #-}
 +{-# LANGUAGE MagicHash #-}
 +{-# LANGUAGE RankNTypes #-}
 +{-# LANGUAGE RecordWildCards #-}
 +{-# LANGUAGE ScopedTypeVariables #-}
 +{-# LANGUAGE TypeFamilies #-}
 +{-# LANGUAGE TypeInType #-}
 +{-# LANGUAGE UnboxedTuples #-}
 +{-# LANGUAGE UnliftedFFITypes #-}
++
 +module GHC.Internal.Stack.Decode (
 +  decodeStack,
 +  decodeStackWithIpe,
 +  prettyStackFrameWithIpe,
 +  -- * StackEntry
 +  StackEntry(..),
 +  prettyStackEntry,
 +  decode,
 +  )
 +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.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.Heap.InfoTable
 +import GHC.Internal.Stack.Annotation
 +import GHC.Internal.Stack.Constants
 +import GHC.Internal.Stack.CloneStack
 +import GHC.Internal.InfoProv.Types (InfoProv (..), 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# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
 +   in
 +    (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr#)
++
 +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
 +    (\ _ nextChunk -> do
 +      decodeStackWithIpe nextChunk
 +    )
 +    (\ frame mIpe -> pure [(frame, mIpe)])
++
 +unpackStackFrameTo ::
 +  forall a .
 +  StackFrameLocation ->
 +  (StgInfoTable -> StackSnapshot -> IO a) ->
 +  (StackFrame -> Maybe InfoProv -> IO a) ->
 +  IO a
 +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
 +  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
 +  unpackStackFrame' info
 +    (`finaliseStackFrame` m_info_prov)
 +  where
 +    unpackStackFrame' ::
 +      StgInfoTable ->
 +      (StackFrame -> IO a) ->
 +      IO a
 +    unpackStackFrame' info 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
 +          unpackUnderflowFrame info 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)
++
 +-- | 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
++
 +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)
++
 +prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
 +prettyStackFrameWithIpe (frame, mipe) =
 +  case frame of
 +    AnnFrame _ (Box ann) ->
 +      Just $ displayStackAnnotation (unsafeCoerce ann :: SomeStackAnnotation)
 +    _ ->
 +      (prettyStackEntry . toStackEntry) <$> mipe
++
++
 +-- TODO @fendor: deprecate
 +prettyStackEntry :: StackEntry -> String
 +prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
 +  mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"