[commit: base] master: Make a class for asynchronous exceptions in the exception hierarchy (1bfecaf)
Simon Marlow
marlowsd at gmail.com
Mon Dec 10 11:52:25 CET 2012
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 <marlowsd at gmail.com>
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
More information about the Cvs-libraries
mailing list