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 +static StgWord getStackFrameCount(StgStack* stack); +static StgWord getStackChunkClosureCount(StgStack* stack); +static StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes); +static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack); + static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack) { StgWord spOffset = stack->sp - stack->stack; @@ -107,3 +112,94 @@ void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED) } #endif // end !defined(THREADED_RTS) + +// Creates a MutableArray# (Haskell representation) that contains a +// InfoProvEnt* for every stack frame on the given stack. Thus, the size of the +// array is the count of stack frames. +// Each InfoProvEnt* is looked up by lookupIPE(). If there's no IPE for a stack +// frame it's represented by null. +StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack) { + StgWord closureCount = getStackFrameCount(stack); + + StgArrBytes* array = allocateByteArray(cap, sizeof(StgInfoTable*) * closureCount); + + copyPtrsToArray(array, stack); + + return array; +} + +// Count the stack frames that are on the given stack. +// This is the sum of all stack frames in all stack chunks of this stack. +StgWord getStackFrameCount(StgStack* stack) { + StgWord closureCount = 0; + StgStack *last_stack = stack; + while (true) { + closureCount += getStackChunkClosureCount(last_stack); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_d_info + ||frame->info == &stg_stack_underflow_frame_v16_info + ||frame->info == &stg_stack_underflow_frame_v32_info + ||frame->info == &stg_stack_underflow_frame_v64_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } + return closureCount; +} + +StgWord getStackChunkClosureCount(StgStack* stack) { + StgWord closureCount = 0; + StgPtr sp = stack->sp; + StgPtr spBottom = stack->stack + stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + closureCount++; + } + + return closureCount; +} + +// Allocate and initialize memory for a ByteArray# (Haskell representation). +StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes) { + // Idea stolen from PrimOps.cmm:stg_newArrayzh() + StgWord words = sizeofW(StgArrBytes) + bytes; + + StgArrBytes* array = (StgArrBytes*) allocate(cap, words); + + SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM); + array->bytes = bytes; + return array; +} + +static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack) { + StgWord index = 0; + StgStack *last_stack = stack; + const StgInfoTable **result = (const StgInfoTable **) arr->payload; + while (true) { + StgPtr sp = last_stack->sp; + StgPtr spBottom = last_stack->stack + last_stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + const StgInfoTable* infoTable = ((StgClosure *)sp)->header.info; + result[index] = infoTable; + index++; + } + + // Ensure that we didn't overflow the result array + ASSERT(index-1 < arr->bytes / sizeof(StgInfoTable*)); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_d_info + ||frame->info == &stg_stack_underflow_frame_v16_info + ||frame->info == &stg_stack_underflow_frame_v32_info + ||frame->info == &stg_stack_underflow_frame_v64_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } +} ===================================== rts/CloneStack.h ===================================== @@ -15,6 +15,8 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack); void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar); +StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack); + #include "BeginPrivate.h" #if defined(THREADED_RTS) ===================================== rts/RtsSymbols.c ===================================== @@ -943,6 +943,7 @@ extern char **environ; SymI_HasProto(lookupIPE) \ SymI_HasProto(sendCloneStackMessage) \ SymI_HasProto(cloneStack) \ + SymI_HasProto(decodeClonedStack) \ SymI_HasProto(stg_newPromptTagzh) \ SymI_HasProto(stg_promptzh) \ SymI_HasProto(stg_control0zh) \ ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -14717,7 +14717,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -16229,8 +16229,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -11938,7 +11938,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13469,8 +13469,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -11682,7 +11682,7 @@ instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.BigNat.BigNat -- Defined in instance GHC.Internal.Classes.Eq GHC.Internal.Bignum.Natural.Natural -- Defined in ‘GHC.Internal.Bignum.Natural’ instance GHC.Internal.Classes.Eq GHC.RTS.Flags.IoManagerFlag -- Defined in ‘GHC.RTS.Flags’ instance forall a. GHC.Internal.Classes.Eq (GHC.Internal.StableName.StableName a) -- Defined in ‘GHC.Internal.StableName’ -instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance forall (n :: GHC.Internal.TypeNats.Nat). GHC.Internal.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance GHC.Internal.Classes.Eq GHC.Internal.TypeNats.SomeNat -- Defined in ‘GHC.Internal.TypeNats’ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ @@ -13197,8 +13197,7 @@ instance GHC.Internal.Show.Show GHC.RTS.Flags.ProfFlags -- Defined in ‘GHC.RTS instance GHC.Internal.Show.Show GHC.RTS.Flags.RTSFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TickyFlags -- Defined in ‘GHC.RTS.Flags’ instance GHC.Internal.Show.Show GHC.RTS.Flags.TraceFlags -- Defined in ‘GHC.RTS.Flags’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.Pointerness -- Defined in ‘GHC.Internal.Stack.Decode’ -instance GHC.Internal.Show.Show GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ +instance GHC.Internal.Show.Show GHC.Internal.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ instance GHC.Internal.Show.Show GHC.Internal.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.Internal.StaticPtr’ instance [safe] GHC.Internal.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance [safe] GHC.Internal.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b92e2bf60bfacbf2c38cb364e0532d2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b92e2bf60bfacbf2c38cb364e0532d2... You're receiving this email because of your account on gitlab.haskell.org.