Zubin pushed to branch wip/annotate-frame at Glasgow Haskell Compiler / GHC

Commits:

7 changed files:

Changes:

  • libraries/ghc-internal/src/GHC/Internal/Exception.hs
    ... ... @@ -75,7 +75,7 @@ import GHC.Internal.Stack.Types
    75 75 
     import GHC.Internal.Types (IO, RuntimeRep)
    76 76 
     import GHC.Internal.IO.Unsafe
    77 77 
     import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc, withFrozenCallStack)
    78 
    -import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectExceptionAnnotation)
    78 
    +import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectExceptionContext)
    79 79 
     import GHC.Internal.Exception.Context (SomeExceptionAnnotation(..))
    80 80 
     import GHC.Internal.Exception.Type
    81 81
    ... ... @@ -175,11 +175,13 @@ throw e =
    175 175 
     --  @since base-4.20.0.0
    176 176 
     toExceptionWithBacktrace :: (HasCallStack, Exception e)
    177 177 
                              => e -> IO SomeException
    178 
    -toExceptionWithBacktrace e
    179 
    -  | backtraceDesired e = do
    180 
    -      SomeExceptionAnnotation ea <- collectExceptionAnnotation
    181 
    -      return (addExceptionContext ea (toException e))
    182 
    -  | otherwise = return (toException e)
    178 
    +toExceptionWithBacktrace e = do
    179 
    +    anns <- collectExceptionContext (backtraceDesired e)
    180 
    +    return (applyAnns anns (toException e))
    181 
    +  where
    182 
    +    applyAnns [] se = se
    183 
    +    applyAnns (SomeExceptionAnnotation a : rest) se =
    184 
    +      applyAnns rest (addExceptionContext a se)
    183 185
    184 186 
     -- | This is thrown when the user calls 'error'. The @String@ is the
    185 187 
     -- argument given to 'error'.

  • libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
    ... ... @@ -16,6 +16,8 @@ import GHC.Internal.Maybe (Maybe(..))
    16 16 
     import GHC.Internal.Ptr
    17 17 
     import GHC.Internal.Data.Maybe (fromMaybe, mapMaybe)
    18 18 
     import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
    19 
    +import GHC.Internal.Stack.Annotation (SomeStackAnnotation(..))
    20 
    +import GHC.Internal.Data.Typeable (cast)
    19 21 
     import qualified GHC.Internal.Stack as HCS
    20 22 
     import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
    21 23 
     import qualified GHC.Internal.Stack.CloneStack as CloneStack
    ... ... @@ -94,12 +96,12 @@ setBacktraceMechanismState bm enabled = do
    94 96 
     -- | How to collect 'ExceptionAnnotation's on throwing 'Exception's.
    95 97 
     --
    96 98 
     data CollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism
    97 
    -  { ceaCollectExceptionAnnotationMechanism :: HasCallStack => IO SomeExceptionAnnotation
    99 
    +  { ceaCollectExceptionAnnotationMechanism :: HasCallStack => CloneStack.StackSnapshot -> IO SomeExceptionAnnotation
    98 100 
       }
    99 101
    100 102 
     defaultCollectExceptionAnnotationMechanism :: CollectExceptionAnnotationMechanism
    101 103 
     defaultCollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism
    102 
    -  { ceaCollectExceptionAnnotationMechanism = SomeExceptionAnnotation `fmap` collectBacktraces
    104 
    +  { ceaCollectExceptionAnnotationMechanism = \snapshot -> SomeExceptionAnnotation `fmap` collectBacktracesFrom snapshot
    103 105 
       }
    104 106
    105 107 
     collectExceptionAnnotationMechanismRef :: IORef CollectExceptionAnnotationMechanism
    ... ... @@ -117,7 +119,7 @@ getCollectExceptionAnnotationMechanism = readIORef collectExceptionAnnotationMec
    117 119 
     setCollectExceptionAnnotation :: ExceptionAnnotation a => (HasCallStack => IO a) -> IO ()
    118 120 
     setCollectExceptionAnnotation collector = do
    119 121 
       let cea = CollectExceptionAnnotationMechanism
    120 
    -        { ceaCollectExceptionAnnotationMechanism = fmap SomeExceptionAnnotation collector
    122 
    +        { ceaCollectExceptionAnnotationMechanism = \_ -> fmap SomeExceptionAnnotation collector
    121 123 
             }
    122 124 
       _ <- atomicModifyIORef'_ collectExceptionAnnotationMechanismRef (const cea)
    123 125 
       return ()
    ... ... @@ -165,18 +167,42 @@ instance ExceptionAnnotation Backtraces where
    165 167 
     --
    166 168 
     collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation
    167 169 
     collectExceptionAnnotation = HCS.withFrozenCallStack $ do
    170 
    +  snapshot <- CloneStack.cloneMyStack
    168 171 
       cea <- getCollectExceptionAnnotationMechanism
    169 
    -  ceaCollectExceptionAnnotationMechanism cea
    172 
    +  ceaCollectExceptionAnnotationMechanism cea snapshot
    173 
    +
    174 
    +stackAnnotationsFrom :: CloneStack.StackSnapshot -> IO [SomeExceptionAnnotation]
    175 
    +stackAnnotationsFrom snapshot = do
    176 
    +  anns <- CloneStack.decodeStackAnnotations snapshot
    177 
    +  return (mapMaybe (\(SomeStackAnnotation a) -> cast a) anns)
    178 
    +
    179 
    +collectExceptionContext :: HasCallStack => Bool -> IO [SomeExceptionAnnotation]
    180 
    +collectExceptionContext backtrace_desired = HCS.withFrozenCallStack $ do
    181 
    +  snapshot <- CloneStack.cloneMyStack
    182 
    +  bt <- if backtrace_desired
    183 
    +    then do
    184 
    +      cea <- getCollectExceptionAnnotationMechanism
    185 
    +      ann <- ceaCollectExceptionAnnotationMechanism cea snapshot
    186 
    +      return [ann]
    187 
    +    else return []
    188 
    +  anns <- stackAnnotationsFrom snapshot
    189 
    +  return (bt ++ anns)
    170 190
    171 191 
     -- | Collect a set of 'Backtraces'.
    172 192 
     collectBacktraces :: (?callStack :: CallStack) => IO Backtraces
    173 
    -collectBacktraces = HCS.withFrozenCallStack $ do
    174 
    -    getEnabledBacktraceMechanisms >>= collectBacktraces'
    193 
    +collectBacktraces = HCS.withFrozenCallStack $
    194 
    +    CloneStack.cloneMyStack >>= collectBacktracesFrom
    195 
    +
    196 
    +collectBacktracesFrom
    197 
    +    :: (?callStack :: CallStack)
    198 
    +    => CloneStack.StackSnapshot -> IO Backtraces
    199 
    +collectBacktracesFrom snapshot = HCS.withFrozenCallStack $ do
    200 
    +    getEnabledBacktraceMechanisms >>= collectBacktraces' snapshot
    175 201
    176 202 
     collectBacktraces'
    177 203 
         :: (?callStack :: CallStack)
    178 
    -    => EnabledBacktraceMechanisms -> IO Backtraces
    179 
    -collectBacktraces' enabled = HCS.withFrozenCallStack $ do
    204 
    +    => CloneStack.StackSnapshot -> EnabledBacktraceMechanisms -> IO Backtraces
    205 
    +collectBacktraces' snapshot enabled = HCS.withFrozenCallStack $ do
    180 206 
         let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a)
    181 207 
             collect mech f
    182 208 
               | backtraceMechanismEnabled mech enabled = f
    ... ... @@ -189,8 +215,7 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do
    189 215 
             ExecStack.collectStackTrace
    190 216
    191 217 
         ipe <- collect IPEBacktrace $ do
    192 
    -        stack <- CloneStack.cloneMyStack
    193 
    -        return (Just stack)
    218 
    +        return (Just snapshot)
    194 219
    195 220 
         hcs <- collect HasCallStackBacktrace $ do
    196 221 
             return (Just ?callStack)

  • libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot
    ... ... @@ -4,8 +4,8 @@
    4 4 
     module GHC.Internal.Exception.Backtrace where
    5 5
    6 6 
     import GHC.Internal.Stack.Types (HasCallStack)
    7 
    -import GHC.Internal.Types (IO)
    7 
    +import GHC.Internal.Types (Bool, IO)
    8 8 
     import GHC.Internal.Exception.Context (SomeExceptionAnnotation)
    9 9
    10 10 
     -- For GHC.Exception
    11 
    -collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation
    11 
    +collectExceptionContext :: HasCallStack => Bool -> IO [SomeExceptionAnnotation]

  • libraries/ghc-internal/src/GHC/Internal/IO.hs
    ... ... @@ -54,8 +54,9 @@ import GHC.Internal.Classes ( Eq )
    54 54 
     import GHC.Internal.Magic ( lazy )
    55 55 
     import GHC.Internal.Maybe ( Maybe(..) )
    56 56 
     import GHC.Internal.Prim (
    57 
    -    RealWorld, State#, catch#, getMaskingState#, maskAsyncExceptions#,
    58 
    -    maskUninterruptible#, raiseIO#, unmaskAsyncExceptions#,
    57 
    +    RealWorld, State#, annotateStack#, catch#, getMaskingState#,
    58 
    +    maskAsyncExceptions#, maskUninterruptible#, raiseIO#,
    59 
    +    unmaskAsyncExceptions#,
    59 60 
       )
    60 61 
     import GHC.Internal.ST
    61 62 
     import GHC.Internal.Types ( Char, IO(..) )
    ... ... @@ -65,7 +66,8 @@ import GHC.Internal.Show
    65 66 
     import GHC.Internal.IO.Unsafe
    66 67 
     import GHC.Internal.Unsafe.Coerce ( unsafeCoerce )
    67 68
    68 
    -import GHC.Internal.Exception.Context ( ExceptionAnnotation )
    69 
    +import GHC.Internal.Exception.Context ( ExceptionAnnotation, SomeExceptionAnnotation(..) )
    70 
    +import GHC.Internal.Stack.Annotation ( SomeStackAnnotation(..) )
    69 71 
     import GHC.Internal.Stack.Types ( HasCallStack )
    70 72 
     import {-# SOURCE #-} GHC.Internal.Stack ( withFrozenCallStack )
    71 73 
     import {-# SOURCE #-} GHC.Internal.IO.Exception ( userError, IOError )
    ... ... @@ -245,9 +247,8 @@ catchAny !(IO io) handler = IO $ catch# io handler'
    245 247 
     --
    246 248 
     -- @since base-4.20.0.0
    247 249 
     annotateIO :: forall e a. ExceptionAnnotation e => e -> IO a -> IO a
    248 
    -annotateIO ann (IO io) = IO (catch# io handler)
    249 
    -  where
    250 
    -    handler se = raiseIO# (addExceptionContext ann se)
    250 
    +annotateIO ann (IO io) =
    251 
    +  IO (annotateStack# (SomeStackAnnotation (SomeExceptionAnnotation ann)) io)
    251 252
    252 253 
     -- Using catchException here means that if `m` throws an
    253 254 
     -- 'IOError' /as an imprecise exception/, we will not catch

  • libraries/ghc-internal/src/GHC/Internal/STM.hs
    ... ... @@ -29,16 +29,17 @@ import GHC.Internal.Base (
    29 29 
         Monoid(..), Semigroup(..), ap, liftM2, ($), (.),
    30 30 
       )
    31 31 
     import GHC.Internal.Classes (Eq(..))
    32 
    -import GHC.Internal.Exception (Exception, toExceptionWithBacktrace, fromException, addExceptionContext)
    33 
    -import GHC.Internal.Exception.Context (ExceptionAnnotation)
    32 
    +import GHC.Internal.Exception (Exception, toExceptionWithBacktrace, fromException)
    33 
    +import GHC.Internal.Exception.Context (ExceptionAnnotation, SomeExceptionAnnotation(..))
    34 34 
     import GHC.Internal.Exception.Type (WhileHandling(..))
    35 35 
     import GHC.Internal.Maybe (Maybe(..))
    36 36 
     import GHC.Internal.Prim (
    37 
    -    RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
    38 
    -    newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
    37 
    +    RealWorld, State#, TVar#, annotateStack#, atomically#, catchRetry#,
    38 
    +    catchSTM#, newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
    39 39 
       )
    40 40 
     import GHC.Internal.Prim.PtrEq (sameTVar#)
    41 41 
     import GHC.Internal.Stack (HasCallStack, withFrozenCallStack)
    42 
    +import GHC.Internal.Stack.Annotation (SomeStackAnnotation(..))
    42 43 
     import GHC.Internal.Types (IO(..), isTrue#)
    43 44
    44 45 
     -- TVars are shared memory locations which support atomic memory
    ... ... @@ -217,9 +218,8 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
    217 218 
     -- | Execute an 'STM' action, adding the given 'ExceptionContext'
    218 219 
     -- to any thrown synchronous exceptions.
    219 220 
     annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
    220 
    -annotateSTM ann (STM io) = STM (catch# io handler)
    221 
    -  where
    222 
    -    handler se = raiseIO# (addExceptionContext ann se)
    221 
    +annotateSTM ann (STM io) =
    222 
    +  STM (annotateStack# (SomeStackAnnotation (SomeExceptionAnnotation ann)) io)
    223 223
    224 224 
     -- |Shared memory locations that support atomic memory transactions.
    225 225 
     data TVar a = TVar (TVar# RealWorld a)

  • libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
    ... ... @@ -4,8 +4,10 @@ module GHC.Internal.Stack.Annotation where
    4 4
    5 5 
     import GHC.Internal.Base (String, (++))
    6 6 
     import GHC.Internal.Data.Typeable
    7 
    +import GHC.Internal.Exception.Context (SomeExceptionAnnotation(..), ExceptionAnnotation(..))
    7 8 
     import GHC.Internal.Maybe (Maybe(..))
    8 
    -import GHC.Internal.Stack (SrcLoc, prettySrcLoc)
    9 
    +import GHC.Internal.Stack.Types (SrcLoc)
    10 
    +import {-# SOURCE #-} GHC.Internal.Stack (prettySrcLoc)
    9 11
    10 12 
     -- ----------------------------------------------------------------------------
    11 13 
     -- StackAnnotation
    ... ... @@ -68,3 +70,7 @@ instance StackAnnotation SomeStackAnnotation where
    68 70
    69 71 
       displayStackAnnotationShort (SomeStackAnnotation a) =
    70 72 
         displayStackAnnotationShort a
    73 
    +
    74 
    +instance StackAnnotation SomeExceptionAnnotation where
    75 
    +  displayStackAnnotationShort (SomeExceptionAnnotation a) =
    76 
    +    displayExceptionAnnotation a

  • libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
    ... ... @@ -19,6 +19,7 @@ module GHC.Internal.Stack.Decode (
    19 19 
       decode,
    20 20 
       decodeStack,
    21 21 
       decodeStackWithIpe,
    22 
    +  decodeStackAnnotations,
    22 23 
       -- * Stack decoder helpers
    23 24 
       decodeStackWithFrameUnpack,
    24 25 
       -- * StackEntry
    ... ... @@ -553,6 +554,26 @@ decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)]
    553 554 
     decodeStackWithIpe snapshot =
    554 555 
       concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
    555 556
    557 
    +stackFrameInfoTable :: StackSnapshot# -> WordOffset -> IO StgInfoTable
    558 
    +stackFrameInfoTable stackSnapshot# index =
    559 
    +  case getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) of
    560 
    +    (# itbl#, _ #) -> peekItbl (Ptr itbl#)
    561 
    +
    562 
    +decodeStackAnnotations :: StackSnapshot -> IO [SomeStackAnnotation]
    563 
    +decodeStackAnnotations snapshot =
    564 
    +  concat . snd <$> decodeStackWithFrameUnpack unpackAnnotationFrame snapshot
    565 
    +
    566 
    +unpackAnnotationFrame :: StackFrameLocation -> IO [SomeStackAnnotation]
    567 
    +unpackAnnotationFrame (StackSnapshot stackSnapshot#, index) = do
    568 
    +  itbl <- stackFrameInfoTable stackSnapshot# index
    569 
    +  case tipe itbl of
    570 
    +    ANN_FRAME ->
    571 
    +      case getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) of
    572 
    +        Box ann -> pure [unsafeCoerce ann]
    573 
    +    UNDERFLOW_FRAME ->
    574 
    +      decodeStackAnnotations (getUnderflowFrameNextChunk stackSnapshot# index)
    575 
    +    _ -> pure []
    576 
    +
    556 577 
     -- ----------------------------------------------------------------------------
    557 578 
     -- Write your own stack decoder!
    558 579 
     -- ----------------------------------------------------------------------------

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/8229e600861665aa4e15023f38fdb94ff7744616 at 1786435968