Repository : ssh://darcs.haskell.org//srv/darcs/packages/base On branch : master
http://hackage.haskell.org/trac/ghc/changeset/1bfecaf5122a96afc1fe68f009cbaa96b48e927a >--------------------------------------------------------------- commit 1bfecaf5122a96afc1fe68f009cbaa96b48e927a Author: Simon Marlow <[email protected]> Date: Mon Dec 10 08:35:34 2012 +0000 Make a class for asynchronous exceptions in the exception hierarchy Right now, we only have data AsyncException = StackOverflow | HeapOverflow | ThreadKilled | ... so it is not possible to add another async exception. For instance, the Timeout exception in System.Timeout should really be an async exception. This patch adds a superclass for all async exceptions: data SomeAsyncException = forall e . Exception e => SomeAsyncException e deriving Typeable and makes the existing AsyncException and Timeout children of SomeAsyncException in the hierarchy. >--------------------------------------------------------------- Control/Exception.hs | 2 ++ Control/Exception/Base.hs | 3 ++- GHC/Conc/Sync.lhs | 19 +++++++------------ GHC/IO/Exception.hs | 30 +++++++++++++++++++++++++++--- GHC/IO/Handle/Internals.hs | 2 +- System/Timeout.hs | 10 ++++++++-- 6 files changed, 47 insertions(+), 19 deletions(-) diff --git a/Control/Exception.hs b/Control/Exception.hs index 4cd00bd..e3a3a24 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -44,7 +44,9 @@ module Control.Exception ( ArithException(..), -- instance Eq, Ord, Show, Typeable, Exception ArrayException(..), -- instance Eq, Ord, Show, Typeable, Exception AssertionFailed(..), + SomeAsyncException(..), AsyncException(..), -- instance Eq, Ord, Show, Typeable, Exception + asyncExceptionToException, asyncExceptionFromException, #if __GLASGOW_HASKELL__ || __HUGS__ NonTermination(..), diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs index 281af02..8d2d5d8 100644 --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -33,7 +33,8 @@ module Control.Exception.Base ( ArithException(..), ArrayException(..), AssertionFailed(..), - AsyncException(..), + SomeAsyncException(..), AsyncException(..), + asyncExceptionToException, asyncExceptionFromException, #if __GLASGOW_HASKELL__ || __HUGS__ NonTermination(..), diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs index ec266e9..4434f0c 100644 --- a/GHC/Conc/Sync.lhs +++ b/GHC/Conc/Sync.lhs @@ -10,6 +10,7 @@ , DeriveDataTypeable , StandaloneDeriving , RankNTypes + , PatternGuards #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} @@ -327,18 +328,12 @@ childHandler :: SomeException -> IO () childHandler err = catchException (real_handler err) childHandler real_handler :: SomeException -> IO () -real_handler se@(SomeException ex) = - -- ignore thread GC and killThread exceptions: - case cast ex of - Just BlockedIndefinitelyOnMVar -> return () - _ -> case cast ex of - Just BlockedIndefinitelyOnSTM -> return () - _ -> case cast ex of - Just ThreadKilled -> return () - _ -> case cast ex of - -- report all others: - Just StackOverflow -> reportStackOverflow - _ -> reportError se +real_handler se + | Just BlockedIndefinitelyOnMVar <- fromException se = return () + | Just BlockedIndefinitelyOnSTM <- fromException se = return () + | Just ThreadKilled <- fromException se = return () + | Just StackOverflow <- fromException se = reportStackOverflow + | otherwise = reportError se {- | 'killThread' raises the 'ThreadKilled' exception in the given thread (GHC only). diff --git a/GHC/IO/Exception.hs b/GHC/IO/Exception.hs index ab385f4..b4d8880 100644 --- a/GHC/IO/Exception.hs +++ b/GHC/IO/Exception.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, MagicHash #-} +{-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, MagicHash, + ExistentialQuantification #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} @@ -22,7 +23,11 @@ module GHC.IO.Exception ( BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM, Deadlock(..), AssertionFailed(..), + + SomeAsyncException(..), + asyncExceptionToException, asyncExceptionFromException, AsyncException(..), stackOverflow, heapOverflow, + ArrayException(..), ExitCode(..), @@ -47,7 +52,7 @@ import Data.Maybe import GHC.IO.Handle.Types import Foreign.C.Types -import Data.Typeable ( Typeable ) +import Data.Typeable ( Typeable, cast ) -- ------------------------------------------------------------------------ -- Exception datatypes and operations @@ -105,6 +110,23 @@ instance Show AssertionFailed where ----- +data SomeAsyncException = forall e . Exception e => SomeAsyncException e + deriving Typeable + +instance Show SomeAsyncException where + show (SomeAsyncException e) = show e + +instance Exception SomeAsyncException + +asyncExceptionToException :: Exception e => e -> SomeException +asyncExceptionToException = toException . SomeAsyncException + +asyncExceptionFromException :: Exception e => SomeException -> Maybe e +asyncExceptionFromException x = do + SomeAsyncException a <- fromException x + cast a + + -- |Asynchronous exceptions. data AsyncException = StackOverflow @@ -132,7 +154,9 @@ data AsyncException -- via the usual mechanism(s) (e.g. Control-C in the console). deriving (Eq, Ord, Typeable) -instance Exception AsyncException +instance Exception AsyncException where + toException = asyncExceptionToException + fromException = asyncExceptionFromException -- | Exceptions generated by array operations data ArrayException diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs index f6c4ef4..79228d3 100644 --- a/GHC/IO/Handle/Internals.hs +++ b/GHC/IO/Handle/Internals.hs @@ -172,7 +172,7 @@ do_operation fun h act m = do _ | Just ioe <- fromException e -> ioError (augmentIOError ioe fun h) _ | Just async_ex <- fromException e -> do -- see Note [async] - let _ = async_ex :: AsyncException + let _ = async_ex :: SomeAsyncException t <- myThreadId throwTo t e do_operation fun h act m diff --git a/System/Timeout.hs b/System/Timeout.hs index a72ec1a..e0b20ea 100644 --- a/System/Timeout.hs +++ b/System/Timeout.hs @@ -26,7 +26,9 @@ module System.Timeout ( timeout ) where #ifdef __GLASGOW_HASKELL__ import Control.Concurrent -import Control.Exception (Exception, handleJust, bracket) +import Control.Exception (Exception(..), handleJust, bracket, + asyncExceptionToException, + asyncExceptionFromException) import Data.Typeable import Data.Unique (Unique, newUnique) @@ -40,7 +42,11 @@ INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout") instance Show Timeout where show _ = "<<timeout>>" -instance Exception Timeout +-- Timeout is a child of SomeAsyncException +instance Exception Timeout where + toException = asyncExceptionToException + fromException = asyncExceptionFromException + #endif /* !__GLASGOW_HASKELL__ */ -- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
