[Git][ghc/ghc][wip/exception-propagate] 4 commits: Fix toException method for ExceptionWithContext
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Tue Sep 24 15:19:40 UTC 2024
Rodrigo Mesquita pushed to branch wip/exception-propagate at Glasgow Haskell Compiler / GHC
Commits:
a0c2dadd by Matthew Pickering at 2024-09-24T16:19:25+01:00
Fix toException method for ExceptionWithContext
Fixes #25235
- - - - -
c8317f80 by Matthew Pickering at 2024-09-24T16:19:25+01:00
Exception rethrowing
Basic changes:
* Change `catch` function to propagate exceptions using the
WhileHandling mechanism.
* Introduce `catchNoPropagate`, which does the same as before, but
passes an exception which can be rethrown.
* Introduce `rethrowIO` combinator, which rethrows an exception with a
context and doesn't add a new backtrace.
* Introduce `tryWithContext` for a variant of `try` which can rethrow
the exception with it's original context.
* onException is modified to rethrow the original error rather than
creating a new callstack.
* Functions which rethrow in GHC.Internal.IO.Handle.FD,
GHC.Internal.IO.Handle.Internals, GHC.Internal.IO.Handle.Text, and
GHC.Internal.System.IO.Error are modified to not add a new callstack.
- - - - -
a1a52283 by Rodrigo Mesquita at 2024-09-24T16:19:25+01:00
Add unicode drawing lines
- - - - -
3d75a03f by Rodrigo Mesquita at 2024-09-24T16:19:26+01:00
fixup! Add unicode drawing lines
- - - - -
10 changed files:
- libraries/base/src/Control/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
- libraries/ghc-internal/src/GHC/Internal/IO.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Handle/FD.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs
Changes:
=====================================
libraries/base/src/Control/Exception.hs
=====================================
@@ -38,6 +38,8 @@ module Control.Exception
someExceptionContext,
annotateIO,
ExceptionWithContext(..),
+ WhileHandling(..),
+
-- * Concrete exception types
IOException,
ArithException(..),
@@ -65,6 +67,7 @@ module Control.Exception
-- * Throwing exceptions
throw,
throwIO,
+ rethrowIO,
ioError,
throwTo,
-- * Catching Exceptions
@@ -73,6 +76,7 @@ module Control.Exception
-- $catchall
-- ** The @catch@ functions
catch,
+ catchNoPropagate,
catches,
Handler(..),
catchJust,
@@ -81,6 +85,7 @@ module Control.Exception
handleJust,
-- ** The @try@ functions
try,
+ tryWithContext,
tryJust,
-- ** The @evaluate@ function
evaluate,
@@ -111,11 +116,11 @@ module Control.Exception
bracketOnError,
finally,
onException
+
) where
import GHC.Internal.Control.Exception
import GHC.Internal.Exception.Type
-import GHC.Internal.IO (annotateIO)
{- $catching
=====================================
libraries/ghc-internal/src/GHC/Internal/Control/Exception.hs
=====================================
@@ -62,20 +62,25 @@ module GHC.Internal.Control.Exception (
-- * Throwing exceptions
throw,
throwIO,
+ rethrowIO,
ioError,
throwTo,
-- ** The @catch@ functions
catch,
+ catchNoPropagate,
catches, Handler(..),
catchJust,
+ -- ** Exception annotation
+
-- ** The @handle@ functions
handle,
handleJust,
-- ** The @try@ functions
try,
+ tryWithContext,
tryJust,
-- ** The @evaluate@ function
@@ -105,6 +110,12 @@ module GHC.Internal.Control.Exception (
finally,
onException,
+ -- * Annotating exceptions
+
+ ExceptionContext(..),
+ annotateIO,
+ WhileHandling(..),
+
) where
import GHC.Internal.Control.Exception.Base
=====================================
libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs
=====================================
@@ -46,6 +46,7 @@ module GHC.Internal.Control.Exception.Base (
-- * Throwing exceptions
throwIO,
+ rethrowIO,
throw,
ioError,
throwTo,
@@ -54,6 +55,7 @@ module GHC.Internal.Control.Exception.Base (
-- ** The @catch@ functions
catch,
+ catchNoPropagate,
catchJust,
-- ** The @handle@ functions
@@ -62,6 +64,7 @@ module GHC.Internal.Control.Exception.Base (
-- ** The @try@ functions
try,
+ tryWithContext,
tryJust,
onException,
@@ -85,6 +88,13 @@ module GHC.Internal.Control.Exception.Base (
assert,
+ -- * Annotating exceptions
+
+ ExceptionContext(..),
+ annotateIO,
+ WhileHandling(..),
+
+
-- * Utilities
bracket,
@@ -105,6 +115,7 @@ import GHC.Internal.Base
import GHC.Internal.Exception
import GHC.Internal.IO hiding (bracket, finally, onException)
import GHC.Internal.IO.Exception
+import GHC.Internal.Exception.Type
import GHC.Internal.Show
-- import GHC.Internal.Exception hiding ( Exception )
import GHC.Internal.Conc.Sync
@@ -132,10 +143,11 @@ catchJust
-> IO a -- ^ Computation to run
-> (b -> IO a) -- ^ Handler
-> IO a
-catchJust p a handler = catch a handler'
- where handler' e = case p e of
- Nothing -> throwIO e
- Just b -> handler b
+catchJust p a handler = catchNoPropagate a handler'
+ where handler' ec@(ExceptionWithContext _ e) =
+ case p e of
+ Nothing -> rethrowIO ec
+ Just b -> annotateIO (whileHandling ec) (handler b)
-- | A version of 'catch' with the arguments swapped around; useful in
-- situations where the code for the handler is shorter. For example:
@@ -176,23 +188,23 @@ mapException f v = unsafePerformIO (catch (evaluate v)
try :: Exception e => IO a -> IO (Either e a)
try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
+-- | Like 'try' but also returns the exception context, which is useful if you intend
+-- to rethrow the exception later.
+tryWithContext :: Exception e => IO a -> IO (Either (ExceptionWithContext e) a)
+tryWithContext a = catchNoPropagate (a >>= \v -> return (Right v)) (\e -> return (Left e))
+
-- | A variant of 'try' that takes an exception predicate to select
-- which exceptions are caught (c.f. 'catchJust'). If the exception
-- does not match the predicate, it is re-thrown.
tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)
-tryJust p a = do
- r <- try a
- case r of
- Right v -> return (Right v)
- Left e -> case p e of
- Nothing -> throwIO e
- Just b -> return (Left b)
+tryJust p a = catchJust p (Right `fmap` a) (return . Left)
-- | Like 'finally', but only performs the final action if there was an
-- exception raised by the computation.
onException :: IO a -> IO b -> IO a
-onException io what = io `catch` \e -> do _ <- what
- throwIO (e :: SomeException)
+onException io what = io `catchNoPropagate` \e -> do
+ _ <- what
+ rethrowIO (e :: ExceptionWithContext SomeException)
-----------------------------------------------------------------------------
-- Some Useful Functions
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
=====================================
@@ -39,13 +39,16 @@ module GHC.Internal.Exception.Type
, emptyExceptionContext
, mergeExceptionContext
, ExceptionWithContext(..)
+ -- * Exception propagation
+ , WhileHandling(..)
+ , whileHandling
-- * Arithmetic exceptions
, ArithException(..)
, divZeroException, overflowException, ratioZeroDenomException
, underflowException
) where
-import GHC.Internal.Data.OldList (intersperse)
+import GHC.Internal.Data.OldList (intersperse, lines, unlines, null)
import GHC.Internal.Data.Maybe
import GHC.Internal.Data.Typeable (Typeable, TypeRep, cast)
import qualified GHC.Internal.Data.Typeable as Typeable
@@ -69,6 +72,27 @@ will be subject to defaulting, as described above.
-}
type HasExceptionContext = (?exceptionContext :: ExceptionContext)
+{- | @WhileHandling@ is used to annotate rethrow exceptions. By inspecting
+ the @WhileHandling@ annotation, all the places the exception has been rethrow
+ can be recovered.
+-}
+
+data WhileHandling = WhileHandling SomeException deriving Show
+
+instance ExceptionAnnotation WhileHandling where
+ displayExceptionAnnotation (WhileHandling e) =
+ "While handling " ++ case lines $ displayException e of
+ [] -> ""
+ (l1:ls) ->
+ -- Indent lines forward.
+ -- displayException may be ill prepared for this?...
+ unlines $ l1:[if null l then " |" else " | " ++ l | l <- ls]
+
+
+-- | Create 'SomeException' from an explicit context and exception.
+whileHandling :: Exception e => ExceptionWithContext e -> WhileHandling
+whileHandling e = WhileHandling (toException e)
+
{- |
The @SomeException@ type is the root of the exception type hierarchy.
When an exception of type @e@ is thrown, behind the scenes it is
@@ -258,8 +282,10 @@ instance Show a => Show (ExceptionWithContext a) where
instance Exception a => Exception (ExceptionWithContext a) where
toException (ExceptionWithContext ctxt e) =
- SomeException e
- where ?exceptionContext = ctxt
+ case toException e of
+ SomeException c ->
+ let ?exceptionContext = ctxt
+ in SomeException c
fromException se = do
e <- fromException se
return (ExceptionWithContext (someExceptionContext se) e)
=====================================
libraries/ghc-internal/src/GHC/Internal/IO.hs
=====================================
@@ -40,7 +40,8 @@ module GHC.Internal.IO (
FilePath,
- catch, catchException, catchAny, throwIO,
+ catch, catchNoPropagate, catchException, catchExceptionNoPropagate, catchAny, throwIO,
+ rethrowIO,
mask, mask_, uninterruptibleMask, uninterruptibleMask_,
MaskingState(..), getMaskingState,
unsafeUnmask, interruptible,
@@ -51,7 +52,7 @@ module GHC.Internal.IO (
import GHC.Internal.Base
import GHC.Internal.ST
import GHC.Internal.Exception
-import GHC.Internal.Exception.Type (NoBacktrace(..))
+import GHC.Internal.Exception.Type (NoBacktrace(..), WhileHandling(..), HasExceptionContext, ExceptionWithContext(..))
import GHC.Internal.Show
import GHC.Internal.IO.Unsafe
import GHC.Internal.Unsafe.Coerce ( unsafeCoerce )
@@ -152,6 +153,10 @@ have to work around that in the definition of catch below).
catchException :: Exception e => IO a -> (e -> IO a) -> IO a
catchException !io handler = catch io handler
+-- | A variant of 'catchException' which does not annotate the handler with 'WhileHandling'
+catchExceptionNoPropagate :: Exception e => IO a -> (ExceptionWithContext e -> IO a) -> IO a
+catchExceptionNoPropagate !io handler = catchNoPropagate io handler
+
-- | This is the simplest of the exception-catching functions. It
-- takes a single argument, runs it, and if an exception is raised
-- the \"handler\" is executed, with the value of the exception passed as an
@@ -191,6 +196,23 @@ 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 (annotateIO (WhileHandling e) (handler e'))
+ Nothing -> raiseIO# e
+
+-- | A variant of 'catch' which doesn't annotate the handler with the exception
+-- which was caught. This function should be used when you are implementing your own
+-- error handling functions which may rethrow the exceptions.
+--
+-- In the case where you rethrow an exception without modifying it, you should
+-- rethrow the exception with the old exception context.
+catchNoPropagate :: Exception e
+ => IO a
+ -> (ExceptionWithContext e -> IO a)
+ -> IO a
+catchNoPropagate (IO io) handler = IO $ catch# io handler'
where
handler' e =
case fromException e of
@@ -202,10 +224,12 @@ catch (IO io) handler = IO $ catch# io handler'
-- Note that this function is /strict/ in the action. That is,
-- @catchAny undefined b == _|_ at . See #exceptions_and_strictness# for
-- details.
-catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
+--
+-- If you rethrow an exception, you should reuse the supplied ExceptionContext.
+catchAny :: IO a -> (forall e . (HasExceptionContext, Exception e) => e -> IO a) -> IO a
catchAny !(IO io) handler = IO $ catch# io handler'
where
- handler' (SomeException e) = unIO (handler e)
+ handler' se@(SomeException e) = unIO (annotateIO (WhileHandling se) (handler e))
-- | Execute an 'IO' action, adding the given 'ExceptionContext'
-- to any thrown synchronous exceptions.
@@ -260,6 +284,11 @@ throwIO e = do
se <- toExceptionWithBacktrace e
IO (raiseIO# se)
+-- | A utility to use when rethrowing exceptions, no new backtrace will be attached
+-- when rethrowing an exception but you must supply the existing context.
+rethrowIO :: Exception e => ExceptionWithContext e -> IO a
+rethrowIO e = throwIO (NoBacktrace e)
+
-- -----------------------------------------------------------------------------
-- Controlling asynchronous exception delivery
@@ -332,9 +361,9 @@ getMaskingState = IO $ \s ->
_ -> MaskedInterruptible #)
onException :: IO a -> IO b -> IO a
-onException io what = io `catchException` \e -> do
+onException io what = io `catchExceptionNoPropagate` \e -> do
_ <- what
- throwIO $ NoBacktrace (e :: SomeException)
+ rethrowIO (e :: ExceptionWithContext SomeException)
-- | Executes an IO computation with asynchronous
-- exceptions /masked/. That is, any thread which attempts to raise
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
=====================================
@@ -315,7 +315,7 @@ ioException :: HasCallStack => IOException -> IO a
ioException err = throwIO err
-- | Raise an 'IOError' in the 'IO' monad.
-ioError :: IOError -> IO a
+ioError :: HasCallStack => IOError -> IO a
ioError = ioException
-- ---------------------------------------------------------------------------
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Handle/FD.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
-----------------------------------------------------------------------------
@@ -27,12 +28,13 @@ module GHC.Internal.IO.Handle.FD (
import GHC.Internal.Base
import GHC.Internal.Show
-import GHC.Internal.Control.Exception (try)
+import GHC.Internal.Control.Exception (tryWithContext)
import GHC.Internal.Data.Maybe
import GHC.Internal.Data.Either (either)
import GHC.Internal.Data.Typeable
import GHC.Internal.Foreign.C.Types
import GHC.Internal.MVar
+import GHC.Internal.Exception.Type
import GHC.Internal.IO
import GHC.Internal.IO.Encoding
import GHC.Internal.IO.Device as IODevice
@@ -116,6 +118,18 @@ addFilePathToIOError :: String -> FilePath -> IOException -> IOException
addFilePathToIOError fun fp ioe
= ioe{ ioe_location = fun, ioe_filename = Just fp }
+-- It could be good in future to use native exception annotation here rather than
+-- modifying IOException
+catchAndAnnotate :: FilePath -> String -> IO a -> IO a
+catchAndAnnotate fp s a =
+ catchExceptionNoPropagate @IOError a
+ (\(ExceptionWithContext c e) -> rethrowIO (ExceptionWithContext c (addFilePathToIOError s fp e)))
+
+-- | Specialised 'rethrowIO' to 'IOError', helpful for type inference
+rethrowError :: ExceptionWithContext IOError -> IO a
+rethrowError = rethrowIO
+
+
-- | Computation 'openFile' @file mode@ allocates and returns a new, open
-- handle to manage the file @file at . It manages input if @mode@
-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
@@ -151,9 +165,9 @@ addFilePathToIOError fun fp ioe
-- be using 'openBinaryFile'.
openFile :: FilePath -> IOMode -> IO Handle
openFile fp im =
- catchException
+ catchAndAnnotate
+ fp "openFile"
(openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True)
- (\e -> ioError (addFilePathToIOError "openFile" fp e))
-- | @'withFile' name mode act@ opens a file like 'openFile' and passes
-- the resulting handle to the computation @act at . The handle will be
@@ -166,10 +180,9 @@ openFile fp im =
withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile fp im act = do
-- Only annotate when setup or teardown of withFile' raised the exception
- catchException
- (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True (try . act))
- (\e -> ioError (addFilePathToIOError "withFile" fp e))
- >>= either ioError pure
+ catchAndAnnotate fp "withFile"
+ (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True (tryWithContext . act))
+ >>= either rethrowError pure
-- | Like 'openFile', but opens the file in ordinary blocking mode.
-- This can be useful for opening a FIFO for writing: if we open in
@@ -187,9 +200,8 @@ withFile fp im act = do
-- @since base-4.4.0.0
openFileBlocking :: FilePath -> IOMode -> IO Handle
openFileBlocking fp im =
- catchException
+ catchAndAnnotate fp "openFileBlocking"
(openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False)
- (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e))
-- | @'withFileBlocking' name mode act@ opens a file like 'openFileBlocking'
-- and passes the resulting handle to the computation @act at . The handle will
@@ -202,10 +214,9 @@ openFileBlocking fp im =
withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFileBlocking fp im act = do
-- Only annotate when setup or teardown of withFile' raised the exception
- catchException
- (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False (try . act))
- (\e -> ioError (addFilePathToIOError "withFileBlocking" fp e))
- >>= either ioError pure
+ catchAndAnnotate fp "withFileBlocking"
+ (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False (tryWithContext . act))
+ >>= either rethrowError pure
-- | Like 'openFile', but open the file in binary mode.
-- On Windows, reading a file in text mode (which is the default)
@@ -220,9 +231,8 @@ withFileBlocking fp im act = do
-- described in "Control.Exception".
openBinaryFile :: FilePath -> IOMode -> IO Handle
openBinaryFile fp m =
- catchException
+ catchAndAnnotate fp "openBinaryFile"
(openFile' fp m True True)
- (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
-- | A version of `openBinaryFile` that takes an action to perform
-- with the handle. If an exception occurs in the action, then
@@ -234,10 +244,9 @@ openBinaryFile fp m =
withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile fp im act =
-- Only annotate when setup or teardown of withFile' raised the exception
- catchException
- (withFile' fp im True True (try . act))
- (\e -> ioError (addFilePathToIOError "withBinaryFile" fp e))
- >>= either ioError pure
+ catchAndAnnotate fp "withBinaryFile"
+ (withFile' fp im True True (tryWithContext . act))
+ >>= either rethrowError pure
-- | Open a file and perform an action with it. If the action throws an
-- exception, then the file will be closed. If the last argument is 'True',
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs
=====================================
@@ -79,6 +79,7 @@ import GHC.Internal.Real
import GHC.Internal.Word
import GHC.Internal.Base
import GHC.Internal.Exception
+import GHC.Internal.Exception.Type
import GHC.Internal.Num ( Num(..) )
import GHC.Internal.Show
import GHC.Internal.IORef
@@ -178,13 +179,13 @@ do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a
do_operation fun h act m = do
h_ <- takeMVar m
checkHandleInvariants h_
- act h_ `catchException` handler h_
+ act h_ `catchExceptionNoPropagate` handler h_
where
- handler h_ e = do
+ handler h_ (ExceptionWithContext c e) = do
putMVar m h_
case () of
_ | Just ioe <- fromException e ->
- ioError (augmentIOError ioe fun h)
+ rethrowIO (ExceptionWithContext c $ augmentIOError ioe fun h)
_ | Just async_ex <- fromException e -> do -- see Note [async]
let _ = async_ex :: SomeAsyncException
t <- myThreadId
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs
=====================================
@@ -41,6 +41,7 @@ import GHC.Internal.IO.Buffer
import qualified GHC.Internal.IO.BufferedIO as Buffered
import GHC.Internal.IO.Exception
import GHC.Internal.Exception
+import GHC.Internal.Exception.Type
import GHC.Internal.IO.Handle.Types
import GHC.Internal.IO.Handle.Internals
import qualified GHC.Internal.IO.Device as IODevice
@@ -495,7 +496,7 @@ hGetContents' handle = do
Left e ->
case fromException e of
Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle)
- Nothing -> throwIO e
+ Nothing -> throwIO (NoBacktrace e)
strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String)
strictRead h handle_ at Handle__{..} = do
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs
=====================================
@@ -90,6 +90,7 @@ import GHC.Internal.Data.Either
import GHC.Internal.Data.Maybe
import GHC.Internal.Base
+import GHC.Internal.Exception.Type
import GHC.Internal.IO
import GHC.Internal.IO.Exception
import GHC.Internal.IO.Handle.Types
@@ -320,7 +321,7 @@ ioeSetFileName ioe filename = ioe{ ioe_filename = Just filename }
-- | Catch any 'IOError' that occurs in the computation and throw a
-- modified version.
modifyIOError :: (IOError -> IOError) -> IO a -> IO a
-modifyIOError f io = catch io (\e -> ioError (f e))
+modifyIOError f io = catch io (\e -> throwIO (NoBacktrace $ f e))
-- -----------------------------------------------------------------------------
-- annotating an IOError
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52a6fde3eae77cb98be9e2569cf8c2e7669f50fe...3d75a03f1a456987f922d1c0b7770528c812915b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52a6fde3eae77cb98be9e2569cf8c2e7669f50fe...3d75a03f1a456987f922d1c0b7770528c812915b
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/20240924/3c7a0b61/attachment-0001.html>
More information about the ghc-commits
mailing list