From b3768993c0fa634d54a15a0eefa370208110be21 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 30 Jul 2008 12:25:39 +0000 Subject: [PATCH] Rejig the extensible exceptions so there is less circular importing --- Control/Exception.hs | 5 +- Data/Typeable.hs | 5 +- Foreign/Marshal/Pool.hs | 5 +- GHC/Conc.lhs | 2 +- GHC/Exception.lhs | 139 +---------------------------------------------- GHC/Exception.lhs-boot | 19 ------- GHC/Handle.hs | 2 +- GHC/IO.hs | 1 - GHC/IOBase.lhs | 114 +++++++++++++++++++++++++++++++++++++- GHC/IOBase.lhs-boot | 1 - GHC/TopHandler.lhs | 1 - System/IO.hs | 2 +- 12 files changed, 125 insertions(+), 171 deletions(-) delete mode 100644 GHC/Exception.lhs-boot diff --git a/Control/Exception.hs b/Control/Exception.hs index 3a92b15..769bf1f 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -128,9 +128,8 @@ module Control.Exception ( ) where #ifdef __GLASGOW_HASKELL__ -import GHC.Base ( assert ) -import GHC.IOBase -import GHC.Exception as ExceptionBase hiding (Exception, catch) +import GHC.IOBase as ExceptionBase hiding ( catch ) +import GHC.Exception hiding ( Exception ) import GHC.Conc ( throwTo, ThreadId ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Foreign.C.String ( CString, withCString ) diff --git a/Data/Typeable.hs b/Data/Typeable.hs index 4614ab5..293564e 100644 --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -101,8 +101,8 @@ import GHC.IOBase (IORef,newIORef,unsafePerformIO) -- These imports are so we can define Typeable instances -- It'd be better to give Typeable instances in the modules themselves -- but they all have to be compiled before Typeable -import GHC.IOBase ( IO, MVar, Exception, ArithException, IOException, - ArrayException, AsyncException, Handle ) +import GHC.IOBase ( IO, MVar, Exception, ArithException, IOException, + ArrayException, AsyncException, Handle, block ) import GHC.ST ( ST ) import GHC.STRef ( STRef ) import GHC.Ptr ( Ptr, FunPtr ) @@ -110,7 +110,6 @@ import GHC.ForeignPtr ( ForeignPtr ) import GHC.Stable ( StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, castStablePtrToPtr, castPtrToStablePtr ) -import GHC.Exception ( block ) import GHC.Arr ( Array, STArray ) #endif diff --git a/Foreign/Marshal/Pool.hs b/Foreign/Marshal/Pool.hs index 445b786..754b484 100644 --- a/Foreign/Marshal/Pool.hs +++ b/Foreign/Marshal/Pool.hs @@ -47,8 +47,9 @@ module Foreign.Marshal.Pool ( #ifdef __GLASGOW_HASKELL__ import GHC.Base ( Int, Monad(..), (.), not ) import GHC.Err ( undefined ) -import GHC.Exception ( block, unblock, throw, catchException, catchAny ) -import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef, ) +import GHC.Exception ( throw ) +import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef + block, unblock, catchAny ) import GHC.List ( elem, length ) import GHC.Num ( Num(..) ) #else diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index d1158dd..50ebab7 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -121,7 +121,7 @@ import GHC.Base ( Int(..) ) import GHC.Read ( Read ) import GHC.Enum ( Enum ) #endif -import GHC.Exception ( catchException, catchAny, throw, block, unblock ) +import GHC.Exception ( throw ) import GHC.Pack ( packCString# ) import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) ) import GHC.STRef diff --git a/GHC/Exception.lhs b/GHC/Exception.lhs index b4c511f..a285542 100644 --- a/GHC/Exception.lhs +++ b/GHC/Exception.lhs @@ -16,16 +16,11 @@ ----------------------------------------------------------------------------- -- #hide -module GHC.Exception - ( module GHC.Exception, - throwIO, ioError ) - where +module GHC.Exception where import Data.Maybe import {-# SOURCE #-} Data.Typeable import GHC.Base -import GHC.IOBase hiding (Exception) -import qualified GHC.IOBase import GHC.Show \end{code} @@ -54,146 +49,16 @@ instance Exception SomeException where fromException = Just \end{code} -For now at least, make the monolithic Exception type an instance. - -\begin{code} -instance Exception GHC.IOBase.Exception -\end{code} - %********************************************************* %* * -\subsection{Primitive catch and throw} +\subsection{Primitive throw} %* * %********************************************************* -catchException used to handle the passing around of the state to the -action and the handler. This turned out to be a bad idea - it meant -that we had to wrap both arguments in thunks so they could be entered -as normal (remember IO returns an unboxed pair...). - -Now catch# has type - - catch# :: IO a -> (b -> IO a) -> IO a - -(well almost; the compiler doesn't know about the IO newtype so we -have to work around that in the definition of catchException below). - \begin{code} -catchException :: Exception e => IO a -> (e -> IO a) -> IO a -catchException (IO io) handler = IO $ catch# io handler' - where handler' e = case fromException e of - Just e' -> unIO (handler e') - Nothing -> raise# e - -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) - --- | The 'catch' function establishes a handler that receives any 'IOError' --- raised in the action protected by 'catch'. An 'IOError' is caught by --- the most recent handler established by 'catch'. These handlers are --- not selective: all 'IOError's are caught. Exception propagation --- must be explicitly provided in a handler by re-raising any unwanted --- exceptions. For example, in --- --- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e) --- --- the function @f@ returns @[]@ when an end-of-file exception --- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the --- exception is propagated to the next outer handler. --- --- When an exception propagates outside the main program, the Haskell --- system prints the associated 'IOError' value and exits the program. --- --- Non-I\/O exceptions are not caught by this variant; to catch all --- exceptions, use 'Control.Exception.catch' from "Control.Exception". -catch :: IO a -> (IOError -> IO a) -> IO a -catch m k = catchException m handler - where handler (IOException err) = k err - handler other = throw other - -- | Throw an exception. Exceptions may be thrown from purely -- functional code, but may only be caught within the 'IO' monad. throw :: Exception e => e -> a throw e = raise# (toException e) - --- | A variant of 'throw' that can be used within the 'IO' monad. --- --- Although 'throwIO' has a type that is an instance of the type of 'throw', the --- two functions are subtly different: --- --- > throw e `seq` x ===> throw e --- > throwIO e `seq` x ===> x --- --- The first example will cause the exception @e@ to be raised, --- whereas the second one won\'t. In fact, 'throwIO' will only cause --- an exception to be raised when it is used within the 'IO' monad. --- The 'throwIO' variant should be used in preference to 'throw' to --- raise an exception within the 'IO' monad because it guarantees --- ordering with respect to other 'IO' operations, whereas 'throw' --- does not. -throwIO :: Exception e => e -> IO a -throwIO e = IO (raiseIO# (toException e)) \end{code} - -%********************************************************* -%* * -\subsection{Controlling asynchronous exception delivery} -%* * -%********************************************************* - -\begin{code} --- | Applying 'block' to a computation will --- execute that computation with asynchronous exceptions --- /blocked/. That is, any thread which --- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be --- blocked until asynchronous exceptions are enabled again. There\'s --- no need to worry about re-enabling asynchronous exceptions; that is --- done automatically on exiting the scope of --- 'block'. --- --- Threads created by 'Control.Concurrent.forkIO' inherit the blocked --- state from the parent; that is, to start a thread in blocked mode, --- use @block $ forkIO ...@. This is particularly useful if you need to --- establish an exception handler in the forked thread before any --- asynchronous exceptions are received. -block :: IO a -> IO a - --- | To re-enable asynchronous exceptions inside the scope of --- 'block', 'unblock' can be --- used. It scopes in exactly the same way, so on exit from --- 'unblock' asynchronous exception delivery will --- be disabled again. -unblock :: IO a -> IO a - -block (IO io) = IO $ blockAsyncExceptions# io -unblock (IO io) = IO $ unblockAsyncExceptions# io - --- | returns True if asynchronous exceptions are blocked in the --- current thread. -blocked :: IO Bool -blocked = IO $ \s -> case asyncExceptionsBlocked# s of - (# s', i #) -> (# s', i /=# 0# #) -\end{code} - -\begin{code} --- | Forces its argument to be evaluated when the resultant 'IO' action --- is executed. It can be used to order evaluation with respect to --- other 'IO' operations; its semantics are given by --- --- > evaluate x `seq` y ==> y --- > evaluate x `catch` f ==> (return $! x) `catch` f --- > evaluate x >>= f ==> (return $! x) >>= f --- --- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the --- same as @(return $! x)@. A correct definition is --- --- > evaluate x = (return $! x) >>= return --- -evaluate :: a -> IO a -evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #) - -- NB. can't write - -- a `seq` (# s, a #) - -- because we can't have an unboxed tuple as a function argument -\end{code} diff --git a/GHC/Exception.lhs-boot b/GHC/Exception.lhs-boot deleted file mode 100644 index dfd8013..0000000 --- a/GHC/Exception.lhs-boot +++ /dev/null @@ -1,19 +0,0 @@ - -\begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} - -module GHC.Exception where - -import {-# SOURCE #-} qualified GHC.IOBase as IOB - -class Exception e - -data SomeException - -instance Exception IOB.Exception - -throwIO :: Exception e => e -> IOB.IO a - -toException :: Exception e => e -> SomeException -\end{code} - diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 1d8445e..3421502 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -73,7 +73,7 @@ import GHC.Base import GHC.Read ( Read ) import GHC.List import GHC.IOBase -import GHC.Exception ( block, catchException, catchAny, throw, throwIO ) +import GHC.Exception ( throw ) import GHC.Enum import GHC.Num ( Integer(..), Num(..) ) import GHC.Show diff --git a/GHC/IO.hs b/GHC/IO.hs index 14c2b3d..7ca3e6e 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -45,7 +45,6 @@ import GHC.Real import GHC.Num import GHC.Show import GHC.List -import GHC.Exception ( ioError, catch ) #ifdef mingw32_HOST_OS import GHC.Conc diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs index 378237d..ac7d0a4 100644 --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -44,6 +44,8 @@ module GHC.IOBase( stackOverflow, heapOverflow, ioException, IOError, IOException(..), IOErrorType(..), ioError, userError, ExitCode(..), + throwIO, block, unblock, catch, catchAny, catchException, + evaluate, -- The RTS calls this nonTermination, ) where @@ -59,7 +61,8 @@ import GHC.Show import GHC.List import GHC.Read import Foreign.C.Types (CInt) -import {-# SOURCE #-} GHC.Exception ( SomeException, toException, throwIO ) +import GHC.Exception hiding (Exception) +import qualified GHC.Exception as Exc #ifndef __HADDOCK__ import {-# SOURCE #-} Data.Typeable ( showsTypeRep ) @@ -717,6 +720,10 @@ data Exception nonTermination :: SomeException nonTermination = toException NonTermination +-- For now at least, make the monolithic Exception type an instance of +-- the Exception class +instance Exc.Exception Exception + -- |The type of arithmetic exceptions data ArithException = Overflow @@ -972,3 +979,108 @@ instance Show IOException where data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode deriving (Eq, Ord, Ix, Enum, Read, Show) \end{code} + +%********************************************************* +%* * +\subsection{Primitive catch and throwIO} +%* * +%********************************************************* + +catchException used to handle the passing around of the state to the +action and the handler. This turned out to be a bad idea - it meant +that we had to wrap both arguments in thunks so they could be entered +as normal (remember IO returns an unboxed pair...). + +Now catch# has type + + catch# :: IO a -> (b -> IO a) -> IO a + +(well almost; the compiler doesn't know about the IO newtype so we +have to work around that in the definition of catchException below). + +\begin{code} +catchException :: Exception e => IO a -> (e -> IO a) -> IO a +catchException (IO io) handler = IO $ catch# io handler' + where handler' e = case fromException e of + Just e' -> unIO (handler e') + Nothing -> raise# e + +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) + +-- | A variant of 'throw' that can be used within the 'IO' monad. +-- +-- Although 'throwIO' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: +-- +-- > throw e `seq` x ===> throw e +-- > throwIO e `seq` x ===> x +-- +-- The first example will cause the exception @e@ to be raised, +-- whereas the second one won\'t. In fact, 'throwIO' will only cause +-- an exception to be raised when it is used within the 'IO' monad. +-- The 'throwIO' variant should be used in preference to 'throw' to +-- raise an exception within the 'IO' monad because it guarantees +-- ordering with respect to other 'IO' operations, whereas 'throw' +-- does not. +throwIO :: Exception e => e -> IO a +throwIO e = IO (raiseIO# (toException e)) +\end{code} + + +%********************************************************* +%* * +\subsection{Controlling asynchronous exception delivery} +%* * +%********************************************************* + +\begin{code} +-- | Applying 'block' to a computation will +-- execute that computation with asynchronous exceptions +-- /blocked/. That is, any thread which +-- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be +-- blocked until asynchronous exceptions are enabled again. There\'s +-- no need to worry about re-enabling asynchronous exceptions; that is +-- done automatically on exiting the scope of +-- 'block'. +-- +-- Threads created by 'Control.Concurrent.forkIO' inherit the blocked +-- state from the parent; that is, to start a thread in blocked mode, +-- use @block $ forkIO ...@. This is particularly useful if you need to +-- establish an exception handler in the forked thread before any +-- asynchronous exceptions are received. +block :: IO a -> IO a + +-- | To re-enable asynchronous exceptions inside the scope of +-- 'block', 'unblock' can be +-- used. It scopes in exactly the same way, so on exit from +-- 'unblock' asynchronous exception delivery will +-- be disabled again. +unblock :: IO a -> IO a + +block (IO io) = IO $ blockAsyncExceptions# io +unblock (IO io) = IO $ unblockAsyncExceptions# io +\end{code} + +\begin{code} +-- | Forces its argument to be evaluated when the resultant 'IO' action +-- is executed. It can be used to order evaluation with respect to +-- other 'IO' operations; its semantics are given by +-- +-- > evaluate x `seq` y ==> y +-- > evaluate x `catch` f ==> (return $! x) `catch` f +-- > evaluate x >>= f ==> (return $! x) >>= f +-- +-- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the +-- same as @(return $! x)@. A correct definition is +-- +-- > evaluate x = (return $! x) >>= return +-- +evaluate :: a -> IO a +evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #) + -- NB. can't write + -- a `seq` (# s, a #) + -- because we can't have an unboxed tuple as a function argument +\end{code} + diff --git a/GHC/IOBase.lhs-boot b/GHC/IOBase.lhs-boot index 3ddd211..fb0b9fe 100644 --- a/GHC/IOBase.lhs-boot +++ b/GHC/IOBase.lhs-boot @@ -5,6 +5,5 @@ module GHC.IOBase where data Exception -data IO a \end{code} diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs index c0fcd6b..867c289 100644 --- a/GHC/TopHandler.lhs +++ b/GHC/TopHandler.lhs @@ -33,7 +33,6 @@ import Control.Concurrent.MVar import Foreign import Foreign.C import GHC.IOBase -import GHC.Exception ( catchException ) import GHC.Prim import GHC.Conc import GHC.Weak diff --git a/System/IO.hs b/System/IO.hs index a2edaec..a47e7bd 100644 --- a/System/IO.hs +++ b/System/IO.hs @@ -171,7 +171,7 @@ import System.Posix.Internals #endif #ifdef __GLASGOW_HASKELL__ -import GHC.Exception as ExceptionBase hiding (catch) +import GHC.IOBase as ExceptionBase #endif #ifdef __HUGS__ import Hugs.Exception as ExceptionBase -- 1.7.10.4