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 -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; @@ -112,94 +107,3 @@ 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,8 +15,6 @@ 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 ===================================== @@ -951,7 +951,6 @@ extern char **environ; SymI_HasProto(lookupIPE) \ SymI_HasProto(sendCloneStackMessage) \ SymI_HasProto(cloneStack) \ - SymI_HasProto(decodeClonedStack) \ SymI_HasProto(getUnderflowFrameNextChunkzh) \ SymI_HasProto(getWordzh) \ SymI_HasProto(isArgGenBigRetFunTypezh) \ ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -11680,7 +11680,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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ 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’ @@ -13139,7 +13139,8 @@ 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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ +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.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 ===================================== @@ -14715,7 +14715,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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ 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’ @@ -16171,7 +16171,8 @@ 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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ +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.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 ===================================== @@ -11936,7 +11936,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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ 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’ @@ -13411,7 +13411,8 @@ 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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ +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.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 ===================================== @@ -11680,7 +11680,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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ +instance GHC.Internal.Classes.Eq GHC.Internal.Stack.Decode.StackEntry -- Defined in ‘GHC.Internal.Stack.Decode’ 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’ @@ -13139,7 +13139,8 @@ 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.CloneStack.StackEntry -- Defined in ‘GHC.Internal.Stack.CloneStack’ +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.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/5d9aa6a41c2559c93ae556fb99de9f4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d9aa6a41c2559c93ae556fb99de9f4... You're receiving this email because of your account on gitlab.haskell.org.