[Git][ghc/ghc][wip/exception-context] 6 commits: Rethrow with context
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Wed Feb 22 00:03:49 UTC 2023
Ben Gamari pushed to branch wip/exception-context at Glasgow Haskell Compiler / GHC
Commits:
6de24a71 by Ben Gamari at 2022-10-20T22:00:30-04:00
Rethrow with context
- - - - -
8e6f1143 by Ben Gamari at 2022-10-24T10:05:34-04:00
base: Use displayException in top-level exception handler
Happily this also allows us to eliminate a special case for Deadlock
exceptions.
- - - - -
3d07eb4a by Ben Gamari at 2022-10-24T10:25:29-04:00
base: Add throw(IO)NoBacktrace
- - - - -
c1c676e6 by Ben Gamari at 2022-10-24T10:26:14-04:00
squash: withExceptionContext
- - - - -
59d27e38 by Ben Gamari at 2023-02-21T17:55:54-05:00
Update
- - - - -
445b0a32 by Ben Gamari at 2023-02-21T19:03:36-05:00
Freeze callstack
- - - - -
11 changed files:
- libraries/base/Control/Exception.hs
- libraries/base/Control/Exception/Base.hs
- libraries/base/GHC/Conc/Sync.hs
- libraries/base/GHC/Exception.hs
- libraries/base/GHC/Exception/Backtrace.hs
- libraries/base/GHC/Exception/Backtrace.hs-boot
- libraries/base/GHC/Exception/Context.hs
- libraries/base/GHC/Exception/Type.hs
- libraries/base/GHC/IO.hs
- libraries/base/GHC/IO/Exception.hs
- libraries/base/System/Timeout.hs
Changes:
=====================================
libraries/base/Control/Exception.hs
=====================================
@@ -43,7 +43,6 @@ module Control.Exception (
SomeAsyncException(..),
AsyncException(..), -- instance Eq, Ord, Show, Typeable, Exception
asyncExceptionToException, asyncExceptionFromException,
- asyncExceptionToExceptionWithContext,
NonTermination(..),
NestedAtomically(..),
=====================================
libraries/base/Control/Exception/Base.hs
=====================================
@@ -26,7 +26,7 @@ module Control.Exception.Base (
ArrayException(..),
AssertionFailed(..),
SomeAsyncException(..), AsyncException(..),
- asyncExceptionToException, asyncExceptionToExceptionWithContext, asyncExceptionFromException,
+ asyncExceptionToException, asyncExceptionFromException,
NonTermination(..),
NestedAtomically(..),
BlockedIndefinitelyOnMVar(..),
=====================================
libraries/base/GHC/Conc/Sync.hs
=====================================
@@ -106,7 +106,6 @@ module GHC.Conc.Sync
import Foreign
import Foreign.C
-import Data.Typeable
import Data.Maybe
import GHC.Base
@@ -940,11 +939,9 @@ uncaughtExceptionHandler :: IORef (SomeException -> IO ())
uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
where
defaultHandler :: SomeException -> IO ()
- defaultHandler se@(SomeException ex) = do
+ defaultHandler se = do
(hFlush stdout) `catchAny` (\ _ -> return ())
- let msg = case cast ex of
- Just Deadlock -> "no threads to run: infinite loop or deadlock?"
- _ -> showsPrec 0 se ""
+ let msg = displayException se
withCString "%s" $ \cfmt ->
withCString msg $ \cmsg ->
errorBelch cfmt cmsg
=====================================
libraries/base/GHC/Exception.hs
=====================================
@@ -57,7 +57,7 @@ throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
(?callStack :: CallStack, Exception e) => e -> a
throw e =
let !context = unsafePerformIO collectBacktraces
- !exc = toExceptionWithContext e context
+ !exc = addExceptionContext context (toException e)
in raise# exc
-- | This is thrown when the user calls 'error'. The first @String@ is the
=====================================
libraries/base/GHC/Exception/Backtrace.hs
=====================================
@@ -1,6 +1,8 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GADTs #-}
module GHC.Exception.Backtrace
( -- * Backtrace mechanisms
@@ -8,6 +10,8 @@ module GHC.Exception.Backtrace
, setEnabledBacktraceMechanisms
, getEnabledBacktraceMechanisms
-- * Collecting backtraces
+ , Backtraces
+ , getBacktrace
, collectBacktraces
, collectBacktrace
) where
@@ -25,80 +29,102 @@ import qualified GHC.Stack.CloneStack as CloneStack
import qualified GHC.Stack.CCS as CCS
-- | How to collect a backtrace when an exception is thrown.
-data BacktraceMechanism
- = -- | collect cost-centre stack backtraces (only available when built with profiling)
- CostCentreBacktraceMech
- | -- | collect backtraces from native execution stack unwinding
- ExecutionStackBacktraceMech -- TODO: unwind limit?
- | -- | collect backtraces from Info Table Provenance Entries
- IPEBacktraceMech
- | -- | collect 'HasCallStack' backtraces
- HasCallStackBacktraceMech
- deriving (Eq, Show)
-
-enabledBacktraceMechanisms :: IORef [BacktraceMechanism]
-enabledBacktraceMechanisms = unsafePerformIO $ newIORef [HasCallStackBacktraceMech]
+data BacktraceMechanism rep where
+ -- | collect cost-centre stack backtraces (only available when built with profiling)
+ CostCentreBacktrace :: BacktraceMechanism [String] -- TODO: Proper representation
+ -- | collect backtraces from native execution stack unwinding
+ ExecutionStackBacktrace :: BacktraceMechanism String -- TODO: proper representation
+ -- | collect backtraces from Info Table Provenance Entries
+ IPEBacktrace :: BacktraceMechanism [CloneStack.StackEntry]
+ -- | collect 'HasCallStack' backtraces
+ HasCallStackBacktrace :: BacktraceMechanism CallStack
+
+newtype EnabledBacktraceMechanisms =
+ EnabledBacktraceMechanisms {
+ backtraceMechanismEnabled :: forall a. BacktraceMechanism a -> Bool
+ }
+
+defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms
+defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms f
+ where
+ f HasCallStackBacktrace = True
+ f _ = False
+
+enabledBacktraceMechanisms :: IORef EnabledBacktraceMechanisms
+enabledBacktraceMechanisms =
+ unsafePerformIO $ newIORef defaultEnabledBacktraceMechanisms
{-# NOINLINE enabledBacktraceMechanisms #-}
-- | Set how 'Control.Exception.throwIO', et al. collect backtraces.
-setEnabledBacktraceMechanisms :: [BacktraceMechanism] -> IO ()
+setEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms -> IO ()
setEnabledBacktraceMechanisms = writeIORef enabledBacktraceMechanisms
-- | Returns the currently enabled 'BacktraceMechanism's.
-getEnabledBacktraceMechanisms :: IO [BacktraceMechanism]
+getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms
getEnabledBacktraceMechanisms = readIORef enabledBacktraceMechanisms
-collectBacktraces :: HasCallStack => IO ExceptionContext
-collectBacktraces = do
- mechs <- getEnabledBacktraceMechanisms
- mconcat `fmap` mapM collectBacktrace mechs
-
-data CostCentreBacktrace = CostCentreBacktrace [String]
- deriving (Show)
-
-instance ExceptionAnnotation CostCentreBacktrace where
- displayExceptionAnnotation (CostCentreBacktrace strs) = CCS.renderStack strs
-
-data ExecutionBacktrace = ExecutionBacktrace String
- deriving (Show)
-
-instance ExceptionAnnotation ExecutionBacktrace where
- displayExceptionAnnotation (ExecutionBacktrace str) =
- "Native stack backtrace:\n" ++ str
-
-data HasCallStackBacktrace = HasCallStackBacktrace CallStack
- deriving (Show)
-
-instance ExceptionAnnotation HasCallStackBacktrace where
- displayExceptionAnnotation (HasCallStackBacktrace cs) =
- "HasCallStack backtrace:\n" ++ CallStack.prettyCallStack cs
-
-data InfoProvBacktrace = InfoProvBacktrace [CloneStack.StackEntry]
- deriving (Show)
-
-instance ExceptionAnnotation InfoProvBacktrace where
- displayExceptionAnnotation (InfoProvBacktrace stack) =
- "Info table provenance backtrace:\n" ++
- intercalate "\n" (map (" "++) $ map CloneStack.prettyStackEntry stack)
-
-collectBacktrace :: (?callStack :: CallStack) => BacktraceMechanism -> IO ExceptionContext
-collectBacktrace CostCentreBacktraceMech = do
+newtype Backtraces = Backtraces { getBacktrace :: forall a. BacktraceMechanism a -> Maybe a }
+
+displayBacktraces :: Backtraces -> String
+displayBacktraces (Backtraces f) = concat
+ [ displayOne "Cost-centre stack backtrace" CostCentreBacktrace displayCc
+ , displayOne "Native stack backtrace" ExecutionStackBacktrace id
+ , displayOne "IPE backtrace" IPEBacktrace displayIpe
+ , displayOne "HasCallStack backtrace" HasCallStackBacktrace CallStack.prettyCallStack
+ ]
+ where
+ indent :: Int -> String -> String
+ indent n s = replicate n ' ' ++ s
+
+ displayCc = intercalate "\n" . map (indent 4)
+ displayExec = id
+ displayIpe = intercalate "\n" . map (indent 4 . CloneStack.prettyStackEntry)
+
+ displayOne :: String -> BacktraceMechanism rep -> (rep -> String) -> String
+ displayOne label mech displ
+ | Just bt <- f mech = label ++ ":\n" ++ displ bt
+ | otherwise = ""
+
+instance ExceptionAnnotation Backtraces where
+ displayExceptionAnnotation = displayBacktraces
+
+collectBacktraces :: (?callStack :: CallStack) => IO Backtraces
+collectBacktraces = CallStack.withFrozenCallStack $ do
+ EnabledBacktraceMechanisms enabled <- getEnabledBacktraceMechanisms
+ let collect :: BacktraceMechanism a -> IO (Maybe a)
+ collect mech
+ | enabled mech = collectBacktrace mech
+ | otherwise = return Nothing
+
+ ccs <- collect CostCentreBacktrace
+ exec <- collect ExecutionStackBacktrace
+ ipe <- collect IPEBacktrace
+ hcs <- collect HasCallStackBacktrace
+ let f :: BacktraceMechanism rep -> Maybe rep
+ f CostCentreBacktrace = ccs
+ f ExecutionStackBacktrace = exec
+ f IPEBacktrace = ipe
+ f HasCallStackBacktrace = hcs
+ return (Backtraces f)
+
+collectBacktrace :: (?callStack :: CallStack) => BacktraceMechanism a -> IO (Maybe a)
+collectBacktrace CostCentreBacktrace = do
strs <- CCS.currentCallStack
case strs of
- [] -> return emptyExceptionContext
- _ -> pure $ mkExceptionContext (CostCentreBacktrace strs)
+ [] -> return Nothing
+ _ -> pure (Just strs)
-collectBacktrace ExecutionStackBacktraceMech = do
+collectBacktrace ExecutionStackBacktrace = do
mst <- ExecStack.showStackTrace
case mst of
- Nothing -> return emptyExceptionContext
- Just st -> return $ mkExceptionContext (ExecutionBacktrace st)
+ Nothing -> return Nothing
+ Just st -> return (Just st)
-collectBacktrace IPEBacktraceMech = do
+collectBacktrace IPEBacktrace = do
stack <- CloneStack.cloneMyStack
stackEntries <- CloneStack.decode stack
- return $ mkExceptionContext (InfoProvBacktrace stackEntries)
+ return (Just stackEntries)
-collectBacktrace HasCallStackBacktraceMech =
- return $ mkExceptionContext (HasCallStackBacktrace ?callStack)
+collectBacktrace HasCallStackBacktrace =
+ return (Just ?callStack)
=====================================
libraries/base/GHC/Exception/Backtrace.hs-boot
=====================================
@@ -1,11 +1,18 @@
{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RoleAnnotations #-}
module GHC.Exception.Backtrace where
import GHC.Base (IO)
-import GHC.Exception.Context (ExceptionContext)
import GHC.Stack.Types (HasCallStack)
+import GHC.Exception.Context (ExceptionAnnotation)
-data BacktraceMechanism
+type role BacktraceMechanism nominal
-collectBacktraces :: HasCallStack => IO ExceptionContext
+data BacktraceMechanism rep
+
+data Backtraces
+
+instance ExceptionAnnotation Backtraces
+
+collectBacktraces :: HasCallStack => IO Backtraces
=====================================
libraries/base/GHC/Exception/Context.hs
=====================================
@@ -1,6 +1,9 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE GADTs #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
@@ -21,16 +24,19 @@ module GHC.Exception.Context
( -- * Exception context
ExceptionContext(..)
, emptyExceptionContext
- , mkExceptionContext
- , mergeExceptionContexts
+ , addExceptionAnnotation
+ , getExceptionAnnotations
+ , getAllExceptionAnnotations
+ , mergeExceptionContext
-- * Exception annotations
, SomeExceptionAnnotation(..)
, ExceptionAnnotation(..)
) where
-import GHC.Base ((++), String, Semigroup(..), Monoid(..))
+import GHC.Base ((++), return, String, Maybe(..), Semigroup(..), Monoid(..))
import GHC.Show (Show(..))
-import Data.Typeable.Internal (Typeable)
+import Data.Typeable.Internal (Typeable, typeRep, eqTypeRep)
+import Data.Type.Equality ( (:~~:)(HRefl) )
-- | Exception context represents a list of 'ExceptionAnnotation's. These are
-- attached to 'SomeException's via 'Control.Exception.addExceptionContext' and
@@ -38,12 +44,11 @@ import Data.Typeable.Internal (Typeable)
-- backtraces and application-specific context.
--
-- 'ExceptionContext's can be merged via concatenation using the 'Semigroup'
--- instance or 'mergeExceptionContexts'.
+-- instance or 'mergeExceptionContext'.
data ExceptionContext = ExceptionContext [SomeExceptionAnnotation]
- deriving (Show)
instance Semigroup ExceptionContext where
- (<>) = mergeExceptionContexts
+ (<>) = mergeExceptionContext
instance Monoid ExceptionContext where
mempty = emptyExceptionContext
@@ -53,22 +58,29 @@ emptyExceptionContext :: ExceptionContext
emptyExceptionContext = ExceptionContext []
-- | Construct a singleton 'ExceptionContext' from an 'ExceptionAnnotation'.
-mkExceptionContext :: ExceptionAnnotation a => a -> ExceptionContext
-mkExceptionContext x = ExceptionContext [SomeExceptionAnnotation x]
+addExceptionAnnotation :: ExceptionAnnotation a => a -> ExceptionContext -> ExceptionContext
+addExceptionAnnotation x (ExceptionContext xs) = ExceptionContext (SomeExceptionAnnotation x : xs)
+
+getExceptionAnnotations :: forall a. ExceptionAnnotation a => ExceptionContext -> [a]
+getExceptionAnnotations (ExceptionContext xs) =
+ [ x
+ | SomeExceptionAnnotation (x :: b) <- xs
+ , Just HRefl <- return (typeRep @a `eqTypeRep` typeRep @b)
+ ]
+
+getAllExceptionAnnotations :: ExceptionContext -> [SomeExceptionAnnotation]
+getAllExceptionAnnotations (ExceptionContext xs) = xs
-- | Merge two 'ExceptionContext's via concatenation
-mergeExceptionContexts :: ExceptionContext -> ExceptionContext -> ExceptionContext
-mergeExceptionContexts (ExceptionContext a) (ExceptionContext b) = ExceptionContext (a ++ b)
+mergeExceptionContext :: ExceptionContext -> ExceptionContext -> ExceptionContext
+mergeExceptionContext (ExceptionContext a) (ExceptionContext b) = ExceptionContext (a ++ b)
data SomeExceptionAnnotation = forall a. ExceptionAnnotation a => SomeExceptionAnnotation a
-instance Show SomeExceptionAnnotation where
- showsPrec p (SomeExceptionAnnotation e) = showsPrec p e
-
-- | 'ExceptionAnnotation's are types which can decorate exceptions as
-- 'ExceptionContext'.
-class (Show a, Typeable a) => ExceptionAnnotation a where
+class (Typeable a) => ExceptionAnnotation a where
-- | Render the annotation for display to the user.
displayExceptionAnnotation :: a -> String
=====================================
libraries/base/GHC/Exception/Type.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -23,11 +24,13 @@ module GHC.Exception.Type
( Exception(..) -- Class
, SomeException(..)
, exceptionContext
- , addExceptionContext
+ , addExceptionContext -- TODO: Drop?
+ , augmentExceptionContext -- TODO: Drop?
+ , mapExceptionContext
-- * Exception context
, ExceptionContext(..)
, emptyExceptionContext
- , mergeExceptionContexts
+ , mergeExceptionContext
, ExceptionWithContext(..)
-- * Arithmetic exceptions
, ArithException(..)
@@ -47,16 +50,24 @@ The @SomeException@ type is the root of the exception type hierarchy.
When an exception of type @e@ is thrown, behind the scenes it is
encapsulated in a @SomeException at .
-}
-data SomeException = forall e. (Exception e, ?context :: ExceptionContext) => SomeException e
+data SomeException = forall e. (Exception e, ?exceptionContext :: ExceptionContext) => SomeException e
-- | View the 'ExceptionContext' of a 'SomeException'.
exceptionContext :: SomeException -> ExceptionContext
-exceptionContext (SomeException _) = ?context
+exceptionContext (SomeException _) = ?exceptionContext
-- | Add more 'ExceptionContext' to a 'SomeException'.
-addExceptionContext :: ExceptionContext -> SomeException -> SomeException
-addExceptionContext ctxt' se@(SomeException e) =
- let ?context = exceptionContext se `mergeExceptionContexts` ctxt'
+addExceptionContext :: ExceptionAnnotation a => a -> SomeException -> SomeException
+addExceptionContext ann =
+ mapExceptionContext (addExceptionAnnotation ann)
+
+augmentExceptionContext :: ExceptionContext -> SomeException -> SomeException
+augmentExceptionContext ctx =
+ mapExceptionContext (ctx `mergeExceptionContext`)
+
+mapExceptionContext :: (ExceptionContext -> ExceptionContext) -> SomeException -> SomeException
+mapExceptionContext f se@(SomeException e) =
+ let ?exceptionContext = f (exceptionContext se)
in SomeException e
-- | @since 3.0
@@ -150,13 +161,11 @@ Caught MismatchedParentheses
-}
class (Typeable e, Show e) => Exception e where
- toException :: e -> SomeException
- toExceptionWithContext :: e -> ExceptionContext -> SomeException
+ toException :: e -> SomeException
fromException :: SomeException -> Maybe e
- toException e = toExceptionWithContext e emptyExceptionContext
- toExceptionWithContext e ctxt = SomeException e
- where ?context = ctxt
+ toException e = SomeException e
+ where ?exceptionContext = emptyExceptionContext
fromException (SomeException e) = cast e
-- | Render this exception value in a human-friendly manner.
@@ -167,13 +176,15 @@ class (Typeable e, Show e) => Exception e where
displayException :: e -> String
displayException = show
+ backtraceDesired :: Bool
+ backtraceDesired = True
+
-- | @since 3.0
instance Exception SomeException where
toException se = se
- toExceptionWithContext se ctxt = addExceptionContext ctxt se
fromException = Just
displayException (SomeException e) =
- displayException e ++ "\n" ++ displayContext ?context
+ displayException e ++ "\n" ++ displayContext ?exceptionContext
displayContext :: ExceptionContext -> String
displayContext (ExceptionContext anns0) = go anns0
@@ -181,16 +192,26 @@ displayContext (ExceptionContext anns0) = go anns0
go (SomeExceptionAnnotation ann : anns) = displayExceptionAnnotation ann ++ "\n" ++ go anns
go [] = "\n"
+newtype NoBacktrace e = NoBacktrace e
+ deriving (Show)
+
+instance Exception e => Exception (NoBacktrace e) where
+ fromException = fmap NoBacktrace . fromException
+ toException (NoBacktrace e) = toException e
+ backtraceDesired = False
+
-- | Wraps a particular exception exposing its 'ExceptionContext'. Intended to
-- be used when 'catch'ing exceptions in cases where access to the context is
-- desired.
data ExceptionWithContext a = ExceptionWithContext ExceptionContext a
- deriving (Show)
+
+instance Show a => Show (ExceptionWithContext a) where
+ showsPrec _ (ExceptionWithContext _ e) = showString "ExceptionWithContext _ " . shows e
instance Exception a => Exception (ExceptionWithContext a) where
toException (ExceptionWithContext ctxt e) =
SomeException e
- where ?context = ctxt
+ where ?exceptionContext = ctxt
fromException se = do
e <- fromException se
return (ExceptionWithContext (exceptionContext se) e)
=====================================
libraries/base/GHC/IO.hs
=====================================
@@ -28,6 +28,7 @@ module GHC.IO (
unsafePerformIO, unsafeInterleaveIO,
unsafeDupablePerformIO, unsafeDupableInterleaveIO,
noDuplicate,
+ annotateIO,
-- To and from ST
stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
@@ -50,6 +51,7 @@ import GHC.IO.Unsafe
import GHC.Stack.Types ( HasCallStack )
import Unsafe.Coerce ( unsafeCoerce )
+import GHC.Exception.Context ( ExceptionAnnotation )
import {-# SOURCE #-} GHC.Exception.Backtrace ( collectBacktraces )
import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError )
@@ -184,10 +186,11 @@ catch :: Exception e
-> IO a
-- See #exceptions_and_strictness#.
catch (IO io) handler = IO $ catch# io handler'
- where handler' e = case fromException e of
- Just e' -> unIO (handler e')
- Nothing -> raiseIO# e
-
+ where
+ handler' e =
+ case fromException e of
+ Just e' -> unIO (withAugmentedContext (exceptionContext e) (handler e'))
+ Nothing -> raiseIO# e
-- | Catch any 'Exception' type in the 'IO' monad.
--
@@ -196,7 +199,21 @@ catch (IO io) handler = IO $ catch# io handler'
-- details.
catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
catchAny !(IO io) handler = IO $ catch# io handler'
- where handler' (SomeException e) = unIO (handler e)
+ where
+ handler' se@(SomeException e) =
+ unIO (withAugmentedContext (exceptionContext se) (handler e))
+
+withAugmentedContext :: ExceptionContext -> IO a -> IO a
+withAugmentedContext ctxt (IO io) = IO (catch# io handler)
+ where
+ handler se = raiseIO# (augmentExceptionContext ctxt se)
+
+-- | Execute an 'IO' action, adding the given 'ExceptionContext'
+-- to any thrown synchronous exceptions.
+annotateIO :: forall e a. ExceptionAnnotation e => e -> IO a -> IO a
+annotateIO ann (IO io) = IO (catch# io handler)
+ where
+ handler se = raiseIO# (addExceptionContext ann se)
-- Using catchException here means that if `m` throws an
-- 'IOError' /as an imprecise exception/, we will not catch
@@ -239,8 +256,8 @@ mplusIO m n = m `catchException` \ (_ :: IOError) -> n
--
throwIO :: (HasCallStack, Exception e) => e -> IO a
throwIO e = do
- ctxt <- collectBacktraces
- let !exc = toExceptionWithContext e ctxt
+ context <- collectBacktraces
+ let !exc = addExceptionContext context (toException e)
IO (raiseIO# exc)
-- -----------------------------------------------------------------------------
=====================================
libraries/base/GHC/IO/Exception.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.IO.Exception (
cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,
SomeAsyncException(..),
- asyncExceptionToException, asyncExceptionToExceptionWithContext, asyncExceptionFromException,
+ asyncExceptionToException, asyncExceptionFromException,
AsyncException(..), stackOverflow, heapOverflow,
ArrayException(..),
@@ -101,7 +101,8 @@ blockedIndefinitelyOnSTM = toException BlockedIndefinitelyOnSTM
data Deadlock = Deadlock
-- | @since 4.1.0.0
-instance Exception Deadlock
+instance Exception Deadlock where
+ displayException _ = "no threads to run: infinite loop or deadlock?"
-- | @since 4.1.0.0
instance Show Deadlock where
@@ -188,11 +189,6 @@ instance Exception SomeAsyncException
asyncExceptionToException :: Exception e => e -> SomeException
asyncExceptionToException = toException . SomeAsyncException
--- | @since 4.18.0.0
-asyncExceptionToExceptionWithContext :: Exception e => e -> ExceptionContext -> SomeException
-asyncExceptionToExceptionWithContext e ctxt =
- addExceptionContext ctxt (asyncExceptionToException e)
-
-- | @since 4.7.0.0
asyncExceptionFromException :: Exception e => SomeException -> Maybe e
asyncExceptionFromException x = do
@@ -238,7 +234,6 @@ data AsyncException
-- | @since 4.7.0.0
instance Exception AsyncException where
toException = asyncExceptionToException
- toExceptionWithContext = asyncExceptionToExceptionWithContext
fromException = asyncExceptionFromException
-- | Exceptions generated by array operations
=====================================
libraries/base/System/Timeout.hs
=====================================
@@ -27,7 +27,6 @@ import Control.Concurrent
import Control.Exception (Exception(..), handleJust, bracket,
uninterruptibleMask_,
asyncExceptionToException,
- asyncExceptionToExceptionWithContext,
asyncExceptionFromException)
import Data.Unique (Unique, newUnique)
@@ -53,7 +52,6 @@ instance Show Timeout where
-- | @since 4.7.0.0
instance Exception Timeout where
toException = asyncExceptionToException
- toExceptionWithContext = asyncExceptionToExceptionWithContext
fromException = asyncExceptionFromException
-- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c91ce67dd859e2e7597c648e96476894c10c03c7...445b0a320b7f299d003bcceb7a4f8d621263dd1d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c91ce67dd859e2e7597c648e96476894c10c03c7...445b0a320b7f299d003bcceb7a4f8d621263dd1d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230221/f4a27074/attachment-0001.html>
More information about the ghc-commits
mailing list