Hannes Siebenhandl pushed to branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC Commits: b9374ecd by fendor at 2025-07-21T14:04:30+02:00 Allow users to customise the collection of exception annotations Add a global `CollectExceptionAnnotationMechanism` which determines how `ExceptionAnnotation`s are collected upon throwing an `Exception`. By overriding how we collect `Backtraces`, we can control how the `Backtraces` are displayed to the user by newtyping `Backtraces` and giving a different instance for `ExceptionAnnotation`. A concrete use-case for this feature is allowing us to experiment with alternative stack decoders, without having to modify `base`, which take additional information from the stack frames. This commit does not modify how `Backtraces` are currently collected or displayed. - - - - - 5 changed files: - libraries/base/src/Control/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs Changes: ===================================== libraries/base/src/Control/Exception/Backtrace.hs ===================================== @@ -54,6 +54,11 @@ module Control.Exception.Backtrace , Backtraces(..) , displayBacktraces , collectBacktraces + -- * Collecting exception annotations (like backtraces) + , CollectExceptionAnnotationMechanism + , getCollectExceptionAnnotationMechanism + , setCollectExceptionAnnotation + , collectExceptionAnnotation ) where import GHC.Internal.Exception.Backtrace ===================================== libraries/ghc-internal/src/GHC/Internal/Exception.hs ===================================== @@ -70,7 +70,7 @@ import GHC.Internal.Show import GHC.Internal.Stack.Types import GHC.Internal.IO.Unsafe import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc, withFrozenCallStack) -import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectBacktraces) +import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectExceptionAnnotation) import GHC.Internal.Exception.Type -- | Throw an exception. Exceptions may be thrown from purely @@ -166,8 +166,8 @@ toExceptionWithBacktrace :: (HasCallStack, Exception e) => e -> IO SomeException toExceptionWithBacktrace e | backtraceDesired e = do - bt <- collectBacktraces - return (addExceptionContext bt (toException e)) + ea <- collectExceptionAnnotation + return (addExceptionContext ea (toException e)) | otherwise = return (toException e) -- | This is thrown when the user calls 'error'. The @String@ is the ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -12,7 +12,7 @@ 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 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 @@ -86,6 +86,40 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () +-- | How to collect 'ExceptionAnnotation's on throwing 'Exception's. +-- +-- @since base-4.23.0.0 +data CollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism + { ceaCollectExceptionAnnotationMechanism :: HasCallStack => IO SomeExceptionAnnotation + } + +defaultCollectExceptionAnnotationMechanism :: CollectExceptionAnnotationMechanism +defaultCollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism + { ceaCollectExceptionAnnotationMechanism = SomeExceptionAnnotation `fmap` collectBacktraces + } + +collectExceptionAnnotationMechanismRef :: IORef CollectExceptionAnnotationMechanism +collectExceptionAnnotationMechanismRef = + unsafePerformIO $ newIORef defaultCollectExceptionAnnotationMechanism +{-# NOINLINE collectExceptionAnnotationMechanismRef #-} + +-- | Returns the current callback for collecting 'ExceptionAnnotation's on throwing 'Exception's. +-- +-- @since base-4.23.0.0 +getCollectExceptionAnnotationMechanism :: IO CollectExceptionAnnotationMechanism +getCollectExceptionAnnotationMechanism = readIORef collectExceptionAnnotationMechanismRef + +-- | Set the callback for collecting an 'ExceptionAnnotation'. +-- +-- @since base-4.23.0.0 +setCollectExceptionAnnotation :: ExceptionAnnotation a => (HasCallStack => IO a) -> IO () +setCollectExceptionAnnotation collector = do + let cea = CollectExceptionAnnotationMechanism + { ceaCollectExceptionAnnotationMechanism = fmap SomeExceptionAnnotation collector + } + _ <- atomicModifyIORef'_ collectExceptionAnnotationMechanismRef (const cea) + return () + -- | A collection of backtraces. data Backtraces = Backtraces { @@ -124,6 +158,15 @@ displayBacktraces bts = concat instance ExceptionAnnotation Backtraces where displayExceptionAnnotation = displayBacktraces +-- | Collect 'SomeExceptionAnnotation' based on the configuration of the +-- global 'CollectExceptionAnnotationMechanism'. +-- +-- @since base-4.23.0.0 +collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation +collectExceptionAnnotation = HCS.withFrozenCallStack $ do + cea <- getCollectExceptionAnnotationMechanism + ceaCollectExceptionAnnotationMechanism cea + -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot ===================================== @@ -5,11 +5,7 @@ module GHC.Internal.Exception.Backtrace where import GHC.Internal.Base (IO) import GHC.Internal.Stack.Types (HasCallStack) -import GHC.Internal.Exception.Context (ExceptionAnnotation) - -data Backtraces - -instance ExceptionAnnotation Backtraces +import GHC.Internal.Exception.Context (SomeExceptionAnnotation) -- For GHC.Exception -collectBacktraces :: HasCallStack => IO Backtraces +collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs ===================================== @@ -99,6 +99,9 @@ displayExceptionContext (ExceptionContext anns0) = mconcat $ intersperse "\n" $ data SomeExceptionAnnotation = forall a. ExceptionAnnotation a => SomeExceptionAnnotation a +instance ExceptionAnnotation SomeExceptionAnnotation where + displayExceptionAnnotation (SomeExceptionAnnotation ann) = displayExceptionAnnotation ann + -- | 'ExceptionAnnotation's are types which can decorate exceptions as -- 'ExceptionContext'. -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9374ecd9e73b6eab34f9410fc284d8f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9374ecd9e73b6eab34f9410fc284d8f... You're receiving this email because of your account on gitlab.haskell.org.