Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC
Commits:
da5d69c0 by fendor at 2025-08-25T17:34:24+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
35d83bc5 by fendor at 2025-08-25T17:34:24+02:00
Remove stg_decodeStackzh
- - - - -
15 changed files:
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- rts/CloneStack.c
- rts/CloneStack.h
- rts/RtsSymbols.c
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
libraries/base/src/GHC/Stack/CloneStack.hs
=====================================
@@ -17,3 +17,4 @@ module GHC.Stack.CloneStack (
) where
import GHC.Internal.Stack.CloneStack
+import GHC.Internal.Stack.Decode
=====================================
libraries/ghc-internal/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_entry;
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_entry) = ccall getInfoTablePtrForIPE(UNTAG(p));
+ return (info_struct, info_entry);
}
// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)
=====================================
libraries/ghc-internal/cbits/StackCloningDecoding.cmm
=====================================
@@ -17,10 +17,3 @@ stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) {
return ();
}
-
-stg_decodeStackzh (gcptr stgStack) {
- gcptr stackEntries;
- ("ptr" stackEntries) = ccall decodeClonedStack(MyCapability() "ptr", stgStack "ptr");
-
- return (stackEntries);
-}
=====================================
libraries/ghc-internal/cbits/Stack_c.c
=====================================
@@ -26,10 +26,18 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
}
}
-// Only exists to make the get_itbl macro available in Haskell code (via FFI).
-const StgInfoTable *getItbl(StgClosure *closure) {
+/**
+ * Given a closure pointer, find the address to the StgInfoTable pointer
+ * that is they key for the closure's IPE info.
+ *
+ * @param closure Pointer to the closure to find the StgInfoTable for.
+ * @return Returns a (StgInfoTable *) that can be used for `lookupIPE`.
+ */
+const StgInfoTable *getInfoTablePtrForIPE(StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
- return get_itbl(closure);
+ const StgInfoTable *info_entry;
+ info_entry = GET_INFO(closure);
+ return info_entry;
};
StgWord getBitmapSize(StgClosure *c) {
=====================================
libraries/ghc-internal/jsbits/base.js
=====================================
@@ -1245,9 +1245,21 @@ function h$mkdir(path, path_offset, mode) {
// It is required by Google Closure Compiler to be at least defined if
// somewhere it is used
-var h$stg_cloneMyStackzh, h$stg_decodeStackzh
+var h$stg_cloneMyStackzh,
+ h$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh,
+ h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh,
+ h$isArgGenBigRetFunTypezh,
+ h$getUnderflowFrameNextChunkzh,
+ h$getInfoTableAddrszh,
+ h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh
h$stg_cloneMyStackzh
- = h$stg_decodeStackzh
+ = h$advanceStackFrameLocationzh
+ = h$getStackFieldszh = h$getStackClosurezh
+ = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh
+ = h$isArgGenBigRetFunTypezh
+ = h$getUnderflowFrameNextChunkzh
+ = h$getInfoTableAddrszh
+ = h$getLargeBitmapzh = h$getSmallBitmapzh = h$getBCOLargeBitmapzh
= function () {
throw new Error('Stack Cloning Decoding: Not Implemented Yet')
}
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
import qualified GHC.Internal.Stack.CloneStack as CloneStack
+import qualified GHC.Internal.Stack.Decode as CloneStack
import qualified GHC.Internal.Stack.CCS as CCS
-- | How to collect a backtrace when an exception is thrown.
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
=====================================
@@ -15,34 +15,20 @@
-- @since base-4.17.0.0
module GHC.Internal.Stack.CloneStack (
StackSnapshot(..),
- StackEntry(..),
cloneMyStack,
cloneThreadStack,
- decode,
- prettyStackEntry
) where
import GHC.Internal.MVar
-import GHC.Internal.Data.Maybe (catMaybes)
import GHC.Internal.Base
-import GHC.Internal.Foreign.Storable
import GHC.Internal.Conc.Sync
-import GHC.Internal.IO (unsafeInterleaveIO)
-import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE, StgInfoTable)
-import GHC.Internal.Num
-import GHC.Internal.Real (div)
import GHC.Internal.Stable
-import GHC.Internal.Text.Show
-import GHC.Internal.Ptr
-import GHC.Internal.ClosureTypes
-- | A frozen snapshot of the state of an execution stack.
--
-- @since base-4.17.0.0
data StackSnapshot = StackSnapshot !StackSnapshot#
-foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #)
-
foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #)
@@ -205,64 +191,3 @@ cloneThreadStack (ThreadId tid#) = do
IO $ \s -> case sendCloneStackMessage# tid# ptr s of (# s', (# #) #) -> (# s', () #)
freeStablePtr boxedPtr
takeMVar resultVar
-
--- | Representation for the source location where a return frame was pushed on the stack.
--- This happens every time when a @case ... of@ scrutinee is evaluated.
-data StackEntry = StackEntry
- { functionName :: String,
- moduleName :: String,
- srcLoc :: String,
- closureType :: ClosureType
- }
- deriving (Show, Eq)
-
--- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry').
--- The stack trace is created from return frames with according 'InfoProvEnt'
--- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are
--- no 'InfoProvEnt' entries, an empty list is returned.
---
--- Please note:
---
--- * To gather 'StackEntry' from libraries, these have to be
--- compiled with @-finfo-table-map@, too.
--- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change
--- with different GHC parameters and versions.
--- * The stack trace is empty (by design) if there are no return frames on
--- the stack. (These are pushed every time when a @case ... of@ scrutinee
--- is evaluated.)
---
--- @since base-4.17.0.0
-decode :: StackSnapshot -> IO [StackEntry]
-decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot
-
-toStackEntry :: InfoProv -> StackEntry
-toStackEntry infoProv =
- StackEntry
- { functionName = ipLabel infoProv,
- moduleName = ipMod infoProv,
- srcLoc = ipLoc infoProv,
- closureType = ipDesc infoProv
- }
-
-getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry]
-getDecodedStackArray (StackSnapshot s) =
- IO $ \s0 -> case decodeStack# s s0 of
- (# s1, arr #) ->
- let n = I# (sizeofByteArray# arr) `div` wordSize - 1
- in unIO (go arr n) s1
- where
- go :: ByteArray# -> Int -> IO [Maybe StackEntry]
- go _stack (-1) = return []
- go stack i = do
- infoProv <- lookupIPE (stackEntryAt stack i)
- rest <- unsafeInterleaveIO $ go stack (i-1)
- return ((toStackEntry `fmap` infoProv) : rest)
-
- stackEntryAt :: ByteArray# -> Int -> Ptr StgInfoTable
- stackEntryAt stack (I# i) = Ptr (indexAddrArray# stack i)
-
- wordSize = sizeOf (nullPtr :: Ptr ())
-
-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/Decode.hs
=====================================
@@ -13,7 +13,16 @@
{-# LANGUAGE UnliftedFFITypes #-}
module GHC.Internal.Stack.Decode (
+ -- * High-level stack decoders
+ decode,
decodeStack,
+ decodeStackWithIpe,
+ -- * Stack decoder helpers
+ decodeStackWithFrameUnpack,
+ -- * StackEntry
+ StackEntry(..),
+ -- * Pretty printing
+ prettyStackEntry,
)
where
@@ -23,7 +32,10 @@ import GHC.Internal.Real
import GHC.Internal.Word
import GHC.Internal.Num
import GHC.Internal.Data.Bits
+import GHC.Internal.Data.Functor
+import GHC.Internal.Data.Maybe (catMaybes)
import GHC.Internal.Data.List
+import GHC.Internal.Data.Tuple
import GHC.Internal.Foreign.Ptr
import GHC.Internal.Foreign.Storable
import GHC.Internal.Exts
@@ -42,6 +54,7 @@ import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
import GHC.Internal.Heap.InfoTable
import GHC.Internal.Stack.Constants
import GHC.Internal.Stack.CloneStack
+import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
{- Note [Decoding the stack]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -153,14 +166,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 'InfoProv' for the 'StgInfoTable' if there is any.
+getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe 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#) <*> lookupIPE (Ptr itbl_ptr#)
getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
getInfoTableForStack stackSnapshot# =
@@ -279,18 +295,66 @@ 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 InfoProv)]
+unpackStackFrameWithIpe stackFrameLoc = do
+ unpackStackFrameTo stackFrameLoc
+ (\ info mIpe nextChunk@(StackSnapshot stack#) -> do
+ framesWithIpe <- decodeStackWithIpe nextChunk
+ pure
+ [ ( UnderflowFrame
+ { info_tbl = info,
+ nextChunk =
+ GenStgStackClosure
+ { ssc_info = info,
+ ssc_stack_size = getStackFields stack#,
+ ssc_stack = map fst framesWithIpe
+ }
+ }
+ , mIpe
+ )
+ ]
+ )
+ (\ frame mIpe -> pure [(frame, mIpe)])
+
+unpackStackFrameTo ::
+ forall a .
+ StackFrameLocation ->
+ -- ^ Decode the given 'StackFrame'.
+ (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
+ -- ^ How to handle 'UNDERFLOW_FRAME's.
+ (StackFrame -> Maybe InfoProv -> IO a) ->
+ -- ^ How to handle all other 'StackFrame' values.
+ IO a
+unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
+ (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
unpackStackFrame' info
+ (unpackUnderflowFrame info m_info_prov)
+ (`finaliseStackFrame` m_info_prov)
where
- unpackStackFrame' :: StgInfoTable -> IO StackFrame
- unpackStackFrame' info =
+ unpackStackFrame' ::
+ StgInfoTable ->
+ (StackSnapshot -> IO a) ->
+ (StackFrame -> IO a) ->
+ IO a
+ unpackStackFrame' info mkUnderflowResult mkStackFrameResult =
case tipe info of
RET_BCO -> do
let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload)
-- The arguments begin directly after the payload's one element
bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
- pure
+ mkStackFrameResult
RetBCO
{ info_tbl = info,
bco = bco',
@@ -299,14 +363,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'
@@ -318,7 +382,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',
@@ -328,31 +392,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}
+ mkUnderflowResult 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',
@@ -363,7 +422,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',
@@ -374,7 +433,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',
@@ -383,7 +442,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
ANN_FRAME ->
let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
in
- pure $
+ mkStackFrameResult $
AnnFrame
{ info_tbl = info,
annotation = annotation
@@ -401,6 +460,54 @@ intToWord# i = int2Word# (toInt# i)
wordOffsetToWord# :: WordOffset -> Word#
wordOffsetToWord# wo = intToWord# (fromIntegral wo)
+-- ----------------------------------------------------------------------------
+-- Simplified source location representation of provenance information
+-- ----------------------------------------------------------------------------
+
+-- | Representation for the source location where a return frame was pushed on the stack.
+-- This happens every time when a @case ... of@ scrutinee is evaluated.
+data StackEntry = StackEntry
+ { functionName :: String,
+ moduleName :: String,
+ srcLoc :: String,
+ closureType :: ClosureType
+ }
+ deriving (Show, Eq)
+
+toStackEntry :: InfoProv -> StackEntry
+toStackEntry infoProv =
+ StackEntry
+ { functionName = ipLabel infoProv,
+ moduleName = ipMod infoProv,
+ srcLoc = ipLoc infoProv,
+ closureType = ipDesc infoProv
+ }
+
+-- ----------------------------------------------------------------------------
+-- Stack decoders
+-- ----------------------------------------------------------------------------
+
+-- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry').
+-- The stack trace is created from return frames with according 'InfoProvEnt'
+-- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are
+-- no 'InfoProvEnt' entries, an empty list is returned.
+--
+-- Please note:
+--
+-- * To gather 'StackEntry' from libraries, these have to be
+-- compiled with @-finfo-table-map@, too.
+-- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change
+-- with different GHC parameters and versions.
+-- * The stack trace is empty (by design) if there are no return frames on
+-- the stack. (These are pushed every time when a @case ... of@ scrutinee
+-- is evaluated.)
+--
+-- @since base-4.17.0.0
+decode :: StackSnapshot -> IO [StackEntry]
+decode stackSnapshot =
+ (map toStackEntry . catMaybes . map snd . reverse) <$> decodeStackWithIpe stackSnapshot
+
+
-- | Location of a stackframe on the stack
--
-- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom
@@ -413,19 +520,31 @@ 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 InfoProv)]
+decodeStackWithIpe snapshot =
+ concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
+
+-- ----------------------------------------------------------------------------
+-- Write your own stack decoder!
+-- ----------------------------------------------------------------------------
+
+decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a])
+decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
info <- getInfoTableForStack stack#
case tipe info of
STACK -> do
- let 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]
@@ -436,3 +555,11 @@ decodeStack (StackSnapshot stack#) = do
go :: Maybe StackFrameLocation -> [StackFrameLocation]
go Nothing = []
go (Just r) = r : go (advanceStackFrameLocation r)
+
+-- ----------------------------------------------------------------------------
+-- Pretty printing functions for stack entires, stack frames and provenance info
+-- ----------------------------------------------------------------------------
+
+prettyStackEntry :: StackEntry -> String
+prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
+ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"
=====================================
rts/CloneStack.c
=====================================
@@ -26,11 +26,6 @@
#include