Hannes Siebenhandl pushed to branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC Commits: 42c8f304 by fendor at 2025-07-17T19:11:12+02:00 Extend Backtraces to allow configuration of stack decoders Allow the user to overwrite the default stack-decoders in `Backtraces`. Users can then experiment with custom stack decoders, or tweak the output of the stack trace to their liking. We store the stack decoders for each of the supported backtraces in `DisplayBacktraceMechanisms` in a global `IORef`. When collecting `Backtraces`, we also ask for the currently configured stack decoders (specified via `DisplayBacktraceMechanisms`) and use them for printing the `Backtraces`. - - - - - 2 changed files: - libraries/base/src/Control/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs Changes: ===================================== libraries/base/src/Control/Exception/Backtrace.hs ===================================== @@ -50,6 +50,10 @@ module Control.Exception.Backtrace BacktraceMechanism(..) , getBacktraceMechanismState , setBacktraceMechanismState + -- * Display Backtrace mechanisms + , DisplayBacktraceMechanisms(..) + , getDisplayBacktraceMechanisms + , setDisplayBacktraceMechanismsState -- * Collecting backtraces , Backtraces(..) , displayBacktraces ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -11,9 +11,9 @@ import GHC.Internal.IORef import GHC.Internal.IO.Unsafe (unsafePerformIO) import GHC.Internal.Exception.Context import GHC.Internal.Ptr +import GHC.Internal.Data.Maybe (fromMaybe) import GHC.Internal.Stack.Types as GHC.Stack (CallStack) import qualified GHC.Internal.Stack as HCS -import qualified GHC.Internal.ExecutionStack as ExecStack import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack import qualified GHC.Internal.Stack.CCS as CCS @@ -86,37 +86,69 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () --- | A collection of backtraces. +-- | How to display a backtrace when an exception is thrown. +data DisplayBacktraceMechanisms = + DisplayBacktraceMechanisms + { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String + , displayHasCallStackBacktrace :: HCS.CallStack -> String + , displayExecutionBacktrace :: ExecStack.StackTrace -> String + , displayIpeBacktrace :: CloneStack.StackSnapshot -> String + } + +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 "") . fromMaybe [] . ExecStack.stackFrames + , 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 + + +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms +displayBacktraceMechanismsRef = + unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms +{-# NOINLINE displayBacktraceMechanismsRef #-} + +-- | How are the 'Backtraces' going to be displayed? +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef + +-- | Specify how the 'Backtraces' are displayed. +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO () +setDisplayBacktraceMechanismsState dbm = do + _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm) + return () + +-- | A collection of backtraces, paired with a way to display each respective backtrace. data Backtraces = Backtraces { btrCostCentre :: Maybe (Ptr CCS.CostCentreStack), + btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String, btrHasCallStack :: Maybe HCS.CallStack, - btrExecutionStack :: Maybe [ExecStack.Location], - btrIpe :: Maybe [CloneStack.StackEntry] + btrDisplayHasCallStack :: HCS.CallStack -> String, + btrExecutionStack :: Maybe ExecStack.StackTrace, + btrDisplayExecutionStack :: ExecStack.StackTrace -> 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 +157,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 @@ -140,18 +174,21 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do Just `fmap` CCS.getCurrentCCS () exec <- collect ExecutionBacktrace $ do - ExecStack.getStackTrace + ExecStack.collectStackTrace 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/-/commit/42c8f3046d06e4b5f0d8ef913a6b5fe9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42c8f3046d06e4b5f0d8ef913a6b5fe9... You're receiving this email because of your account on gitlab.haskell.org.