Hannes Siebenhandl pushed to branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • libraries/base/src/Control/Exception/Backtrace.hs
    ... ... @@ -54,6 +54,11 @@ module Control.Exception.Backtrace
    54 54 
         , Backtraces(..)
    55 55 
         , displayBacktraces
    56 56 
         , collectBacktraces
    57 
    +      -- * Collecting exception annotations (like backtraces)
    58 
    +    , CollectExceptionAnnotationMechanism
    59 
    +    , getCollectExceptionAnnotationMechanism
    60 
    +    , setCollectExceptionAnnotation
    61 
    +    , collectExceptionAnnotation
    57 62 
         ) where
    58 63
    59 64 
     import GHC.Internal.Exception.Backtrace

  • libraries/ghc-internal/src/GHC/Internal/Exception.hs
    ... ... @@ -70,7 +70,7 @@ import GHC.Internal.Show
    70 70 
     import GHC.Internal.Stack.Types
    71 71 
     import GHC.Internal.IO.Unsafe
    72 72 
     import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc, withFrozenCallStack)
    73 
    -import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectBacktraces)
    73 
    +import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectExceptionAnnotation)
    74 74 
     import GHC.Internal.Exception.Type
    75 75
    76 76 
     -- | Throw an exception.  Exceptions may be thrown from purely
    ... ... @@ -166,8 +166,8 @@ toExceptionWithBacktrace :: (HasCallStack, Exception e)
    166 166 
                              => e -> IO SomeException
    167 167 
     toExceptionWithBacktrace e
    168 168 
       | backtraceDesired e = do
    169 
    -      bt <- collectBacktraces
    170 
    -      return (addExceptionContext bt (toException e))
    169 
    +      ea <- collectExceptionAnnotation
    170 
    +      return (addExceptionContext ea (toException e))
    171 171 
       | otherwise = return (toException e)
    172 172
    173 173 
     -- | 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)
    12 12 
     import GHC.Internal.Exception.Context
    13 13 
     import GHC.Internal.Ptr
    14 14 
     import GHC.Internal.Data.Maybe (fromMaybe)
    15 
    -import GHC.Internal.Stack.Types as GHC.Stack (CallStack)
    15 
    +import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
    16 16 
     import qualified GHC.Internal.Stack as HCS
    17 17 
     import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
    18 18 
     import qualified GHC.Internal.Stack.CloneStack as CloneStack
    ... ... @@ -86,6 +86,40 @@ setBacktraceMechanismState bm enabled = do
    86 86 
         _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled)
    87 87 
         return ()
    88 88
    89 
    +-- | How to collect 'ExceptionAnnotation's on throwing 'Exception's.
    90 
    +--
    91 
    +-- @since base-4.23.0.0
    92 
    +data CollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism
    93 
    +  { ceaCollectExceptionAnnotationMechanism :: HasCallStack => IO SomeExceptionAnnotation
    94 
    +  }
    95 
    +
    96 
    +defaultCollectExceptionAnnotationMechanism :: CollectExceptionAnnotationMechanism
    97 
    +defaultCollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism
    98 
    +  { ceaCollectExceptionAnnotationMechanism = SomeExceptionAnnotation `fmap` collectBacktraces
    99 
    +  }
    100 
    +
    101 
    +collectExceptionAnnotationMechanismRef :: IORef CollectExceptionAnnotationMechanism
    102 
    +collectExceptionAnnotationMechanismRef =
    103 
    +    unsafePerformIO $ newIORef defaultCollectExceptionAnnotationMechanism
    104 
    +{-# NOINLINE collectExceptionAnnotationMechanismRef #-}
    105 
    +
    106 
    +-- | Returns the current callback for collecting 'ExceptionAnnotation's on throwing 'Exception's.
    107 
    +--
    108 
    +-- @since base-4.23.0.0
    109 
    +getCollectExceptionAnnotationMechanism :: IO CollectExceptionAnnotationMechanism
    110 
    +getCollectExceptionAnnotationMechanism = readIORef collectExceptionAnnotationMechanismRef
    111 
    +
    112 
    +-- | Set the callback for collecting an 'ExceptionAnnotation'.
    113 
    +--
    114 
    +-- @since base-4.23.0.0
    115 
    +setCollectExceptionAnnotation :: ExceptionAnnotation a => (HasCallStack => IO a) -> IO ()
    116 
    +setCollectExceptionAnnotation collector = do
    117 
    +  let cea = CollectExceptionAnnotationMechanism
    118 
    +        { ceaCollectExceptionAnnotationMechanism = fmap SomeExceptionAnnotation collector
    119 
    +        }
    120 
    +  _ <- atomicModifyIORef'_ collectExceptionAnnotationMechanismRef (const cea)
    121 
    +  return ()
    122 
    +
    89 123 
     -- | A collection of backtraces.
    90 124 
     data Backtraces =
    91 125 
         Backtraces {
    ... ... @@ -124,6 +158,15 @@ displayBacktraces bts = concat
    124 158 
     instance ExceptionAnnotation Backtraces where
    125 159 
         displayExceptionAnnotation = displayBacktraces
    126 160
    161 
    +-- | Collect 'SomeExceptionAnnotation' based on the configuration of the
    162 
    +-- global 'CollectExceptionAnnotationMechanism'.
    163 
    +--
    164 
    +-- @since base-4.23.0.0
    165 
    +collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation
    166 
    +collectExceptionAnnotation = HCS.withFrozenCallStack $ do
    167 
    +  cea <- getCollectExceptionAnnotationMechanism
    168 
    +  ceaCollectExceptionAnnotationMechanism cea
    169 
    +
    127 170 
     -- | Collect a set of 'Backtraces'.
    128 171 
     collectBacktraces :: (?callStack :: CallStack) => IO Backtraces
    129 172 
     collectBacktraces = HCS.withFrozenCallStack $ do

  • libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot
    ... ... @@ -5,11 +5,7 @@ module GHC.Internal.Exception.Backtrace where
    5 5
    6 6 
     import GHC.Internal.Base (IO)
    7 7 
     import GHC.Internal.Stack.Types (HasCallStack)
    8 
    -import GHC.Internal.Exception.Context (ExceptionAnnotation)
    9 
    -
    10 
    -data Backtraces
    11 
    -
    12 
    -instance ExceptionAnnotation Backtraces
    8 
    +import GHC.Internal.Exception.Context (SomeExceptionAnnotation)
    13 9
    14 10 
     -- For GHC.Exception
    15 
    -collectBacktraces :: HasCallStack => IO Backtraces
    11 
    +collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation

  • libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs
    ... ... @@ -99,6 +99,9 @@ displayExceptionContext (ExceptionContext anns0) = mconcat $ intersperse "\n" $
    99 99
    100 100 
     data SomeExceptionAnnotation = forall a. ExceptionAnnotation a => SomeExceptionAnnotation a
    101 101
    102 
    +instance ExceptionAnnotation SomeExceptionAnnotation where
    103 
    +  displayExceptionAnnotation (SomeExceptionAnnotation ann) = displayExceptionAnnotation ann
    104 
    +
    102 105 
     -- | 'ExceptionAnnotation's are types which can decorate exceptions as
    103 106 
     -- 'ExceptionContext'.
    104 107 
     --

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help