Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: b8bd47d7 by fendor at 2025-07-16T11:35:47+02:00 WIP: Introduce stack frame annotation helpers and extend ghc-heap stack decoder - - - - - dda9f198 by fendor at 2025-07-16T11:35:47+02:00 WIP: base: extend Backtraces to allow configuration of stack decoders - - - - - 8 changed files: - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/cbits/Stack.cmm - libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs Changes: ===================================== libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs ===================================== @@ -3,65 +3,106 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ImplicitParams #-} -module GHC.Stack.Annotation.Experimental where +module GHC.Stack.Annotation.Experimental ( + IsStackAnnotation(..), + SomeStackAnnotation(..), + -- * Source Location annotations + SrcLocAnnotation, + UnknownSrcLocAnnotation, + -- * Stack annotations + annotateStack, + annotateShow, + annotateStackM, + annotateStringM, + annotateStackShowM, + annotateCallStackM, + ) where import Data.Typeable import GHC.Exts import GHC.IO -import GHC.Internal.Stack.Types +import GHC.Internal.Stack -data StackAnnotation where - StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation +-- ---------------------------------------------------------------------------- +-- IsStackAnnotation +-- ---------------------------------------------------------------------------- class IsStackAnnotation a where - display :: a -> String + displayStackAnnotation :: a -> String -instance IsStackAnnotation StackAnnotation where - display (StackAnnotation a) = show a +-- ---------------------------------------------------------------------------- +-- Annotations +-- ---------------------------------------------------------------------------- -newtype SrcLocAnno = MkSrcLocAnno SrcLoc +{- | +The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy. +When the call stack is annotated with a value of type @a@, behind the scenes it is +encapsulated in a @SomeStackAnnotation@. +-} +data SomeStackAnnotation where + SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation -data UnknownSrcLocAnno = UnknownSrcLocAnno +instance IsStackAnnotation SomeStackAnnotation where + displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a + +data StringAnnotation where + StringAnnotation :: String -> StringAnnotation + +instance IsStackAnnotation StringAnnotation where + displayStackAnnotation (StringAnnotation str) = str + +-- ---------------------------------------------------------------------------- +-- Source location annotations +-- ---------------------------------------------------------------------------- + +newtype SrcLocAnnotation = SrcLocAnnotation SrcLoc + +data UnknownSrcLocAnnotation = UnknownSrcLocAnnotation deriving Show -instance Show SrcLocAnno where - show (MkSrcLocAnno l) = - concat - [ srcLocPackage l - , ":" - , srcLocModule l - , " " - , srcLocFile l - , ":" - , show $ srcLocStartLine l - , "-" - , show $ srcLocStartCol l - , ":" - , show $ srcLocEndLine l - , "-" - , show $ srcLocEndCol l - ] - -instance IsStackAnnotation SrcLocAnno where - display = show - -instance IsStackAnnotation UnknownSrcLocAnno where - display UnknownSrcLocAnno = "UnknownSrcLocAnno" +instance Show SrcLocAnnotation where + show (SrcLocAnnotation l) = prettySrcLoc l + +instance IsStackAnnotation SrcLocAnnotation where + displayStackAnnotation = show + +instance IsStackAnnotation UnknownSrcLocAnnotation where + displayStackAnnotation UnknownSrcLocAnnotation = "<no location info>" + +-- ---------------------------------------------------------------------------- +-- Annotate the CallStack! +-- ---------------------------------------------------------------------------- {-# NOINLINE annotateStack #-} -annotateStack :: forall a b. (Typeable a, Show a) => a -> b -> b +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateStack :: forall a b. (Typeable a, IsStackAnnotation a) => a -> b -> b annotateStack ann b = unsafePerformIO $ annotateStackM ann (pure b) -annotateStackM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateShow :: forall a b . (Typeable a, Show a) => a -> b -> b +annotateShow ann = + annotateStack (StringAnnotation $ show ann) + +annotateStackM :: forall a b . (Typeable a, IsStackAnnotation a) => a -> IO b -> IO b annotateStackM ann (IO act) = - IO $ \s -> annotateStack# (StackAnnotation ann) act s + IO $ \s -> annotateStack# (SomeStackAnnotation ann) act s + +annotateStringM :: forall b . String -> IO b -> IO b +annotateStringM ann = + annotateStackM (StringAnnotation ann) + +annotateStackShowM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b +annotateStackShowM ann = + annotateStringM (show ann) annotateCallStackM :: HasCallStack => IO a -> IO a annotateCallStackM act = let cs = getCallStack ?callStack in case cs of - [] -> annotateStackM UnknownSrcLocAnno act - [(_, srcLoc)] -> annotateStackM (MkSrcLocAnno srcLoc) act - (_:(_, srcLoc):_) -> annotateStackM (MkSrcLocAnno srcLoc) act + [] -> annotateStackM UnknownSrcLocAnnotation act + [(_, srcLoc)] -> annotateStackM (SrcLocAnnotation srcLoc) act + (_:(_, srcLoc):_) -> annotateStackM (SrcLocAnnotation srcLoc) act ===================================== libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc ===================================== @@ -24,7 +24,7 @@ import Foreign -- | Read an InfoTable from the heap into a haskell type. -- WARNING: This code assumes it is passed a pointer to a "standard" info --- table. If tables_next_to_code is enabled, it will look 1 byte before the +-- table. If tables_next_to_code is disabled, it will look 1 word before the -- start for the entry field. peekItbl :: Ptr StgInfoTable -> IO StgInfoTable peekItbl a0 = do ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Exts.Stack.Decode ( decodeStack, + decodeStackWithIpe, ) where @@ -36,6 +37,7 @@ import GHC.Exts.Heap.Closures import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS) import GHC.Exts.Heap.InfoTable import GHC.Exts.Stack.Constants +import qualified GHC.Internal.InfoProv.Types as IPE import GHC.Stack.CloneStack import GHC.Word import Prelude @@ -150,14 +152,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 'IPE.InfoProv' for the 'StgInfoTable' if there is any. +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe IPE.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#) <*> IPE.lookupIPE (Ptr itbl_ptr#) getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -276,18 +281,49 @@ 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 IPE.InfoProv)] +unpackStackFrameWithIpe stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ _ nextChunk -> do + decodeStackWithIpe nextChunk + ) + (\ frame mIpe -> pure [(frame, mIpe)]) + +unpackStackFrameTo :: + StackFrameLocation -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> Maybe IPE.InfoProv -> IO a) -> + IO a +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do + (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info + unpackUnderflowFrame + (`finaliseStackFrame` m_info_prov) where - unpackStackFrame' :: StgInfoTable -> IO StackFrame - unpackStackFrame' info = + unpackStackFrame' :: + StgInfoTable -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> IO a) -> + IO a + unpackStackFrame' info unpackUnderflowFrame 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', @@ -296,14 +332,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' @@ -315,7 +351,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', @@ -325,31 +361,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} + unpackUnderflowFrame info 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', @@ -360,7 +391,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', @@ -371,7 +402,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', @@ -380,7 +411,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do ANN_FRAME -> let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) in - pure $ + mkStackFrameResult $ AnnFrame { info_tbl = info, annotation = annotation @@ -410,19 +441,27 @@ 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 IPE.InfoProv)] +decodeStackWithIpe snapshot = + concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot + +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] ===================================== libraries/ghc-heap/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_ptr; 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_ptr = %INFO_PTR(UNTAG(p)); + return (info_struct, info_ptr); } // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs ===================================== @@ -7,7 +7,7 @@ import System.IO.Unsafe import Unsafe.Coerce hello :: Int -> Int -> Int -hello x y = annotateStack (x,y) $ +hello x y = annotateShow (x,y) $ decodeAndPrintAnnotationFrames $! x + y + 42 {-# OPAQUE hello #-} @@ -17,9 +17,9 @@ decodeAndPrintAnnotationFrames :: a -> a decodeAndPrintAnnotationFrames a = unsafePerformIO $ do stack <- GHC.Stack.CloneStack.cloneMyStack decoded <- GHC.Exts.Stack.Decode.decodeStack stack - print [ show a + print [ displayStackAnnotation a | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded - , StackAnnotation a <- pure $ unsafeCoerce ann + , SomeStackAnnotation a <- pure $ unsafeCoerce ann ] pure a @@ -30,13 +30,13 @@ main = do {-# INLINE tailCallEx #-} tailCallEx :: Int -> Int -> Int -tailCallEx a b = annotateStack "tailCallEx" $ foo a b +tailCallEx a b = annotateShow "tailCallEx" $ foo a b {-# INLINE foo #-} foo :: Int -> Int -> Int -foo a b = annotateStack "foo" $ bar $ a * b +foo a b = annotateShow "foo" $ bar $ a * b -bar c = annotateStack "bar" $ +bar c = annotateShow "bar" $ decodeAndPrintAnnotationFrames $ c + c ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs ===================================== @@ -12,17 +12,7 @@ import qualified GHC.Internal.Stack.CloneStack as CloneStack import System.IO.Unsafe import Unsafe.Coerce - -{-# NOINLINE decodeAnnotationFrames #-} -decodeAnnotationFrames :: IO [String] -decodeAnnotationFrames = do - stack <- CloneStack.cloneMyStack - decoded <- Decode.decodeStack stack - pure - [ show a - | AnnFrame _ (Box ann) <- ssc_stack decoded - , StackAnnotation a <- [unsafeCoerce ann] - ] +import GHC.Exts.Heap.Closures (GenStgStackClosure) {-# NOINLINE printAnnotationStack #-} printAnnotationStack :: [String] -> IO () @@ -47,8 +37,8 @@ baz = annotateCallStackM $ do decodeAnnotationFrames >>= printAnnotationStack bar :: IO () -bar = annotateCallStackM $ annotateStackM "bar" $ do - putStrLn "Some more ork in bar" +bar = annotateCallStackM $ annotateStringM "bar" $ do + putStrLn "Some more work in bar" print (fib 21) decodeAnnotationFrames >>= printAnnotationStack @@ -56,3 +46,23 @@ fib :: Int -> Int fib n | n <= 1 = 1 | otherwise = fib (n - 1) + fib (n - 2) + +{-# NOINLINE decodeAnnotationFrames #-} +decodeAnnotationFrames :: IO [String] +decodeAnnotationFrames = do + stack <- CloneStack.cloneMyStack + decoded <- Decode.decodeStack stack + pure $ unwindStack decoded + +unwindStack :: GenStgStackClosure Box -> [String] +unwindStack stack_closure = + [ ann + | a <- ssc_stack stack_closure + , ann <- case a of + AnnFrame _ (Box ann) -> + [ displayStackAnnotation a + | SomeStackAnnotation a <- [unsafeCoerce ann] + ] + UnderflowFrame _ underflow_stack_closure -> unwindStack underflow_stack_closure + _ -> [] + ] ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout ===================================== @@ -1,11 +1,11 @@ Start some work 10946 Annotation stack: -main:Main ann_frame002.hs:35-7:35-10 -main:Main ann_frame002.hs:35-3:35-6 +ann_frame002.hs:25:7 in main:Main +ann_frame002.hs:25:3 in main:Main Finish some work Some more ork in bar 17711 Annotation stack: -"bar" -main:Main ann_frame002.hs:50-7:50-25 +bar +ann_frame002.hs:40:7 in main:Main ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -37,6 +37,14 @@ data EnabledBacktraceMechanisms = , ipeBacktraceEnabled :: !Bool } +data DisplayBacktraceMechanisms = + DisplayBacktraceMechanisms + { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String + , displayHasCallStackBacktrace :: HCS.CallStack -> String + , displayExecutionBacktrace :: [ExecStack.Location] -> String + , displayIpeBacktrace :: CloneStack.StackSnapshot -> String + } + defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms { costCentreBacktraceEnabled = False @@ -45,6 +53,19 @@ defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms , ipeBacktraceEnabled = False } +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms + { displayCostCentreBacktrace = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings + , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack + , displayExecutionBacktrace = unlines . map (indent 2 . flip ExecStack.showLocation "") + , displayIpeBacktrace = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode + } + where + indent :: Int -> String -> String + indent n s = replicate n ' ' ++ s + + prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc + backtraceMechanismEnabled :: BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool backtraceMechanismEnabled bm = case bm of @@ -69,6 +90,11 @@ enabledBacktraceMechanismsRef = unsafePerformIO $ newIORef defaultEnabledBacktraceMechanisms {-# NOINLINE enabledBacktraceMechanismsRef #-} +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms +displayBacktraceMechanismsRef = + unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms +{-# NOINLINE displayBacktraceMechanismsRef #-} + -- | Returns the currently enabled 'BacktraceMechanism's. getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms getEnabledBacktraceMechanisms = readIORef enabledBacktraceMechanismsRef @@ -86,37 +112,41 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () +-- TODO @fendor +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef + +-- TODO @fendor: +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO () +setDisplayBacktraceMechanismsState dbm = do + _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm) + return () + -- | A collection of backtraces. data Backtraces = Backtraces { btrCostCentre :: Maybe (Ptr CCS.CostCentreStack), + btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String, btrHasCallStack :: Maybe HCS.CallStack, + btrDisplayHasCallStack :: HCS.CallStack -> String, btrExecutionStack :: Maybe [ExecStack.Location], - btrIpe :: Maybe [CloneStack.StackEntry] + btrDisplayExecutionStack :: [ExecStack.Location] -> String, + btrIpe :: Maybe CloneStack.StackSnapshot, + btrDisplayIpe :: CloneStack.StackSnapshot -> String } -- | Render a set of backtraces to a human-readable string. displayBacktraces :: Backtraces -> String displayBacktraces bts = concat - [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc - , displayOne "Native stack backtrace" btrExecutionStack displayExec - , displayOne "IPE backtrace" btrIpe displayIpe - , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc + [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre + , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack + , displayOne "IPE backtrace" btrIpe btrDisplayIpe + , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack ] where - indent :: Int -> String -> String - indent n s = replicate n ' ' ++ s - - -- The unsafePerformIO here is safe as we don't currently unload cost-centres. - displayCc = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings - displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) - displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack - where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc - - displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String + displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String displayOne label getBt displ - | Just bt <- getBt bts = concat [label, ":\n", displ bt] + | Just bt <- getBt bts = concat [label, ":\n", displ bts bt] | otherwise = "" instance ExceptionAnnotation Backtraces where @@ -125,12 +155,14 @@ instance ExceptionAnnotation Backtraces where -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do - getEnabledBacktraceMechanisms >>= collectBacktraces' + bm <- getEnabledBacktraceMechanisms + dpm <- getDisplayBacktraceMechanisms + collectBacktraces' bm dpm collectBacktraces' :: (?callStack :: CallStack) - => EnabledBacktraceMechanisms -> IO Backtraces -collectBacktraces' enabled = HCS.withFrozenCallStack $ do + => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a) collect mech f | backtraceMechanismEnabled mech enabled = f @@ -144,14 +176,17 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do ipe <- collect IPEBacktrace $ do stack <- CloneStack.cloneMyStack - stackEntries <- CloneStack.decode stack - return (Just stackEntries) + return (Just stack) hcs <- collect HasCallStackBacktrace $ do return (Just ?callStack) return (Backtraces { btrCostCentre = ccs + , btrDisplayCostCentre = displayCostCentreBacktrace renderers , btrHasCallStack = hcs + , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers , btrExecutionStack = exec + , btrDisplayExecutionStack = displayExecutionBacktrace renderers , btrIpe = ipe + , btrDisplayIpe = displayIpeBacktrace renderers }) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff9d4ecb791f07faf207eadb3e9fb48... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff9d4ecb791f07faf207eadb3e9fb48... You're receiving this email because of your account on gitlab.haskell.org.