X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIOBase.lhs;h=f50c7752124bc7a35153f21c8f922daf77a8a6b7;hb=b9152b3523862840a0b682ffa55cf55281c93185;hp=053cfd873b10e1bcc471abca28e7c30e2b73a5e9;hpb=3e118622794d68f63338b3e00fe450b552408b64;p=ghc-base.git diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs index 053cfd8..f50c775 100644 --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -43,7 +43,11 @@ module GHC.IOBase( Exception(..), ArithException(..), AsyncException(..), ArrayException(..), stackOverflow, heapOverflow, ioException, IOError, IOException(..), IOErrorType(..), ioError, userError, - ExitCode(..) + ExitCode(..), + throwIO, block, unblock, blocked, catchAny, catchException, + evaluate, + ErrorCall(..), ArithException(..), AsyncException(..), + BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..) ) where import GHC.ST @@ -57,10 +61,10 @@ import GHC.Show import GHC.List import GHC.Read import Foreign.C.Types (CInt) -import {-# SOURCE #-} GHC.Exception ( throwIO ) +import GHC.Exception #ifndef __HADDOCK__ -import {-# SOURCE #-} Data.Typeable ( showsTypeRep ) +import {-# SOURCE #-} Data.Typeable ( Typeable, showsTypeRep ) import {-# SOURCE #-} Data.Dynamic ( Dynamic, dynTypeRep ) #endif @@ -624,93 +628,47 @@ instance Show Handle where showHandle file = showString "{handle: " . showString file . showString "}" -- ------------------------------------------------------------------------ --- Exception datatype and operations - --- |The type of exceptions. Every kind of system-generated exception --- has a constructor in the 'Exception' type, and values of other --- types may be injected into 'Exception' by coercing them to --- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions: --- "Control.Exception\#DynamicExceptions"). -data Exception - = ArithException ArithException - -- ^Exceptions raised by arithmetic - -- operations. (NOTE: GHC currently does not throw - -- 'ArithException's except for 'DivideByZero'). - | ArrayException ArrayException - -- ^Exceptions raised by array-related - -- operations. (NOTE: GHC currently does not throw - -- 'ArrayException's). - | AssertionFailed String - -- ^This exception is thrown by the - -- 'assert' operation when the condition - -- fails. The 'String' argument contains the - -- location of the assertion in the source program. - | AsyncException AsyncException - -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.Exception\#AsynchronousExceptions"). - | BlockedOnDeadMVar - -- ^The current thread was executing a call to - -- 'Control.Concurrent.MVar.takeMVar' that could never return, - -- because there are no other references to this 'MVar'. - | BlockedIndefinitely - -- ^The current thread was waiting to retry an atomic memory transaction - -- that could never become possible to complete because there are no other - -- threads referring to any of the TVars involved. - | NestedAtomically - -- ^The runtime detected an attempt to nest one STM transaction - -- inside another one, presumably due to the use of - -- 'unsafePeformIO' with 'atomically'. - | Deadlock - -- ^There are no runnable threads, so the program is - -- deadlocked. The 'Deadlock' exception is - -- raised in the main thread only (see also: "Control.Concurrent"). - | DynException Dynamic - -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.Exception\#DynamicExceptions"). - | ErrorCall String - -- ^The 'ErrorCall' exception is thrown by 'error'. The 'String' - -- argument of 'ErrorCall' is the string passed to 'error' when it was - -- called. - | ExitException ExitCode - -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and - -- 'System.Exit.exitFailure'). The 'ExitCode' argument is the value passed - -- to 'System.Exit.exitWith'. An unhandled 'ExitException' exception in the - -- main thread will cause the program to be terminated with the given - -- exit code. - | IOException IOException - -- ^These are the standard IO exceptions generated by - -- Haskell\'s @IO@ operations. See also "System.IO.Error". - | NoMethodError String - -- ^An attempt was made to invoke a class method which has - -- no definition in this instance, and there was no default - -- definition given in the class declaration. GHC issues a - -- warning when you compile an instance which has missing - -- methods. - | NonTermination - -- ^The current thread is stuck in an infinite loop. This - -- exception may or may not be thrown when the program is - -- non-terminating. - | PatternMatchFail String - -- ^A pattern matching failure. The 'String' argument should contain a - -- descriptive message including the function name, source file - -- and line number. - | RecConError String - -- ^An attempt was made to evaluate a field of a record - -- for which no value was given at construction time. The - -- 'String' argument gives the location of the - -- record construction in the source program. - | RecSelError String - -- ^A field selection was attempted on a constructor that - -- doesn\'t have the requested field. This can happen with - -- multi-constructor records when one or more fields are - -- missing from some of the constructors. The - -- 'String' argument gives the location of the - -- record selection in the source program. - | RecUpdError String - -- ^An attempt was made to update a field in a record, - -- where the record doesn\'t have the requested field. This can - -- only occur with multi-constructor records, when one or more - -- fields are missing from some of the constructors. The - -- 'String' argument gives the location of the - -- record update in the source program. +-- Exception datatypes and operations + +data ErrorCall = ErrorCall String + deriving Typeable + +instance Exception ErrorCall + +instance Show ErrorCall where + showsPrec _ (ErrorCall err) = showString err + +----- + +data BlockedOnDeadMVar = BlockedOnDeadMVar + deriving Typeable + +instance Exception BlockedOnDeadMVar + +instance Show BlockedOnDeadMVar where + showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely" + +----- + +data BlockedIndefinitely = BlockedIndefinitely + deriving Typeable + +instance Exception BlockedIndefinitely + +instance Show BlockedIndefinitely where + showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely" + +----- + +data Deadlock = Deadlock + deriving Typeable + +instance Exception Deadlock + +instance Show Deadlock where + showsPrec _ Deadlock = showString "<>" + +----- -- |The type of arithmetic exceptions data ArithException @@ -719,8 +677,9 @@ data ArithException | LossOfPrecision | DivideByZero | Denormal - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) +instance Exception ArithException -- |Asynchronous exceptions data AsyncException @@ -747,7 +706,9 @@ data AsyncException -- ^This exception is raised by default in the main thread of -- the program when the user requests to terminate the program -- via the usual mechanism(s) (e.g. Control-C in the console). - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) + +instance Exception AsyncException -- | Exceptions generated by array operations data ArrayException @@ -757,11 +718,13 @@ data ArrayException | UndefinedElement String -- ^An attempt was made to evaluate an element of an -- array that had not been initialized. - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) + +instance Exception ArrayException -stackOverflow, heapOverflow :: Exception -- for the RTS -stackOverflow = AsyncException StackOverflow -heapOverflow = AsyncException HeapOverflow +stackOverflow, heapOverflow :: SomeException -- for the RTS +stackOverflow = toException StackOverflow +heapOverflow = toException HeapOverflow instance Show ArithException where showsPrec _ Overflow = showString "arithmetic overflow" @@ -785,46 +748,6 @@ instance Show ArrayException where . (if not (null s) then showString ": " . showString s else id) -instance Show Exception where - showsPrec _ (IOException err) = shows err - showsPrec _ (ArithException err) = shows err - showsPrec _ (ArrayException err) = shows err - showsPrec _ (ErrorCall err) = showString err - showsPrec _ (ExitException err) = showString "exit: " . shows err - showsPrec _ (NoMethodError err) = showString err - showsPrec _ (PatternMatchFail err) = showString err - showsPrec _ (RecSelError err) = showString err - showsPrec _ (RecConError err) = showString err - showsPrec _ (RecUpdError err) = showString err - showsPrec _ (AssertionFailed err) = showString err - showsPrec _ (DynException err) = showString "exception :: " . showsTypeRep (dynTypeRep err) - showsPrec _ (AsyncException e) = shows e - showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely" - showsPrec _ (BlockedIndefinitely) = showString "thread blocked indefinitely" - showsPrec _ (NestedAtomically) = showString "Control.Concurrent.STM.atomically was nested" - showsPrec _ (NonTermination) = showString "<>" - showsPrec _ (Deadlock) = showString "<>" - -instance Eq Exception where - IOException e1 == IOException e2 = e1 == e2 - ArithException e1 == ArithException e2 = e1 == e2 - ArrayException e1 == ArrayException e2 = e1 == e2 - ErrorCall e1 == ErrorCall e2 = e1 == e2 - ExitException e1 == ExitException e2 = e1 == e2 - NoMethodError e1 == NoMethodError e2 = e1 == e2 - PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2 - RecSelError e1 == RecSelError e2 = e1 == e2 - RecConError e1 == RecConError e2 = e1 == e2 - RecUpdError e1 == RecUpdError e2 = e1 == e2 - AssertionFailed e1 == AssertionFailed e2 = e1 == e2 - DynException _ == DynException _ = False -- incomparable - AsyncException e1 == AsyncException e2 = e1 == e2 - BlockedOnDeadMVar == BlockedOnDeadMVar = True - NonTermination == NonTermination = True - NestedAtomically == NestedAtomically = True - Deadlock == Deadlock = True - _ == _ = False - -- ----------------------------------------------------------------------------- -- The ExitCode type @@ -838,10 +761,12 @@ data ExitCode -- The exact interpretation of the code is -- operating-system dependent. In particular, some values -- may be prohibited (e.g. 0 on a POSIX-compliant system). - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Read, Show, Typeable) + +instance Exception ExitCode ioException :: IOException -> IO a -ioException err = throwIO (IOException err) +ioException err = throwIO err -- | Raise an 'IOError' in the 'IO' monad. ioError :: IOError -> IO a @@ -871,6 +796,9 @@ data IOException ioe_description :: String, -- error type specific information. ioe_filename :: Maybe FilePath -- filename the error is related to. } + deriving Typeable + +instance Exception IOException instance Eq IOException where (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = @@ -967,3 +895,114 @@ 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 + +-- | 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} +