Hannes Siebenhandl pushed to branch wip/fendor/revert-backtrace-decoder at Glasgow Haskell Compiler / GHC
Commits:
7f3aa09d by Fendor at 2025-10-18T18:31:34+02:00
Revert "Remove stg_decodeStackzh"
This reverts commit e0544cc8a9d152c57f35bdd5e940020cc3953489.
- - - - -
edaecdfa by fendor at 2025-10-18T18:31:34+02:00
Revert "Implement `decode` in terms of `decodeStackWithIpe`"
This reverts commit bd80bb7013b1c2446557a56779c88e7ad1a06259.
- - - - -
fe9826bb by fendor at 2025-10-18T18:31:34+02:00
Add regression test for #26507
- - - - -
19 changed files:
- compiler/GHC/Rename/Unbound.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- + libraries/ghc-bignum/gmp/gmp-tarballs
- 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
- + libraries/ghc-internal/tests/backtraces/T26507.hs
- libraries/ghc-internal/tests/backtraces/all.T
- 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:
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Rename.Unbound
, IsTermInTypes(..)
, notInScopeErr
, relevantNameSpace
- , suggestionIsRelevant
+ , suggestionIsRelevantp
, termNameInType
)
where
=====================================
libraries/base/src/GHC/Stack/CloneStack.hs
=====================================
@@ -17,4 +17,3 @@ module GHC.Stack.CloneStack (
) where
import GHC.Internal.Stack.CloneStack
-import GHC.Internal.Stack.Decode
=====================================
libraries/ghc-bignum/gmp/gmp-tarballs
=====================================
@@ -0,0 +1 @@
+Subproject commit 01149ce3471128e9fe0feca607579981f4b64395
=====================================
libraries/ghc-internal/cbits/Stack.cmm
=====================================
@@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {
return (type);
}
-// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords)
-getInfoTableAddrszh(P_ stack, W_ offsetWords) {
- P_ p, info_struct, info_ptr_ipe_key;
+// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords)
+getInfoTableAddrzh(P_ stack, W_ offsetWords) {
+ P_ p, info;
p = StgStack_sp(stack) + WDS(offsetWords);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
- info_struct = %GET_STD_INFO(UNTAG(p));
- info_ptr_ipe_key = %INFO_PTR(UNTAG(p));
- return (info_struct, info_ptr_ipe_key);
+ info = %GET_STD_INFO(UNTAG(p));
+
+ return (info);
}
// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)
=====================================
libraries/ghc-internal/cbits/StackCloningDecoding.cmm
=====================================
@@ -17,3 +17,10 @@ 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
=====================================
@@ -30,7 +30,7 @@ StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
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));
=====================================
libraries/ghc-internal/jsbits/base.js
=====================================
@@ -1245,21 +1245,9 @@ 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$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
+var h$stg_cloneMyStackzh, h$stg_decodeStackzh
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_decodeStackzh
= function () {
throw new Error('Stack Cloning Decoding: Not Implemented Yet')
}
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -16,7 +16,6 @@ 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.
@@ -144,7 +143,7 @@ displayBacktraces bts = concat
displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames
-- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor
-- references closures can be garbage collected.
- displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe
+ displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
=====================================
@@ -15,20 +15,34 @@
-- @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, (# #) #)
@@ -191,3 +205,64 @@ 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
=====================================
@@ -14,17 +14,7 @@
{-# LANGUAGE UnliftedFFITypes #-}
module GHC.Internal.Stack.Decode (
- -- * High-level stack decoders
- decode,
decodeStack,
- decodeStackWithIpe,
- -- * Stack decoder helpers
- decodeStackWithFrameUnpack,
- -- * StackEntry
- StackEntry(..),
- -- * Pretty printing
- prettyStackEntry,
- prettyStackFrameWithIpe,
)
where
@@ -34,10 +24,7 @@ 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
@@ -58,7 +45,6 @@ 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 (..), ipLoc, lookupIPE)
{- Note [Decoding the stack]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -170,17 +156,14 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
-foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)
+foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> 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# -> WordOffset -> IO StgInfoTable
getInfoTableOnStack stackSnapshot# index =
- let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
- in
- (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#)
+ let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
+ in peekItbl infoTablePtr
getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
getInfoTableForStack stackSnapshot# =
@@ -299,66 +282,18 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
(bitmapWordPointerness size bitmap)
unpackStackFrame :: StackFrameLocation -> IO StackFrame
-unpackStackFrame stackFrameLoc = do
- unpackStackFrameTo stackFrameLoc
- (\ info _ nextChunk -> do
- stackClosure <- decodeStack nextChunk
- pure $
- UnderflowFrame
- { info_tbl = info,
- nextChunk = stackClosure
- }
- )
- (\ frame _ -> pure frame)
-
-unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)]
-unpackStackFrameWithIpe stackFrameLoc = do
- unpackStackFrameTo stackFrameLoc
- (\ info mIpe nextChunk@(StackSnapshot stack#) -> do
- framesWithIpe <- decodeStackWithIpe nextChunk
- pure
- [ ( UnderflowFrame
- { info_tbl = info,
- nextChunk =
- GenStgStackClosure
- { ssc_info = info,
- ssc_stack_size = getStackFields stack#,
- ssc_stack = map fst framesWithIpe
- }
- }
- , mIpe
- )
- ]
- )
- (\ frame mIpe -> pure [(frame, mIpe)])
-
-unpackStackFrameTo ::
- forall a .
- StackFrameLocation ->
- -- ^ Decode the given 'StackFrame'.
- (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) ->
- -- ^ How to handle 'UNDERFLOW_FRAME's.
- (StackFrame -> Maybe InfoProv -> IO a) ->
- -- ^ How to handle all other 'StackFrame' values.
- IO a
-unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
- (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
+unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
+ info <- getInfoTableOnStack stackSnapshot# index
unpackStackFrame' info
- (unpackUnderflowFrame info m_info_prov)
- (`finaliseStackFrame` m_info_prov)
where
- unpackStackFrame' ::
- StgInfoTable ->
- (StackSnapshot -> IO a) ->
- (StackFrame -> IO a) ->
- IO a
- unpackStackFrame' info mkUnderflowResult mkStackFrameResult =
+ unpackStackFrame' :: StgInfoTable -> IO StackFrame
+ unpackStackFrame' info =
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
+ pure
RetBCO
{ info_tbl = info,
bco = bco',
@@ -367,14 +302,14 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
RET_SMALL ->
let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
in
- mkStackFrameResult $
+ pure $
RetSmall
{ info_tbl = info,
stack_payload = payload'
}
RET_BIG -> do
payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
- mkStackFrameResult $
+ pure $
RetBig
{ info_tbl = info,
stack_payload = payload'
@@ -386,7 +321,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
if isArgGenBigRetFunType stackSnapshot# index == True
then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
- mkStackFrameResult $
+ pure $
RetFun
{ info_tbl = info,
retFunSize = retFunSize',
@@ -396,26 +331,31 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
UPDATE_FRAME ->
let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
in
- mkStackFrameResult $
+ pure $
UpdateFrame
{ info_tbl = info,
updatee = updatee'
}
CATCH_FRAME -> do
let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
- mkStackFrameResult $
+ pure $
CatchFrame
{ info_tbl = info,
handler = handler'
}
UNDERFLOW_FRAME -> do
let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
- mkUnderflowResult nextChunk'
- STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
+ stackClosure <- decodeStack nextChunk'
+ pure $
+ UnderflowFrame
+ { info_tbl = info,
+ nextChunk = stackClosure
+ }
+ STOP_FRAME -> pure $ StopFrame {info_tbl = info}
ATOMICALLY_FRAME -> do
let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
- mkStackFrameResult $
+ pure $
AtomicallyFrame
{ info_tbl = info,
atomicallyFrameCode = atomicallyFrameCode',
@@ -426,7 +366,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
in
- mkStackFrameResult $
+ pure $
CatchRetryFrame
{ info_tbl = info,
running_alt_code = running_alt_code',
@@ -437,7 +377,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
in
- mkStackFrameResult $
+ pure $
CatchStmFrame
{ info_tbl = info,
catchFrameCode = catchFrameCode',
@@ -446,7 +386,7 @@ unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame fi
ANN_FRAME ->
let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
in
- mkStackFrameResult $
+ pure $
AnnFrame
{ info_tbl = info,
annotation = annotation
@@ -464,54 +404,6 @@ 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
@@ -524,31 +416,19 @@ type StackFrameLocation = (StackSnapshot, WordOffset)
--
-- See /Note [Decoding the stack]/.
decodeStack :: StackSnapshot -> IO StgStackClosure
-decodeStack snapshot@(StackSnapshot stack#) = do
- (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot
- pure
- GenStgStackClosure
- { ssc_info = stackInfo,
- ssc_stack_size = getStackFields stack#,
- ssc_stack = ssc_stack
- }
-
-decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)]
-decodeStackWithIpe snapshot =
- concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
-
--- ----------------------------------------------------------------------------
--- Write your own stack decoder!
--- ----------------------------------------------------------------------------
-
-decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a])
-decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
+decodeStack (StackSnapshot stack#) = do
info <- getInfoTableForStack stack#
case tipe info of
STACK -> do
- let sfls = stackFrameLocations stack#
- stack' <- mapM unpackFrame sfls
- pure (info, stack')
+ 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'
+ }
_ -> error $ "Expected STACK closure, got " ++ show info
where
stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
@@ -559,21 +439,3 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
go :: Maybe StackFrameLocation -> [StackFrameLocation]
go Nothing = []
go (Just r) = r : go (advanceStackFrameLocation r)
-
--- ----------------------------------------------------------------------------
--- Pretty printing functions for stack entries, stack frames and provenance info
--- ----------------------------------------------------------------------------
-
-prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
-prettyStackFrameWithIpe (frame, mipe) =
- case frame of
- AnnFrame {annotation = Box someStackAnno } ->
- case unsafeCoerce someStackAnno of
- SomeStackAnnotation ann ->
- Just $ displayStackAnnotation ann
- _ ->
- (prettyStackEntry . toStackEntry) <$> mipe
-
-prettyStackEntry :: StackEntry -> String
-prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
- mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"
=====================================
libraries/ghc-internal/tests/backtraces/T26507.hs
=====================================
@@ -0,0 +1,7 @@
+import GHC.Internal.Control.Exception
+import GHC.Internal.Control.Exception.Backtrace
+
+main :: IO ()
+main = do
+ setBacktraceMechanismState IPEBacktrace True
+ throwIO $ ErrorCall "Throw error"
=====================================
libraries/ghc-internal/tests/backtraces/all.T
=====================================
@@ -1,2 +1,4 @@
test('T14532a', [], compile_and_run, [''])
test('T14532b', [], compile_and_run, [''])
+test('T26507', [extra_ways(['prof'])], compile_and_run, [''])
+
=====================================
rts/CloneStack.c
=====================================
@@ -26,6 +26,11 @@
#include