Hannes Siebenhandl pushed to branch wip/fendor/ghc-sample-profiler at Glasgow Haskell Compiler / GHC Commits: 67ea2dcc by fendor at 2025-10-17T11:21:16+02:00 Expose more details from stack decoding - - - - - 2 changed files: - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc ===================================== @@ -15,6 +15,7 @@ module GHC.Internal.InfoProv.Types , getIPE , StgInfoTable , lookupIPE + , lookupIpProvId ) where import GHC.Internal.Base @@ -60,6 +61,13 @@ lookupIPE itbl = allocaBytes (#size InfoProvEnt) $ \p -> do 1 -> Just `fmap` peekInfoProv (ipeProv p) _ -> return Nothing +lookupIpProvId :: Ptr StgInfoTable -> IO (Maybe Word64) +lookupIpProvId itbl = allocaBytes (#size InfoProvEnt) $ \p -> do + res <- c_lookupIPE itbl p + case res of + 1 -> Just `fmap` peekIpProvId (ipeProv p) + _ -> return Nothing + getIPE :: a -> r -> (Ptr InfoProvEnt -> IO r) -> IO r getIPE obj fail k = allocaBytes (#size InfoProvEnt) $ \p -> IO $ \s -> case whereFrom## obj (unPtr p) s of ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -25,6 +25,10 @@ module GHC.Internal.Stack.Decode ( -- * Pretty printing prettyStackEntry, prettyStackFrameWithIpe, + -- * Low level decoding functions + StackFrameLocation(..), + unpackStackFrameTo, + getStackFields, ) where @@ -59,6 +63,7 @@ import GHC.Internal.Stack.Annotation import GHC.Internal.Stack.Constants import GHC.Internal.Stack.CloneStack import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) +import qualified GHC.Internal.InfoProv.Types as IPE {- Note [Decoding the stack] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -176,11 +181,11 @@ foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSna -- | 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, Ptr IPE.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#) + (,) <$> peekItbl (Ptr itbl_struct#) <*> pure (Ptr itbl_ptr_ipe_key#) getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -314,8 +319,9 @@ unpackStackFrame stackFrameLoc = do unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)] unpackStackFrameWithIpe stackFrameLoc = do unpackStackFrameTo stackFrameLoc - (\ info mIpe nextChunk@(StackSnapshot stack#) -> do + (\ info infoKey nextChunk@(StackSnapshot stack#) -> do framesWithIpe <- decodeStackWithIpe nextChunk + mIpe <- lookupIPE infoKey pure [ ( UnderflowFrame { info_tbl = info, @@ -330,22 +336,26 @@ unpackStackFrameWithIpe stackFrameLoc = do ) ] ) - (\ frame mIpe -> pure [(frame, mIpe)]) + (\ frame infoKey -> do + mIpe <- lookupIPE infoKey + pure [(frame, mIpe)]) unpackStackFrameTo :: forall a . StackFrameLocation -> -- ^ Decode the given 'StackFrame'. - (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) -> + (StgInfoTable -> Ptr IPE.StgInfoTable -> StackSnapshot -> IO a) -> -- ^ How to handle 'UNDERFLOW_FRAME's. - (StackFrame -> Maybe InfoProv -> IO a) -> + -- The pointer is the key for the 'lookupIPE'. + (StackFrame -> Ptr IPE.StgInfoTable -> IO a) -> -- ^ How to handle all other 'StackFrame' values. + -- The pointer is the key for the 'lookupIPE'. IO a unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do - (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index + (info, infoTablePtr) <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info - (unpackUnderflowFrame info m_info_prov) - (`finaliseStackFrame` m_info_prov) + (unpackUnderflowFrame info infoTablePtr) + (`finaliseStackFrame` infoTablePtr) where unpackStackFrame' :: StgInfoTable -> View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67ea2dcc1582dc863c8c8e3a6af9657d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67ea2dcc1582dc863c8c8e3a6af9657d... You're receiving this email because of your account on gitlab.haskell.org.