X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIOBase.lhs;h=c15d6c7b3fbce56779d545a0d5def7b653dbf401;hb=cdd30e6640d450835091b8815b42d55bee67df6b;hp=3442677316996ef2c2ac4d139db5081a7c113247;hpb=d7019a562d5e862476d55d1c0721fd6c4e793c28;p=ghc-base.git diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs index 3442677..c15d6c7 100644 --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -1,5 +1,6 @@ \begin{code} -{-# OPTIONS_GHC -fno-implicit-prelude #-} +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.IOBase @@ -18,44 +19,53 @@ module GHC.IOBase( IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, unsafePerformIO, unsafeInterleaveIO, - - -- To and from from ST + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, + + -- To and from from ST stToIO, ioToST, unsafeIOToST, unsafeSTToIO, - -- References + -- References IORef(..), newIORef, readIORef, writeIORef, IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray, MVar(..), - -- Handles, file descriptors, + -- Handles, file descriptors, FilePath, Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle, - - -- Buffers + + -- Buffers Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..), bufferIsWritable, bufferEmpty, bufferFull, - -- Exceptions + -- Exceptions Exception(..), ArithException(..), AsyncException(..), ArrayException(..), - stackOverflow, heapOverflow, throw, throwIO, ioException, + stackOverflow, heapOverflow, ioException, IOError, IOException(..), IOErrorType(..), ioError, userError, - ExitCode(..) + ExitCode(..), + throwIO, block, unblock, blocked, catchAny, catchException, + evaluate, + ErrorCall(..), AssertionFailed(..), assertError, untangle, + BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..), + blockedOnDeadMVar, blockedIndefinitely ) where - + import GHC.ST -import GHC.Arr -- to derive Ix class +import GHC.Arr -- to derive Ix class import GHC.Enum -- to derive Enum class import GHC.STRef import GHC.Base --- import GHC.Num -- To get fromInteger etc, needed because of -fno-implicit-prelude +-- import GHC.Num -- To get fromInteger etc, needed because of -XNoImplicitPrelude import Data.Maybe ( Maybe(..) ) import GHC.Show import GHC.List import GHC.Read +import Foreign.C.Types (CInt) +import GHC.Exception #ifndef __HADDOCK__ -import {-# SOURCE #-} GHC.Dynamic +import {-# SOURCE #-} Data.Typeable ( Typeable ) #endif -- --------------------------------------------------------------------------- @@ -71,13 +81,13 @@ system. The following list may or may not be exhaustive: Compiler - types of various primitives in PrimOp.lhs -RTS - forceIO (StgMiscClosures.hc) - - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast - (Exceptions.hc) - - raiseAsync (Schedule.c) +RTS - forceIO (StgMiscClosures.hc) + - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast + (Exceptions.hc) + - raiseAsync (Schedule.c) Prelude - GHC.IOBase.lhs, and several other places including - GHC.Exception.lhs. + GHC.Exception.lhs. Libraries - parts of hslibs/lang. @@ -110,10 +120,10 @@ instance Monad IO where {-# INLINE (>>) #-} {-# INLINE (>>=) #-} m >> k = m >>= \ _ -> k - return x = returnIO x + return x = returnIO x m >>= k = bindIO m k - fail s = failIO s + fail s = failIO s failIO :: String -> IO a failIO s = ioError (userError s) @@ -130,7 +140,7 @@ bindIO (IO m) k = IO ( \ s -> thenIO :: IO a -> IO b -> IO b thenIO (IO m) k = IO ( \ s -> case m s of - (# new_s, a #) -> unIO k new_s + (# new_s, _ #) -> unIO k new_s ) returnIO :: a -> IO a @@ -143,10 +153,10 @@ returnIO x = IO (\ s -> (# s, x #)) -- monad. The 'RealWorld' parameter indicates that the internal state -- used by the 'ST' computation is a special one supplied by the 'IO' -- monad, and thus distinct from those used by invocations of 'runST'. -stToIO :: ST RealWorld a -> IO a +stToIO :: ST RealWorld a -> IO a stToIO (ST m) = IO m -ioToST :: IO a -> ST RealWorld a +ioToST :: IO a -> ST RealWorld a ioToST (IO m) = (ST m) -- This relies on IO and ST having the same representation modulo the @@ -174,26 +184,26 @@ effects take place (relative to the main I\/O trunk, or other calls to writing and compiling modules that use 'unsafePerformIO': * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@ - that calls 'unsafePerformIO'. If the call is inlined, - the I\/O may be performed more than once. + that calls 'unsafePerformIO'. If the call is inlined, + the I\/O may be performed more than once. * Use the compiler flag @-fno-cse@ to prevent common sub-expression - elimination being performed on the module, which might combine - two side effects that were meant to be separate. A good example - is using multiple global variables (like @test@ in the example below). + elimination being performed on the module, which might combine + two side effects that were meant to be separate. A good example + is using multiple global variables (like @test@ in the example below). * Make sure that the either you switch off let-floating, or that the - call to 'unsafePerformIO' cannot float outside a lambda. For example, - if you say: - @ - f x = unsafePerformIO (newIORef []) - @ - you may get only one reference cell shared between all calls to @f@. - Better would be - @ - f x = unsafePerformIO (newIORef [x]) - @ - because now it can't float outside the lambda. + call to 'unsafePerformIO' cannot float outside a lambda. For example, + if you say: + @ + f x = unsafePerformIO (newIORef []) + @ + you may get only one reference cell shared between all calls to @f@. + Better would be + @ + f x = unsafePerformIO (newIORef [x]) + @ + because now it can't float outside the lambda. It is less well known that 'unsafePerformIO' is not type safe. For example: @@ -202,9 +212,9 @@ It is less well known that > test = unsafePerformIO $ newIORef [] > > main = do -> writeIORef test [42] -> bang <- readIORef test -> print (bang :: [Char]) +> writeIORef test [42] +> bang <- readIORef test +> print (bang :: [Char]) This program will core dump. This problem with polymorphic references is well known in the ML community, and does not arise with normal @@ -213,31 +223,41 @@ once you use 'unsafePerformIO'. Indeed, it is possible to write @coerce :: a -> b@ with the help of 'unsafePerformIO'. So be careful! -} -{-# NOINLINE unsafePerformIO #-} -unsafePerformIO :: IO a -> a -unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) +unsafePerformIO :: IO a -> a +unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) + +{-| +This version of 'unsafePerformIO' is slightly more efficient, +because it omits the check that the IO is only being performed by a +single thread. Hence, when you write 'unsafeDupablePerformIO', +there is a possibility that the IO action may be performed multiple +times (on a multiprocessor), and you should therefore ensure that +it gives the same results each time. +-} +{-# NOINLINE unsafeDupablePerformIO #-} +unsafeDupablePerformIO :: IO a -> a +unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) --- Why do we NOINLINE unsafePerformIO? See the comment with +-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with -- GHC.ST.runST. Essentially the issue is that the IO computation -- inside unsafePerformIO must be atomic: it must either all run, or -- not at all. If we let the compiler see the application of the IO -- to realWorld#, it might float out part of the IO. --- Why is there a call to 'lazy' in unsafePerformIO? +-- Why is there a call to 'lazy' in unsafeDupablePerformIO? -- If we don't have it, the demand analyser discovers the following strictness --- for unsafePerformIO: C(U(AV)) +-- for unsafeDupablePerformIO: C(U(AV)) -- But then consider --- unsafePerformIO (\s -> let r = f x in --- case writeIORef v r s of (# s1, _ #) -> --- (# s1, r #) +-- unsafeDupablePerformIO (\s -> let r = f x in +-- case writeIORef v r s of (# s1, _ #) -> +-- (# s1, r #) -- The strictness analyser will find that the binding for r is strict, -- (becuase of uPIO's strictness sig), and so it'll evaluate it before -- doing the writeIORef. This actually makes tests/lib/should_run/memo002 -- get a deadlock! -- --- Solution: don't expose the strictness of unsafePerformIO, --- by hiding it with 'lazy' - +-- Solution: don't expose the strictness of unsafeDupablePerformIO, +-- by hiding it with 'lazy' {-| 'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily. @@ -247,16 +267,33 @@ file reading, see 'System.IO.hGetContents'. -} {-# INLINE unsafeInterleaveIO #-} unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO (IO m) - = IO ( \ s -> let - r = case m s of (# _, res #) -> res - in - (# s, r #)) +unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m) -- We believe that INLINE on unsafeInterleaveIO is safe, because the -- state from this IO thread is passed explicitly to the interleaved -- IO, so it cannot be floated out and shared. +{-# INLINE unsafeDupableInterleaveIO #-} +unsafeDupableInterleaveIO :: IO a -> IO a +unsafeDupableInterleaveIO (IO m) + = IO ( \ s -> let + r = case m s of (# _, res #) -> res + in + (# s, r #)) + +{-| +Ensures that the suspensions under evaluation by the current thread +are unique; that is, the current thread is not evaluating anything +that is also under evaluation by another thread that has also executed +'noDuplicate'. + +This operation is used in the definition of 'unsafePerformIO' to +prevent the IO action from being executed multiple times, which is usually +undesirable. +-} +noDuplicate :: IO () +noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #) + -- --------------------------------------------------------------------------- -- Handle type @@ -269,7 +306,7 @@ as a a box, which may be empty or full. -- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module instance Eq (MVar a) where - (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# + (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# -- A Handle is represented by (a reference to) a record -- containing the state of the I/O port/device. We record @@ -280,7 +317,7 @@ instance Eq (MVar a) where -- * buffering mode -- * buffer, and spare buffers -- * user-friendly name (usually the --- FilePath used when IO.openFile was called) +-- FilePath used when IO.openFile was called) -- Note: when a Handle is garbage collected, we want to flush its buffer -- and close the OS file handle, so as to free up a (precious) resource. @@ -323,15 +360,15 @@ instance Eq (MVar a) where -- ensure that this doesn't happen. data Handle - = FileHandle -- A normal handle to a file - FilePath -- the file (invariant) - !(MVar Handle__) + = FileHandle -- A normal handle to a file + FilePath -- the file (invariant) + !(MVar Handle__) - | DuplexHandle -- A handle to a read/write stream - FilePath -- file for a FIFO, otherwise some - -- descriptive string. - !(MVar Handle__) -- The read side - !(MVar Handle__) -- The write side + | DuplexHandle -- A handle to a read/write stream + FilePath -- file for a FIFO, otherwise some + -- descriptive string. + !(MVar Handle__) -- The read side + !(MVar Handle__) -- The write side -- NOTES: -- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be @@ -342,19 +379,20 @@ instance Eq Handle where (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2 _ == _ = False -type FD = Int -- XXX ToDo: should be CInt +type FD = CInt data Handle__ = Handle__ { - haFD :: !FD, -- file descriptor - haType :: HandleType, -- type (read/write/append etc.) - haIsBin :: Bool, -- binary mode? - haIsStream :: Bool, -- is this a stream handle? - haBufferMode :: BufferMode, -- buffer contains read/write data? - haBuffer :: !(IORef Buffer), -- the current buffer + haFD :: !FD, -- file descriptor + haType :: HandleType, -- type (read/write/append etc.) + haIsBin :: Bool, -- binary mode? + haIsStream :: Bool, -- Windows : is this a socket? + -- Unix : is O_NONBLOCK set? + haBufferMode :: BufferMode, -- buffer contains read/write data? + haBuffer :: !(IORef Buffer), -- the current buffer haBuffers :: !(IORef BufferList), -- spare buffers haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a - -- duplex handle. + -- duplex handle. } -- --------------------------------------------------------------------------- @@ -394,11 +432,11 @@ type RawBuffer = MutableByteArray# RealWorld data Buffer = Buffer { - bufBuf :: RawBuffer, - bufRPtr :: !Int, - bufWPtr :: !Int, - bufSize :: !Int, - bufState :: BufferState + bufBuf :: RawBuffer, + bufRPtr :: !Int, + bufWPtr :: !Int, + bufSize :: !Int, + bufState :: BufferState } data BufferState = ReadBuffer | WriteBuffer deriving (Eq) @@ -433,15 +471,18 @@ data HandleType | AppendHandle | ReadWriteHandle +isReadableHandleType :: HandleType -> Bool isReadableHandleType ReadHandle = True isReadableHandleType ReadWriteHandle = True -isReadableHandleType _ = False +isReadableHandleType _ = False +isWritableHandleType :: HandleType -> Bool isWritableHandleType AppendHandle = True isWritableHandleType WriteHandle = True isWritableHandleType ReadWriteHandle = True -isWritableHandleType _ = False +isWritableHandleType _ = False +isReadWriteHandleType :: HandleType -> Bool isReadWriteHandleType ReadWriteHandle{} = True isReadWriteHandleType _ = False @@ -495,13 +536,13 @@ type FilePath = String -- and terminals will normally be line-buffered. data BufferMode - = NoBuffering -- ^ buffering is disabled if possible. + = NoBuffering -- ^ buffering is disabled if possible. | LineBuffering - -- ^ line-buffering should be enabled if possible. + -- ^ line-buffering should be enabled if possible. | BlockBuffering (Maybe Int) - -- ^ block-buffering should be enabled if possible. - -- The size of the buffer is @n@ items if the argument - -- is 'Just' @n@ and is otherwise implementation-dependent. + -- ^ block-buffering should be enabled if possible. + -- The size of the buffer is @n@ items if the argument + -- is 'Just' @n@ and is otherwise implementation-dependent. deriving (Eq, Ord, Read, Show) -- --------------------------------------------------------------------------- @@ -545,7 +586,7 @@ instance Eq (IOArray i e) where -- |Build a new 'IOArray' newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e) {-# INLINE newIOArray #-} -newIOArray lu init = stToIO $ do {marr <- newSTArray lu init; return (IOArray marr)} +newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)} -- | Read a value from an 'IOArray' unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e @@ -574,7 +615,7 @@ writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e) -- than the derived one. instance Show HandleType where - showsPrec p t = + showsPrec _ t = case t of ClosedHandle -> showString "closed" SemiClosedHandle -> showString "semi-closed" @@ -584,208 +625,121 @@ instance Show HandleType where ReadWriteHandle -> showString "read-writable" instance Show Handle where - showsPrec p (FileHandle file _) = showHandle file - showsPrec p (DuplexHandle file _ _) = showHandle file + showsPrec _ (FileHandle file _) = showHandle file + showsPrec _ (DuplexHandle file _ _) = showHandle file +showHandle :: FilePath -> String -> String 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 teh 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. - --- |The type of arithmetic exceptions -data ArithException - = Overflow - | Underflow - | LossOfPrecision - | DivideByZero - | Denormal - deriving (Eq, Ord) +-- Exception datatypes and operations + +data BlockedOnDeadMVar = BlockedOnDeadMVar + deriving Typeable + +instance Exception BlockedOnDeadMVar + +instance Show BlockedOnDeadMVar where + showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely" + +blockedOnDeadMVar :: SomeException -- for the RTS +blockedOnDeadMVar = toException BlockedOnDeadMVar + +----- + +data BlockedIndefinitely = BlockedIndefinitely + deriving Typeable + +instance Exception BlockedIndefinitely + +instance Show BlockedIndefinitely where + showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely" + +blockedIndefinitely :: SomeException -- for the RTS +blockedIndefinitely = toException BlockedIndefinitely + +----- + +data Deadlock = Deadlock + deriving Typeable + +instance Exception Deadlock + +instance Show Deadlock where + showsPrec _ Deadlock = showString "<>" + +----- +data AssertionFailed = AssertionFailed String + deriving Typeable + +instance Exception AssertionFailed + +instance Show AssertionFailed where + showsPrec _ (AssertionFailed err) = showString err + +----- -- |Asynchronous exceptions data AsyncException = StackOverflow - -- ^The current thread\'s stack exceeded its limit. - -- Since an exception has been raised, the thread\'s stack - -- will certainly be below its limit again, but the - -- programmer should take remedial action - -- immediately. + -- ^The current thread\'s stack exceeded its limit. + -- Since an exception has been raised, the thread\'s stack + -- will certainly be below its limit again, but the + -- programmer should take remedial action + -- immediately. | HeapOverflow - -- ^The program\'s heap is reaching its limit, and - -- the program should take action to reduce the amount of - -- live data it has. Notes: - -- - -- * It is undefined which thread receives this exception. - -- - -- * GHC currently does not throw 'HeapOverflow' exceptions. + -- ^The program\'s heap is reaching its limit, and + -- the program should take action to reduce the amount of + -- live data it has. Notes: + -- + -- * It is undefined which thread receives this exception. + -- + -- * GHC currently does not throw 'HeapOverflow' exceptions. | ThreadKilled - -- ^This exception is raised by another thread - -- calling 'Control.Concurrent.killThread', or by the system - -- if it needs to terminate the thread for some - -- reason. - deriving (Eq, Ord) + -- ^This exception is raised by another thread + -- calling 'Control.Concurrent.killThread', or by the system + -- if it needs to terminate the thread for some + -- reason. + | UserInterrupt + -- ^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, Typeable) + +instance Exception AsyncException -- | Exceptions generated by array operations data ArrayException - = IndexOutOfBounds String - -- ^An attempt was made to index an array outside - -- its declared bounds. - | UndefinedElement String - -- ^An attempt was made to evaluate an element of an - -- array that had not been initialized. - deriving (Eq, Ord) - -stackOverflow, heapOverflow :: Exception -- for the RTS -stackOverflow = AsyncException StackOverflow -heapOverflow = AsyncException HeapOverflow - -instance Show ArithException where - showsPrec _ Overflow = showString "arithmetic overflow" - showsPrec _ Underflow = showString "arithmetic underflow" - showsPrec _ LossOfPrecision = showString "loss of precision" - showsPrec _ DivideByZero = showString "divide by zero" - showsPrec _ Denormal = showString "denormal" + = IndexOutOfBounds String + -- ^An attempt was made to index an array outside + -- its declared bounds. + | UndefinedElement String + -- ^An attempt was made to evaluate an element of an + -- array that had not been initialized. + deriving (Eq, Ord, Typeable) + +instance Exception ArrayException + +stackOverflow, heapOverflow :: SomeException -- for the RTS +stackOverflow = toException StackOverflow +heapOverflow = toException HeapOverflow instance Show AsyncException where showsPrec _ StackOverflow = showString "stack overflow" showsPrec _ HeapOverflow = showString "heap overflow" showsPrec _ ThreadKilled = showString "thread killed" + showsPrec _ UserInterrupt = showString "user interrupt" instance Show ArrayException where showsPrec _ (IndexOutOfBounds s) - = showString "array index out of range" - . (if not (null s) then showString ": " . showString s - else id) + = showString "array index out of range" + . (if not (null s) then showString ": " . showString s + else id) showsPrec _ (UndefinedElement s) - = showString "undefined array element" - . (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 + = showString "undefined array element" + . (if not (null s) then showString ": " . showString s + else id) -- ----------------------------------------------------------------------------- -- The ExitCode type @@ -794,46 +748,22 @@ instance Eq Exception where -- Exception datatype (above). data ExitCode - = ExitSuccess -- ^ indicates successful termination; + = ExitSuccess -- ^ indicates successful termination; | ExitFailure Int - -- ^ indicates program failure with an exit code. - -- 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) + -- ^ indicates program failure with an exit code. + -- 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, Typeable) --- -------------------------------------------------------------------------- --- Primitive throw +instance Exception ExitCode --- | Throw an exception. Exceptions may be thrown from purely --- functional code, but may only be caught within the 'IO' monad. -throw :: Exception -> a -throw exception = raise# exception - --- | 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 -> IO a -throwIO err = IO $ raiseIO# err - -ioException :: IOException -> IO a -ioException err = IO $ raiseIO# (IOException err) +ioException :: IOException -> IO a +ioException err = throwIO err -- | Raise an 'IOError' in the 'IO' monad. ioError :: IOError -> IO a -ioError = ioException +ioError = ioException -- --------------------------------------------------------------------------- -- IOError type @@ -853,12 +783,15 @@ type IOError = IOException data IOException = IOError { ioe_handle :: Maybe Handle, -- the handle used by the action flagging - -- the error. + -- the error. ioe_type :: IOErrorType, -- what it was. - ioe_location :: String, -- location. + ioe_location :: String, -- location. 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) = @@ -887,38 +820,33 @@ data IOErrorType | TimeExpired | ResourceVanished | Interrupted - | DynIOError Dynamic -- cheap&cheerful extensible IO error type. instance Eq IOErrorType where - x == y = - case x of - DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst? - _ -> getTag x ==# getTag y + x == y = getTag x ==# getTag y instance Show IOErrorType where showsPrec _ e = showString $ case e of - AlreadyExists -> "already exists" + AlreadyExists -> "already exists" NoSuchThing -> "does not exist" ResourceBusy -> "resource busy" ResourceExhausted -> "resource exhausted" - EOF -> "end of file" - IllegalOperation -> "illegal operation" + EOF -> "end of file" + IllegalOperation -> "illegal operation" PermissionDenied -> "permission denied" - UserError -> "user error" - HardwareFault -> "hardware fault" + UserError -> "user error" + HardwareFault -> "hardware fault" InappropriateType -> "inappropriate type" Interrupted -> "interrupted" InvalidArgument -> "invalid argument" OtherError -> "failed" ProtocolError -> "protocol error" ResourceVanished -> "resource vanished" - SystemError -> "system error" + SystemError -> "system error" TimeExpired -> "timeout" UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! UnsupportedOperation -> "unsupported operation" - DynIOError{} -> "unknown IO error" -- | Construct an 'IOError' value with a string describing the error. -- The 'fail' method of the 'IO' instance of the 'Monad' class raises a @@ -929,7 +857,7 @@ instance Show IOErrorType where -- > fail s = ioError (userError s) -- userError :: String -> IOError -userError str = IOError Nothing UserError "" str Nothing +userError str = IOError Nothing UserError "" str Nothing -- --------------------------------------------------------------------------- -- Showing IOErrors @@ -937,17 +865,17 @@ userError str = IOError Nothing UserError "" str Nothing instance Show IOException where showsPrec p (IOError hdl iot loc s fn) = (case fn of - Nothing -> case hdl of - Nothing -> id - Just h -> showsPrec p h . showString ": " - Just name -> showString name . showString ": ") . + Nothing -> case hdl of + Nothing -> id + Just h -> showsPrec p h . showString ": " + Just name -> showString name . showString ": ") . (case loc of "" -> id - _ -> showString loc . showString ": ") . + _ -> showString loc . showString ": ") . showsPrec p iot . (case s of - "" -> id - _ -> showString " (" . showString s . showString ")") + "" -> id + _ -> showString " (" . showString s . showString ")") -- ----------------------------------------------------------------------------- -- IOMode type @@ -955,3 +883,145 @@ 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} + +\begin{code} +assertError :: Addr# -> Bool -> a -> a +assertError str predicate v + | predicate = v + | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) + +{- +(untangle coded message) expects "coded" to be of the form + "location|details" +It prints + location message details +-} +untangle :: Addr# -> String -> String +untangle coded message + = location + ++ ": " + ++ message + ++ details + ++ "\n" + where + coded_str = unpackCStringUtf8# coded + + (location, details) + = case (span not_bar coded_str) of { (loc, rest) -> + case rest of + ('|':det) -> (loc, ' ' : det) + _ -> (loc, "") + } + not_bar c = c /= '|' +\end{code} +