From: simonmar Date: Fri, 7 Jul 2000 11:03:59 +0000 (+0000) Subject: [project @ 2000-07-07 11:03:57 by simonmar] X-Git-Tag: Approximately_9120_patches~4061 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6151c960d6df040a5bfd94791f934969dfb55050;p=ghc-hetmet.git [project @ 2000-07-07 11:03:57 by simonmar] Rearrange exception stuff, as per my message on glasgow-haskell-users recently. The main change is the IOError type is now a synonym for Exception. IO.ioError can therefore be used for throwing exceptions. IO.catch still catches only IO exceptions, for backwards compatibility. The interface exported by Exception has changed somewhat: try :: IO a -> IO (Either Exception a) tryJust :: (Exception -> Maybe b) -> a -> IO (Either b a) catch :: IO a -> (Exception -> IO a) -> IO a catchJust :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a ioErrors :: Exception -> Maybe IOError arithExceptions :: Exception -> Maybe ArithException errorCalls :: Exception -> Maybe String dynExceptions :: Exception -> Maybe Dynamic assertions :: Exception -> Maybe String asyncExceptions :: Exception -> Maybe AsyncException raiseInThread is now called throwTo. Where possible, the old functions have been left around, but marked deprecated. --- diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs index 86309a3..f8f9eeb 100644 --- a/ghc/lib/std/CPUTime.lhs +++ b/ghc/lib/std/CPUTime.lhs @@ -1,7 +1,9 @@ +% ----------------------------------------------------------------------------- +% $Id: CPUTime.lhs,v 1.24 2000/07/07 11:03:57 simonmar Exp $ % -% (c) The GRASP/AQUA Project, Glasgow University, 1995-1997 +% (c) The University of Glasgow, 1995-2000 % -\section[CPUTime]{Haskell 1.4 CPU Time Library} +\section[CPUTime]{Haskell 98 CPU Time Library} \begin{code} {-# OPTIONS -#include "cbits/stgio.h" #-} @@ -23,8 +25,9 @@ import PrelBase ( Int(..) ) import PrelByteArr ( ByteArray(..), newIntArray ) import PrelArrExtra ( unsafeFreezeByteArray ) import PrelNum ( fromInt ) -import PrelIOBase ( IOError(..), IOErrorType( UnsupportedOperation ), - unsafePerformIO, stToIO ) +import PrelIOBase ( IOError(..), IOException(..), + IOErrorType( UnsupportedOperation ), + unsafePerformIO, stToIO, ioException ) import Ratio \end{code} @@ -50,7 +53,7 @@ getCPUTime = do fromIntegral (I# (indexIntArray# frozen# 2#)) * 1000000000 + fromIntegral (I# (indexIntArray# frozen# 3#))) * 1000) else - ioError (IOError Nothing UnsupportedOperation + ioException (IOError Nothing UnsupportedOperation "getCPUTime" "can't get CPU time") diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index 1c65c87..ffb75a0 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.lhs @@ -1,6 +1,9 @@ +% ----------------------------------------------------------------------------- +% $Id: Directory.lhs,v 1.19 2000/07/07 11:03:57 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1999 +% (c) The University of Glasgow, 1994-2000 % + \section[Directory]{Directory interface} A directory contains a series of entries, each of which is a named @@ -60,10 +63,10 @@ import PrelGHC ( RealWorld, or#, and# ) import PrelByteArr ( ByteArray, MutableByteArray, newWordArray, readWordArray, newCharArray ) import PrelArrExtra ( unsafeFreezeByteArray ) -import PrelPack ( unpackNBytesST, packString, unpackCStringST ) +import PrelPack ( packString, unpackCStringST ) import PrelIOBase ( stToIO, constructErrorAndFail, constructErrorAndFailWithInfo, - IOError(IOError), IOErrorType(SystemError) ) + IOException(..), ioException, IOErrorType(SystemError) ) import Time ( ClockTime(..) ) import PrelAddr ( Addr, nullAddr, Word(..), wordToInt, intToWord ) #endif @@ -481,7 +484,7 @@ setPermissions name (Permissions r w e s) = do rc <- primChmod (primPackString name) mode if rc == 0 then return () - else ioError (IOError Nothing SystemError "setPermissions" "insufficient permissions") + else ioException (IOError Nothing SystemError "setPermissions" "insufficient permissions") \end{code} (Sigh)..copied from Posix.Files to avoid dep. on posix library @@ -499,7 +502,7 @@ getFileStatus name = do #else then stToIO (unsafeFreezeByteArray bytes) #endif - else ioError (IOError Nothing SystemError "getFileStatus" "") + else ioException (IOError Nothing SystemError "getFileStatus" "") #ifndef __HUGS__ modificationTime :: FileStatus -> IO ClockTime diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs index 8cfbbd9..9745286 100644 --- a/ghc/lib/std/PrelArr.lhs +++ b/ghc/lib/std/PrelArr.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelArr.lhs,v 1.23 2000/06/30 13:39:35 simonmar Exp $ +% $Id: PrelArr.lhs,v 1.24 2000/07/07 11:03:57 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -17,13 +17,10 @@ For byte-arrays see @PrelByteArr@. module PrelArr where import {-# SOURCE #-} PrelErr ( error ) -import PrelList (foldl) import PrelEnum import PrelNum import PrelST import PrelBase -import PrelAddr -import PrelGHC import PrelShow infixl 9 !, // diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index b168ef4..5f6bd26 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelBase.lhs,v 1.32 2000/06/30 13:39:35 simonmar Exp $ +% $Id: PrelBase.lhs,v 1.33 2000/07/07 11:03:57 simonmar Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -83,10 +83,6 @@ module PrelBase ) where -import {-# SOURCE #-} PrelErr ( error ) -import {-# SOURCE #-} PrelNum ( addr2Integer ) - -- Otherwise the system import of addr2Integer looks for PrelNum.hi - import PrelGHC infixr 9 . diff --git a/ghc/lib/std/PrelByteArr.lhs b/ghc/lib/std/PrelByteArr.lhs index f299f1f..ada2a6a 100644 --- a/ghc/lib/std/PrelByteArr.lhs +++ b/ghc/lib/std/PrelByteArr.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelByteArr.lhs,v 1.7 2000/06/30 13:39:35 simonmar Exp $ +% $Id: PrelByteArr.lhs,v 1.8 2000/07/07 11:03:58 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -16,11 +16,9 @@ module PrelByteArr where import {-# SOURCE #-} PrelErr ( error ) import PrelArr import PrelFloat -import PrelList (foldl) import PrelST import PrelBase import PrelAddr -import PrelGHC \end{code} diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs index 74a1d7a..4594a6b 100644 --- a/ghc/lib/std/PrelConc.lhs +++ b/ghc/lib/std/PrelConc.lhs @@ -1,5 +1,7 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelConc.lhs,v 1.20 2000/07/07 11:03:58 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The University of Glasgow, 1994-2000 % \section[PrelConc]{Module @PrelConc@} @@ -15,7 +17,7 @@ module PrelConc -- Forking and suchlike , myThreadId -- :: IO ThreadId , killThread -- :: ThreadId -> IO () - , raiseInThread -- :: ThreadId -> Exception -> IO () + , throwTo -- :: ThreadId -> Exception -> IO () , par -- :: a -> b -> b , seq -- :: a -> b -> b , yield -- :: IO () @@ -41,8 +43,7 @@ module PrelConc import PrelBase import PrelMaybe import PrelErr ( parError, seqError ) -import PrelST ( liftST ) -import PrelIOBase ( IO(..), MVar(..), unsafePerformIO ) +import PrelIOBase ( IO(..), MVar(..) ) import PrelBase ( Int(..) ) import PrelException ( Exception(..), AsyncException(..) ) @@ -67,8 +68,8 @@ killThread :: ThreadId -> IO () killThread (ThreadId id) = IO $ \ s -> case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #) -raiseInThread :: ThreadId -> Exception -> IO () -raiseInThread (ThreadId id) ex = IO $ \ s -> +throwTo :: ThreadId -> Exception -> IO () +throwTo (ThreadId id) ex = IO $ \ s -> case (killThread# id ex s) of s1 -> (# s1, () #) myThreadId :: IO ThreadId diff --git a/ghc/lib/std/PrelException.hi-boot b/ghc/lib/std/PrelException.hi-boot deleted file mode 100644 index 9be1ea3..0000000 --- a/ghc/lib/std/PrelException.hi-boot +++ /dev/null @@ -1,12 +0,0 @@ ---------------------------------------------------------------------------- --- PrelException.hi-boot --- --- This hand-written interface file is the initial bootstrap version --- for PrelException.hi. ---------------------------------------------------------------------------- - -__interface PrelException 1 where -__export PrelException ioError catch; -1 ioError :: __forall a => PrelIOBase.IOError -> PrelIOBase.IO a ; -1 catch :: __forall a => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ; -- wish there could be more __o's here. KSW 1999-04. - diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs index 5dd4a4a..b1f41e7 100644 --- a/ghc/lib/std/PrelException.lhs +++ b/ghc/lib/std/PrelException.lhs @@ -1,7 +1,7 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelException.lhs,v 1.21 2000/06/18 21:12:31 panne Exp $ +% ------------------------------------------------------------------------------ +% $Id: PrelException.lhs,v 1.22 2000/07/07 11:03:58 simonmar Exp $ % -% (c) The GRAP/AQUA Project, Glasgow University, 1998 +% (c) The University of Glasgow, 1998-2000 % Exceptions and exception-handling functions. @@ -10,122 +10,26 @@ Exceptions and exception-handling functions. {-# OPTIONS -fno-implicit-prelude #-} #ifndef __HUGS__ -module PrelException where +module PrelException + ( module PrelException, + Exception(..), AsyncException(..), + IOException(..), ArithException(..), ArrayException(..), + throw, ioError ) + where -import PrelList import PrelBase import PrelMaybe -import PrelShow import PrelIOBase -import PrelST ( STret(..) ) -import PrelDynamic -import PrelGHC -#endif -\end{code} - -%********************************************************* -%* * -\subsection{Exception datatype and operations} -%* * -%********************************************************* -\begin{code} -data Exception - = IOException IOError -- IO exceptions (from 'ioError') - | ArithException ArithException -- Arithmetic exceptions - | ArrayException ArrayException -- Array-related exceptions - | ErrorCall String -- Calls to 'error' - | NoMethodError String -- A non-existent method was invoked - | PatternMatchFail String -- A pattern match / guard failure - | RecSelError String -- Selecting a non-existent field - | RecConError String -- Field missing in record construction - | RecUpdError String -- Record doesn't contain updated field - | AssertionFailed String -- Assertions - | DynException Dynamic -- Dynamic exceptions - | AsyncException AsyncException -- Externally generated errors - | PutFullMVar -- Put on a full MVar - | BlockedOnDeadMVar -- Blocking on a dead MVar - | NonTermination - -data ArithException - = Overflow - | Underflow - | LossOfPrecision - | DivideByZero - | Denormal - deriving (Eq, Ord) - -data AsyncException - = StackOverflow - | HeapOverflow - | ThreadKilled - deriving (Eq, Ord) - -data ArrayException - = IndexOutOfBounds String -- out-of-range array access - | UndefinedElement String -- evaluating an undefined element - 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" - -instance Show AsyncException where - showsPrec _ StackOverflow = showString "stack overflow" - showsPrec _ HeapOverflow = showString "heap overflow" - showsPrec _ ThreadKilled = showString "thread killed" - -instance Show ArrayException where - showsPrec _ (IndexOutOfBounds s) - = 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 _ (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 _ (AsyncException e) = shows e - showsPrec _ (DynException _err) = showString "unknown exception" - showsPrec _ (PutFullMVar) = showString "putMVar: full MVar" - showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely" - showsPrec _ (NonTermination) = showString "<>" +#endif \end{code} %********************************************************* %* * -\subsection{Primitive catch and throw} +\subsection{Primitive catch} %* * %********************************************************* -\begin{code} -throw :: Exception -> a - -#ifdef __HUGS__ -throw = primRaise -#else -throw exception = raise# exception -#endif -\end{code} - 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 @@ -146,15 +50,10 @@ catchException m k = ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s) catchException (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s #endif -catch :: IO a -> (IOError -> IO a) -> IO a +catch :: IO a -> (Exception -> IO a) -> IO a catch m k = catchException m handler - where handler (IOException err) = k err - handler other = throw other - -catchNonIO :: IO a -> (Exception -> IO a) -> IO a -catchNonIO m k = catchException m handler - where handler (IOException err) = ioError err - handler other = k other + where handler err@(IOException _) = k err + handler other = throw other \end{code} @@ -167,8 +66,11 @@ catchNonIO m k = catchException m handler The construct @try comp@ exposes errors which occur within a computation, and which are not fully handled. It always succeeds. +These are the IO-only try/bracket. For the full exception try/bracket +see hslibs/lang/Exception.lhs. + \begin{code} -try :: IO a -> IO (Either IOError a) +try :: IO a -> IO (Either Exception a) try f = catch (do r <- f return (Right r)) (return . Left) @@ -196,22 +98,6 @@ bracket_ before after m = do %********************************************************* %* * -\subsection{ioError} -%* * -%********************************************************* - -Why is this stuff here? To avoid recursive module dependencies of -course. - -\begin{code} -ioError :: IOError -> IO a -ioError err = IO $ \s -> throw (IOException err) s - -- (ioError e) isn't an exception; we only throw - -- the exception when applied to a world -\end{code} - -%********************************************************* -%* * \subsection{Controlling asynchronous exception delivery} %* * %********************************************************* @@ -233,3 +119,4 @@ unblockAsyncExceptions (IO io) = IO io #endif \end{code} + diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index d3b1320..f5d51b8 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -1,5 +1,7 @@ +% ------------------------------------------------------------------------------ +% $Id: PrelHandle.lhs,v 1.59 2000/07/07 11:03:58 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-2000 % \section[PrelHandle]{Module @PrelHandle@} @@ -17,12 +19,12 @@ module PrelHandle where import PrelArr import PrelBase import PrelAddr ( Addr, nullAddr ) -import PrelByteArr ( ByteArray(..), MutableByteArray(..) ) +import PrelByteArr ( ByteArray(..) ) import PrelRead ( Read ) import PrelList ( span ) import PrelIOBase -import PrelException import PrelMaybe ( Maybe(..) ) +import PrelException import PrelEnum import PrelNum ( toBig, Integer(..), Num(..) ) import PrelShow @@ -53,6 +55,20 @@ import PrelForeign ( makeForeignObj, mkForeignObj ) #endif \end{code} +\begin{code} +mkBuffer__ :: FILE_OBJECT -> Int -> IO () +mkBuffer__ fo sz_in_bytes = do + chunk <- + case sz_in_bytes of + 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer. + _ -> do + chunk <- allocMemory__ sz_in_bytes + if chunk == nullAddr + then ioException (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory") + else return chunk + setBuf fo chunk sz_in_bytes +\end{code} + %********************************************************* %* * \subsection{Types @Handle@, @Handle__@} @@ -147,7 +163,7 @@ mkClosedHandle__ = haBuffers__ = [] } -mkErrorHandle__ :: IOError -> Handle__ +mkErrorHandle__ :: IOException -> Handle__ mkErrorHandle__ ioe = Handle__ { haFO__ = nullFile__, haType__ = (ErrorHandle ioe), @@ -379,7 +395,7 @@ hClose :: Handle -> IO () hClose handle = withHandle__ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> return handle_ _ -> do rc <- closeFile (haFO__ handle_) @@ -424,7 +440,7 @@ hFileSize :: Handle -> IO Integer hFileSize handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hFileSize" handle SemiClosedHandle -> ioe_closedHandle "hFileSize" handle #ifdef __HUGS__ @@ -515,15 +531,16 @@ hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = case mode of BlockBuffering (Just n) - | n <= 0 -> ioError + | n <= 0 -> ioException (IOError (Just handle) InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified. + ("illegal buffer size " ++ showsPrec 9 n [])) + -- 9 => should be parens'ified. _ -> withHandle__ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hSetBuffering" handle _ -> do {- Note: @@ -697,7 +714,7 @@ hIsOpen :: Handle -> IO Bool hIsOpen handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> return False SemiClosedHandle -> return False _ -> return True @@ -706,7 +723,7 @@ hIsClosed :: Handle -> IO Bool hIsClosed handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> return True _ -> return False @@ -724,7 +741,7 @@ hIsReadable :: Handle -> IO Bool hIsReadable handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hIsReadable" handle SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle htype -> return (isReadable htype) @@ -737,7 +754,7 @@ hIsWritable :: Handle -> IO Bool hIsWritable handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hIsWritable" handle SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle htype -> return (isWritable htype) @@ -769,7 +786,7 @@ hGetBuffering :: Handle -> IO BufferMode hGetBuffering handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hGetBuffering" handle _ -> {- @@ -784,7 +801,7 @@ hIsSeekable :: Handle -> IO Bool hIsSeekable handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hIsSeekable" handle SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle AppendHandle -> return False @@ -815,7 +832,7 @@ hSetEcho handle on = do else withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hSetEcho" handle _ -> do rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block @@ -831,7 +848,7 @@ hGetEcho handle = do else withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hGetEcho" handle _ -> do rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block @@ -844,7 +861,7 @@ hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice handle = do withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle _ -> do rc <- isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block @@ -923,7 +940,7 @@ getHandleFd :: Handle -> IO Int getHandleFd handle = withHandle_ handle $ \ handle_ -> do case (haType__ handle_) of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "getHandleFd" handle _ -> do fd <- getFileFd (haFO__ handle_) @@ -946,17 +963,20 @@ ioeGetFileName :: IOError -> Maybe FilePath ioeGetErrorString :: IOError -> String ioeGetHandle :: IOError -> Maybe Handle -ioeGetHandle (IOError h _ _ _) = h -ioeGetErrorString (IOError _ iot _ str) = +ioeGetHandle (IOException (IOError h _ _ _)) = h +ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error" + +ioeGetErrorString (IOException (IOError _ iot _ str)) = case iot of EOF -> "end of file" _ -> str +ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error" -ioeGetFileName (IOError _ _ _ str) = +ioeGetFileName (IOException (IOError _ _ _ str)) = case span (/=':') str of (_,[]) -> Nothing (fs,_) -> Just fs - +ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error" \end{code} 'Top-level' IO actions want to catch exceptions (e.g., forkIO and @@ -1019,11 +1039,11 @@ wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantReadableHandle fun handle act = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle fun handle SemiClosedHandle -> ioe_closedHandle fun handle - AppendHandle -> ioError not_readable_error - WriteHandle -> ioError not_readable_error + AppendHandle -> ioException not_readable_error + WriteHandle -> ioException not_readable_error _ -> act handle_ where not_readable_error = @@ -1042,21 +1062,21 @@ wantWriteableHandle_ fun handle act = checkWriteableHandle fun handle handle_ act = case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioError (IOException theError) ClosedHandle -> ioe_closedHandle fun handle SemiClosedHandle -> ioe_closedHandle fun handle ReadHandle -> ioError not_writeable_error _ -> act where not_writeable_error = - IOError (Just handle) IllegalOperation fun - ("handle is not open for writing") + IOException (IOError (Just handle) IllegalOperation fun + ("handle is not open for writing")) wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantRWHandle fun handle act = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle fun handle SemiClosedHandle -> ioe_closedHandle fun handle _ -> act handle_ @@ -1065,15 +1085,15 @@ wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantSeekableHandle fun handle act = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle fun handle SemiClosedHandle -> ioe_closedHandle fun handle _ -> act handle_ where not_seekable_error = - IOError (Just handle) - IllegalOperation fun - ("handle is not seekable") + IOException (IOError (Just handle) + IllegalOperation fun + ("handle is not seekable")) \end{code} @@ -1082,7 +1102,8 @@ access to a closed file. \begin{code} ioe_closedHandle :: String -> Handle -> IO a -ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed") +ioe_closedHandle fun h = ioError (IOException (IOError (Just h) IllegalOperation fun + "handle is closed")) \end{code} Internal helper functions for Concurrent Haskell implementation diff --git a/ghc/lib/std/PrelIO.lhs b/ghc/lib/std/PrelIO.lhs index f500692..944ed19 100644 --- a/ghc/lib/std/PrelIO.lhs +++ b/ghc/lib/std/PrelIO.lhs @@ -1,6 +1,9 @@ +% ------------------------------------------------------------------------------ +% $Id: PrelIO.lhs,v 1.14 2000/07/07 11:03:58 simonmar Exp $ % -% (c) The GRAP/AQUA Project, Glasgow University, 1992-1996 +% (c) The University of Glasgow, 1992-2000 % + \section[PrelIO]{Module @PrelIO@} This module defines all basic IO operations. @@ -20,15 +23,13 @@ import PrelIOBase import PrelHandle -- much of the real stuff is in here import PrelNum -import PrelRead ( readParen, Read(..), reads, lex, readIO ) +import PrelRead ( Read(..), readIO ) import PrelShow -import PrelMaybe ( Either(..), Maybe(..) ) +import PrelMaybe ( Maybe(..) ) import PrelAddr ( Addr(..), AddrOff(..), nullAddr, plusAddr ) import PrelList ( concat, reverse, null ) -import PrelByteArr ( ByteArray ) import PrelPack ( unpackNBytesST, unpackNBytesAccST ) -import PrelException ( ioError, catch, catchException, throw, - blockAsyncExceptions ) +import PrelException ( ioError, catch, catchException, throw ) import PrelConc \end{code} @@ -228,11 +229,11 @@ hGetContents handle = -- the handle. withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError + ErrorHandle theError -> ioException theError ClosedHandle -> ioe_closedHandle "hGetContents" handle SemiClosedHandle -> ioe_closedHandle "hGetContents" handle - AppendHandle -> ioError not_readable_error - WriteHandle -> ioError not_readable_error + AppendHandle -> ioException not_readable_error + WriteHandle -> ioException not_readable_error _ -> do {- To avoid introducing an extra layer of buffering here, diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 4131de0..7c53b59 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,7 +1,7 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelIOBase.lhs,v 1.25 2000/05/30 14:28:13 simonmar Exp $ +% ------------------------------------------------------------------------------ +% $Id: PrelIOBase.lhs,v 1.26 2000/07/07 11:03:58 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1998 +% (c) The University of Glasgow, 1994-2000 % \section[PrelIOBase]{Module @PrelIOBase@} @@ -11,8 +11,8 @@ concretely; the @IO@ module itself exports abstractly. \begin{code} {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} -#include "cbits/stgerror.h" #include "config.h" +#include "cbits/stgerror.h" #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */ module PrelIOBase where @@ -21,11 +21,12 @@ import {-# SOURCE #-} PrelErr ( error ) import PrelST import PrelBase -import {-# SOURCE #-} PrelException ( ioError ) import PrelMaybe ( Maybe(..) ) -import PrelAddr ( Addr(..), nullAddr ) -import PrelPack ( unpackCString ) +import PrelAddr ( Addr(..) ) import PrelShow +import PrelList +import PrelDynamic +import PrelPack ( unpackCString ) #if !defined(__CONCURRENT_HASKELL__) import PrelArr ( MutableVar, readVar ) @@ -143,228 +144,6 @@ unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST %********************************************************* %* * -\subsection{Type @IOError@} -%* * -%********************************************************* - -A value @IOError@ encode errors occurred in the @IO@ monad. -An @IOError@ records a more specific error type, a descriptive -string and maybe the handle that was used when the error was -flagged. - -\begin{code} -data IOError - = IOError - (Maybe Handle) -- the handle used by the action flagging the - -- the error. - IOErrorType -- what it was. - String -- location - String -- error type specific information. - -instance Eq IOError where - (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) = - e1==e2 && str1==str2 && h1==h2 && loc1 == loc2 - -data IOErrorType - = AlreadyExists | HardwareFault - | IllegalOperation | InappropriateType - | Interrupted | InvalidArgument - | NoSuchThing | OtherError - | PermissionDenied | ProtocolError - | ResourceBusy | ResourceExhausted - | ResourceVanished | SystemError - | TimeExpired | UnsatisfiedConstraints - | UnsupportedOperation | UserError - | EOF -#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS) - | ComError Int -- HRESULT -#endif - deriving (Eq) - -instance Show IOErrorType where - showsPrec _ e = - showString $ - case e of - AlreadyExists -> "already exists" - HardwareFault -> "hardware fault" - IllegalOperation -> "illegal operation" - InappropriateType -> "inappropriate type" - Interrupted -> "interrupted" - InvalidArgument -> "invalid argument" - NoSuchThing -> "does not exist" - OtherError -> "failed" - PermissionDenied -> "permission denied" - ProtocolError -> "protocol error" - ResourceBusy -> "resource busy" - ResourceExhausted -> "resource exhausted" - ResourceVanished -> "resource vanished" - SystemError -> "system error" - TimeExpired -> "timeout" - UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! - UserError -> "failed" - UnsupportedOperation -> "unsupported operation" - EOF -> "end of file" -#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS) - ComError _ -> "COM error" -#endif - - - -userError :: String -> IOError -userError str = IOError Nothing UserError "" str -\end{code} - -Predicates on IOError; little effort made on these so far... - -\begin{code} - -isAlreadyExistsError :: IOError -> Bool -isAlreadyExistsError (IOError _ AlreadyExists _ _) = True -isAlreadyExistsError _ = False - -isAlreadyInUseError :: IOError -> Bool -isAlreadyInUseError (IOError _ ResourceBusy _ _) = True -isAlreadyInUseError _ = False - -isFullError :: IOError -> Bool -isFullError (IOError _ ResourceExhausted _ _) = True -isFullError _ = False - -isEOFError :: IOError -> Bool -isEOFError (IOError _ EOF _ _) = True -isEOFError _ = False - -isIllegalOperation :: IOError -> Bool -isIllegalOperation (IOError _ IllegalOperation _ _) = True -isIllegalOperation _ = False - -isPermissionError :: IOError -> Bool -isPermissionError (IOError _ PermissionDenied _ _) = True -isPermissionError _ = False - -isDoesNotExistError :: IOError -> Bool -isDoesNotExistError (IOError _ NoSuchThing _ _) = True -isDoesNotExistError _ = False - -isUserError :: IOError -> Bool -isUserError (IOError _ UserError _ _) = True -isUserError _ = False -\end{code} - -Showing @IOError@s - -\begin{code} -#ifdef __HUGS__ --- For now we give a fairly uninformative error message which just happens to --- be like the ones that Hugs used to give. -instance Show IOError where - showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n' -#else -instance Show IOError where - showsPrec p (IOError hdl iot loc s) = - showsPrec p iot . - showChar '\n' . - (case loc of - "" -> id - _ -> showString "Action: " . showString loc . showChar '\n') . - showHdl . - (case s of - "" -> id - _ -> showString "Reason: " . showString s) - where - showHdl = - case hdl of - Nothing -> id - Just h -> showString "Handle: " . showsPrec p h - -#endif -\end{code} - -The @String@ part of an @IOError@ is platform-dependent. However, to -provide a uniform mechanism for distinguishing among errors within -these broad categories, each platform-specific standard shall specify -the exact strings to be used for particular errors. For errors not -explicitly mentioned in the standard, any descriptive string may be -used. - -\begin{code} -constructErrorAndFail :: String -> IO a -constructErrorAndFail call_site - = constructError call_site >>= \ io_error -> - ioError io_error - -constructErrorAndFailWithInfo :: String -> String -> IO a -constructErrorAndFailWithInfo call_site reason - = constructErrorMsg call_site (Just reason) >>= \ io_error -> - ioError io_error - -\end{code} - -This doesn't seem to be documented/spelled out anywhere, -so here goes: (SOF) - -The implementation of the IO prelude uses various C stubs -to do the actual interaction with the OS. The bandwidth -\tr{C<->Haskell} is somewhat limited, so the general strategy -for flaggging any errors (apart from possibly using the -return code of the external call), is to set the @ghc_errtype@ -to a value that is one of the \tr{#define}s in @includes/error.h@. -@ghc_errstr@ holds a character string providing error-specific -information. Error constructing functions will then reach out -and grab these values when generating - -\begin{code} -constructError :: String -> IO IOError -constructError call_site = constructErrorMsg call_site Nothing - -constructErrorMsg :: String -> Maybe String -> IO IOError -constructErrorMsg call_site reason = - getErrType__ >>= \ errtype -> - getErrStr__ >>= \ str -> - let - iot = - case (errtype::Int) of - ERR_ALREADYEXISTS -> AlreadyExists - ERR_HARDWAREFAULT -> HardwareFault - ERR_ILLEGALOPERATION -> IllegalOperation - ERR_INAPPROPRIATETYPE -> InappropriateType - ERR_INTERRUPTED -> Interrupted - ERR_INVALIDARGUMENT -> InvalidArgument - ERR_NOSUCHTHING -> NoSuchThing - ERR_OTHERERROR -> OtherError - ERR_PERMISSIONDENIED -> PermissionDenied - ERR_PROTOCOLERROR -> ProtocolError - ERR_RESOURCEBUSY -> ResourceBusy - ERR_RESOURCEEXHAUSTED -> ResourceExhausted - ERR_RESOURCEVANISHED -> ResourceVanished - ERR_SYSTEMERROR -> SystemError - ERR_TIMEEXPIRED -> TimeExpired - ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints - ERR_UNSUPPORTEDOPERATION -> UnsupportedOperation - ERR_EOF -> EOF - _ -> OtherError - - msg = - unpackCString str ++ - (case iot of - OtherError -> "(error code: " ++ show errtype ++ ")" - _ -> "") ++ - (case reason of - Nothing -> "" - Just m -> ' ':m) - in - return (IOError Nothing iot call_site msg) -\end{code} - -File names are specified using @FilePath@, a OS-dependent -string that (hopefully, I guess) maps to an accessible file/object. - -\begin{code} -type FilePath = String -\end{code} - -%********************************************************* -%* * \subsection{Types @Handle@, @Handle__@} %* * %********************************************************* @@ -443,7 +222,7 @@ data Handle__ of the following: -} data Handle__Type - = ErrorHandle IOError + = ErrorHandle IOException | ClosedHandle | SemiClosedHandle | ReadHandle @@ -452,6 +231,19 @@ data Handle__Type | ReadWriteHandle +-- File names are specified using @FilePath@, a OS-dependent +-- string that (hopefully, I guess) maps to an accessible file/object. + +type FilePath = String +\end{code} + +%********************************************************* +%* * +\subsection[Show-Handle]{Show instance for Handles} +%* * +%********************************************************* + +\begin{code} -- handle types are 'show'ed when printing error msgs, so -- we provide a more user-friendly Show instance for it -- than the derived one. @@ -507,19 +299,6 @@ instance Show Handle where where def :: Int def = unsafePerformIO (getBufSize fo) - -mkBuffer__ :: FILE_OBJECT -> Int -> IO () -mkBuffer__ fo sz_in_bytes = do - chunk <- - case sz_in_bytes of - 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer. - _ -> do - chunk <- allocMemory__ sz_in_bytes - if chunk == nullAddr - then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory") - else return chunk - setBuf fo chunk sz_in_bytes - \end{code} %********************************************************* @@ -589,3 +368,324 @@ foreign import "libHS_cbits" "setBuf" unsafe setBuf :: FILE_OBJECT -> Addr -> Int -> IO () \end{code} + +%********************************************************* +%* * +\subsection{Exception datatype and operations} +%* * +%********************************************************* + +\begin{code} +data Exception + = IOException IOException -- IO exceptions + | ArithException ArithException -- Arithmetic exceptions + | ArrayException ArrayException -- Array-related exceptions + | ErrorCall String -- Calls to 'error' + | NoMethodError String -- A non-existent method was invoked + | PatternMatchFail String -- A pattern match / guard failure + | RecSelError String -- Selecting a non-existent field + | RecConError String -- Field missing in record construction + | RecUpdError String -- Record doesn't contain updated field + | AssertionFailed String -- Assertions + | DynException Dynamic -- Dynamic exceptions + | AsyncException AsyncException -- Externally generated errors + | PutFullMVar -- Put on a full MVar + | BlockedOnDeadMVar -- Blocking on a dead MVar + | NonTermination + | UserError String + +data ArithException + = Overflow + | Underflow + | LossOfPrecision + | DivideByZero + | Denormal + deriving (Eq, Ord) + +data AsyncException + = StackOverflow + | HeapOverflow + | ThreadKilled + deriving (Eq, Ord) + +data ArrayException + = IndexOutOfBounds String -- out-of-range array access + | UndefinedElement String -- evaluating an undefined element + 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" + +instance Show AsyncException where + showsPrec _ StackOverflow = showString "stack overflow" + showsPrec _ HeapOverflow = showString "heap overflow" + showsPrec _ ThreadKilled = showString "thread killed" + +instance Show ArrayException where + showsPrec _ (IndexOutOfBounds s) + = 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 _ (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 _ (AsyncException e) = shows e + showsPrec _ (DynException _err) = showString "unknown exception" + showsPrec _ (PutFullMVar) = showString "putMVar: full MVar" + showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely" + showsPrec _ (NonTermination) = showString "<>" +\end{code} + +%********************************************************* +%* * +\subsection{Primitive throw} +%* * +%********************************************************* + +\begin{code} +throw :: Exception -> a +throw exception = raise# exception + +ioError :: Exception -> IO a +ioError err = IO $ \s -> throw err s + +ioException :: IOException -> IO a +ioException err = IO $ \s -> throw (IOException err) s +\end{code} + +%********************************************************* +%* * +\subsection{Type @IOError@} +%* * +%********************************************************* + +A value @IOError@ encode errors occurred in the @IO@ monad. +An @IOError@ records a more specific error type, a descriptive +string and maybe the handle that was used when the error was +flagged. + +\begin{code} +type IOError = Exception + +data IOException + = IOError + (Maybe Handle) -- the handle used by the action flagging the + -- the error. + IOErrorType -- what it was. + String -- location + String -- error type specific information. + +instance Eq IOException where + (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) = + e1==e2 && str1==str2 && h1==h2 && loc1 == loc2 + +data IOErrorType + = AlreadyExists | HardwareFault + | IllegalOperation | InappropriateType + | Interrupted | InvalidArgument + | NoSuchThing | OtherError + | PermissionDenied | ProtocolError + | ResourceBusy | ResourceExhausted + | ResourceVanished | SystemError + | TimeExpired | UnsatisfiedConstraints + | UnsupportedOperation + | EOF +#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS) + | ComError Int -- HRESULT +#endif + deriving (Eq) + +instance Show IOErrorType where + showsPrec _ e = + showString $ + case e of + AlreadyExists -> "already exists" + HardwareFault -> "hardware fault" + IllegalOperation -> "illegal operation" + InappropriateType -> "inappropriate type" + Interrupted -> "interrupted" + InvalidArgument -> "invalid argument" + NoSuchThing -> "does not exist" + OtherError -> "failed" + PermissionDenied -> "permission denied" + ProtocolError -> "protocol error" + ResourceBusy -> "resource busy" + ResourceExhausted -> "resource exhausted" + ResourceVanished -> "resource vanished" + SystemError -> "system error" + TimeExpired -> "timeout" + UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! + UnsupportedOperation -> "unsupported operation" + EOF -> "end of file" +#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS) + ComError _ -> "COM error" +#endif + + + +userError :: String -> IOError +userError str = UserError str +\end{code} + +Predicates on IOError; little effort made on these so far... + +\begin{code} + +isAlreadyExistsError :: IOError -> Bool +isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _)) = True +isAlreadyExistsError _ = False + +isAlreadyInUseError :: IOError -> Bool +isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _)) = True +isAlreadyInUseError _ = False + +isFullError :: IOError -> Bool +isFullError (IOException (IOError _ ResourceExhausted _ _)) = True +isFullError _ = False + +isEOFError :: IOError -> Bool +isEOFError (IOException (IOError _ EOF _ _)) = True +isEOFError _ = False + +isIllegalOperation :: IOError -> Bool +isIllegalOperation (IOException (IOError _ IllegalOperation _ _)) = True +isIllegalOperation _ = False + +isPermissionError :: IOError -> Bool +isPermissionError (IOException (IOError _ PermissionDenied _ _)) = True +isPermissionError _ = False + +isDoesNotExistError :: IOError -> Bool +isDoesNotExistError (IOException (IOError _ NoSuchThing _ _)) = True +isDoesNotExistError _ = False + +isUserError :: IOError -> Bool +isUserError (UserError _) = True +isUserError _ = False +\end{code} + +Showing @IOError@s + +\begin{code} +#ifdef __HUGS__ +-- For now we give a fairly uninformative error message which just happens to +-- be like the ones that Hugs used to give. +instance Show IOException where + showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n' +#else +instance Show IOException where + showsPrec p (IOError hdl iot loc s) = + showsPrec p iot . + showChar '\n' . + (case loc of + "" -> id + _ -> showString "Action: " . showString loc . showChar '\n') . + showHdl . + (case s of + "" -> id + _ -> showString "Reason: " . showString s) + where + showHdl = + case hdl of + Nothing -> id + Just h -> showString "Handle: " . showsPrec p h + +#endif +\end{code} + +The @String@ part of an @IOError@ is platform-dependent. However, to +provide a uniform mechanism for distinguishing among errors within +these broad categories, each platform-specific standard shall specify +the exact strings to be used for particular errors. For errors not +explicitly mentioned in the standard, any descriptive string may be +used. + +\begin{code} +constructErrorAndFail :: String -> IO a +constructErrorAndFail call_site + = constructError call_site >>= \ io_error -> + ioError (IOException io_error) + +constructErrorAndFailWithInfo :: String -> String -> IO a +constructErrorAndFailWithInfo call_site reason + = constructErrorMsg call_site (Just reason) >>= \ io_error -> + ioError (IOException io_error) + +\end{code} + +This doesn't seem to be documented/spelled out anywhere, +so here goes: (SOF) + +The implementation of the IO prelude uses various C stubs +to do the actual interaction with the OS. The bandwidth +\tr{C<->Haskell} is somewhat limited, so the general strategy +for flaggging any errors (apart from possibly using the +return code of the external call), is to set the @ghc_errtype@ +to a value that is one of the \tr{#define}s in @includes/error.h@. +@ghc_errstr@ holds a character string providing error-specific +information. Error constructing functions will then reach out +and grab these values when generating + +\begin{code} +constructError :: String -> IO IOException +constructError call_site = constructErrorMsg call_site Nothing + +constructErrorMsg :: String -> Maybe String -> IO IOException +constructErrorMsg call_site reason = + getErrType__ >>= \ errtype -> + getErrStr__ >>= \ str -> + let + iot = + case (errtype::Int) of + ERR_ALREADYEXISTS -> AlreadyExists + ERR_HARDWAREFAULT -> HardwareFault + ERR_ILLEGALOPERATION -> IllegalOperation + ERR_INAPPROPRIATETYPE -> InappropriateType + ERR_INTERRUPTED -> Interrupted + ERR_INVALIDARGUMENT -> InvalidArgument + ERR_NOSUCHTHING -> NoSuchThing + ERR_OTHERERROR -> OtherError + ERR_PERMISSIONDENIED -> PermissionDenied + ERR_PROTOCOLERROR -> ProtocolError + ERR_RESOURCEBUSY -> ResourceBusy + ERR_RESOURCEEXHAUSTED -> ResourceExhausted + ERR_RESOURCEVANISHED -> ResourceVanished + ERR_SYSTEMERROR -> SystemError + ERR_TIMEEXPIRED -> TimeExpired + ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints + ERR_UNSUPPORTEDOPERATION -> UnsupportedOperation + ERR_EOF -> EOF + _ -> OtherError + + msg = + unpackCString str ++ + (case iot of + OtherError -> "(error code: " ++ show errtype ++ ")" + _ -> "") ++ + (case reason of + Nothing -> "" + Just m -> ' ':m) + in + return (IOError Nothing iot call_site msg) +\end{code} diff --git a/ghc/lib/std/PrelPack.lhs b/ghc/lib/std/PrelPack.lhs index 4788126..098f2f4 100644 --- a/ghc/lib/std/PrelPack.lhs +++ b/ghc/lib/std/PrelPack.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelPack.lhs,v 1.13 2000/06/30 13:39:36 simonmar Exp $ +% $Id: PrelPack.lhs,v 1.14 2000/07/07 11:03:58 simonmar Exp $ % % (c) The University of Glasgow, 1997-2000 % @@ -55,7 +55,6 @@ import {-# SOURCE #-} PrelErr ( error ) import PrelList ( length ) import PrelST import PrelNum -import PrelArr import PrelByteArr import PrelAddr diff --git a/ghc/lib/std/PrelST.lhs b/ghc/lib/std/PrelST.lhs index 996e7cf..a5a0411 100644 --- a/ghc/lib/std/PrelST.lhs +++ b/ghc/lib/std/PrelST.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelST.lhs,v 1.15 2000/06/30 13:39:36 simonmar Exp $ +% $Id: PrelST.lhs,v 1.16 2000/07/07 11:03:58 simonmar Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -13,7 +13,6 @@ module PrelST where import PrelShow import PrelBase -import PrelGHC import PrelNum () -- So that we get the .hi file for system imports default () diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index 61955b0..c96e2b9 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -1,5 +1,7 @@ +% ----------------------------------------------------------------------------- +% $Id: System.lhs,v 1.26 2000/07/07 11:03:58 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1999 +% (c) The University of Glasgow, 1994-2000 % \section[System]{Module @System@} @@ -23,7 +25,8 @@ module System \begin{code} import Prelude import PrelAddr -import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo, stToIO ) +import PrelIOBase ( IOException(..), ioException, + IOErrorType(..), constructErrorAndFailWithInfo, stToIO ) import PrelPack ( unpackCString, unpackCStringST, packString ) import PrelByteArr ( ByteArray ) @@ -90,8 +93,8 @@ getEnv name = do litstring <- primGetEnv (primPackString name) if litstring /= nullAddr then primUnpackCString litstring - else ioError (IOError Nothing NoSuchThing "getEnv" - ("environment variable: " ++ name)) + else ioException (IOError Nothing NoSuchThing "getEnv" + ("environment variable: " ++ name)) foreign import ccall "libHS_cbits.so" "getenv" unsafe primGetEnv :: PrimByteArray -> IO Addr \end{code} @@ -111,7 +114,7 @@ The implementation does not support system calls. \begin{code} system :: String -> IO ExitCode -system "" = ioError (IOError Nothing InvalidArgument "system" "null command") +system "" = ioException (IOError Nothing InvalidArgument "system" "null command") system cmd = do status <- primSystem (primPackString cmd) case status of @@ -129,13 +132,13 @@ Before it terminates, any open or semi-closed handles are first closed. exitWith :: ExitCode -> IO a exitWith ExitSuccess = do primExit 0 - ioError (IOError Nothing OtherError "exitWith" "exit should not return") + ioException (IOError Nothing OtherError "exitWith" "exit should not return") exitWith (ExitFailure n) - | n == 0 = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0") + | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0") | otherwise = do primExit n - ioError (IOError Nothing OtherError "exitWith" "exit should not return") + ioException (IOError Nothing OtherError "exitWith" "exit should not return") -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can* -- re-enter Haskell land through finalizers. @@ -243,12 +246,12 @@ exitWith c nh_stdout >>= nh_flush nh_stdin >>= nh_close nh_exitwith (fromExitCode c) - (ioError.IOError) "System.exitWith: should not return" + (ioException . IOError) "System.exitWith: should not return" system :: String -> IO ExitCode system cmd | null cmd - = (ioError.IOError) "System.system: null command" + = (ioException.IOError) "System.system: null command" | otherwise = do str <- copy_String_to_cstring cmd status <- nh_system str diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index db04225..c2f6ca9 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.11 2000/06/15 13:23:52 daan Exp $ + * $Id: Prelude.h,v 1.12 2000/07/07 11:03:57 simonmar Exp $ * * (c) The GHC Team, 1998-2000 * @@ -21,11 +21,11 @@ extern DLL_IMPORT const StgClosure PrelPack_unpackCString_closure; extern DLL_IMPORT const StgClosure PrelWeak_runFinalizzerBatch_closure; extern const StgClosure PrelMain_mainIO_closure; -extern DLL_IMPORT const StgClosure PrelException_stackOverflow_closure; -extern DLL_IMPORT const StgClosure PrelException_heapOverflow_closure; -extern DLL_IMPORT const StgClosure PrelException_PutFullMVar_closure; -extern DLL_IMPORT const StgClosure PrelException_BlockedOnDeadMVar_closure; -extern DLL_IMPORT const StgClosure PrelException_NonTermination_closure; +extern DLL_IMPORT const StgClosure PrelIOBase_stackOverflow_closure; +extern DLL_IMPORT const StgClosure PrelIOBase_heapOverflow_closure; +extern DLL_IMPORT const StgClosure PrelIOBase_PutFullMVar_closure; +extern DLL_IMPORT const StgClosure PrelIOBase_BlockedOnDeadMVar_closure; +extern DLL_IMPORT const StgClosure PrelIOBase_NonTermination_closure; extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info; extern DLL_IMPORT const StgInfoTable PrelBase_Izh_static_info; @@ -50,11 +50,11 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; #define runFinalizerBatch_closure (&PrelWeak_runFinalizzerBatch_closure) #define mainIO_closure (&PrelMain_mainIO_closure) -#define stackOverflow_closure (&PrelException_stackOverflow_closure) -#define heapOverflow_closure (&PrelException_heapOverflow_closure) -#define PutFullMVar_closure (&PrelException_PutFullMVar_closure) -#define BlockedOnDeadMVar_closure (&PrelException_BlockedOnDeadMVar_closure) -#define NonTermination_closure (&PrelException_NonTermination_closure) +#define stackOverflow_closure (&PrelIOBase_stackOverflow_closure) +#define heapOverflow_closure (&PrelIOBase_heapOverflow_closure) +#define PutFullMVar_closure (&PrelIOBase_PutFullMVar_closure) +#define BlockedOnDeadMVar_closure (&PrelIOBase_BlockedOnDeadMVar_closure) +#define NonTermination_closure (&PrelIOBase_NonTermination_closure) #define Czh_static_info (&PrelBase_Czh_static_info) #define Izh_static_info (&PrelBase_Izh_static_info)