X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Flib%2Fghc%2FIOBase.lhs;h=9121dfcf96768ffa77f8718be0a092ff9dff9d7e;hb=a1f430d97717f193646614d877d0815b6ad6c0ac;hp=8214bd3c7ab9d28a958aac41be9a2291b615d39a;hpb=8f7ac3fe40d3d55743b824deab655d0797a1c55f;p=ghc-hetmet.git diff --git a/ghc/lib/ghc/IOBase.lhs b/ghc/lib/ghc/IOBase.lhs index 8214bd3..9121dfc 100644 --- a/ghc/lib/ghc/IOBase.lhs +++ b/ghc/lib/ghc/IOBase.lhs @@ -8,20 +8,23 @@ Definitions for the @IO@ monad and its friends. Everything is exported concretely; the @IO@ module itself exports abstractly. \begin{code} -#include "error.h" - {-# OPTIONS -fno-implicit-prelude #-} +#include "error.h" module IOBase where import STBase +import UnsafeST import PrelTup import Foreign -import PackedString ( unpackCString ) +import PackBase ( unpackCString ) import PrelBase +import ArrBase ( ByteArray(..), MutableVar(..) ) +import PrelRead + import GHC -infixr 1 `thenIO_Prim` +infixr 1 `thenIO_Prim`, `seqIO_Prim` \end{code} %********************************************************* @@ -30,54 +33,58 @@ infixr 1 `thenIO_Prim` %* * %********************************************************* +IO is no longer built on top of PrimIO (which is a specialised version +of the ST monad), instead it is now has its own type. This is purely +for efficiency purposes, since we get to remove several levels of +lifting in the type of the monad. + \begin{code} -newtype IO a = IO (PrimIO (Either IOError a)) +newtype IO a = IO (State# RealWorld -> IOResult a) + +{-# INLINE unIO #-} +unIO (IO a) = a + +data IOResult a = IOok (State# RealWorld) a + | IOfail (State# RealWorld) IOError instance Functor IO where map f x = x >>= (return . f) instance Monad IO where -{- No inlining for now... until we can inline some of the - imports, like $, these functions are pretty big. {-# INLINE return #-} {-# INLINE (>>) #-} {-# INLINE (>>=) #-} --} m >> k = m >>= \ _ -> k - return x = IO $ ST $ \ s@(S# _) -> (Right x, s) + return x = IO $ \ s -> IOok s x - (IO (ST m)) >>= k - = IO $ ST $ \ s -> - let (r, new_s) = m s in - case r of - Left err -> (Left err, new_s) - Right x -> case (k x) of { IO (ST k2) -> - k2 new_s } + (IO m) >>= k = + IO $ \s -> + case m s of + IOfail new_s err -> IOfail new_s err + IOok new_s a -> unIO (k a) new_s fixIO :: (a -> IO a) -> IO a -- not required but worth having around -fixIO k = IO $ ST $ \ s -> +fixIO k = IO $ \ s -> let - (IO (ST k_loop)) = k loop - result = k_loop s - (Right loop, _) = result + (IO k_loop) = k loop + result = k_loop s + IOok _ loop = result in result fail :: IOError -> IO a -fail err = IO $ ST $ \ s -> (Left err, s) +fail err = IO $ \ s -> IOfail s err userError :: String -> IOError -userError str = UserError str +userError str = IOError Nothing UserError str catch :: IO a -> (IOError -> IO a) -> IO a -catch (IO (ST m)) k = IO $ ST $ \ s -> - case (m s) of { (r, new_s) -> - case r of - Right _ -> (r, new_s) - Left err -> case (k err) of { IO (ST k_err) -> - (k_err new_s) }} +catch (IO m) k = IO $ \ s -> + case m s of + IOok new_s a -> IOok new_s a + IOfail new_s e -> unIO (k e) new_s instance Show (IO a) where showsPrec p f = showString "<>" @@ -99,28 +106,26 @@ ioToPrimIO :: IO a -> PrimIO a primIOToIO = stToIO -- for backwards compatibility ioToPrimIO = ioToST -stToIO (ST m) = IO $ ST $ \ s -> - case (m s) of { (r, new_s) -> - (Right r, new_s) } +stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r -ioToST (IO (ST io)) = ST $ \ s -> - case (io s) of { (r, new_s) -> - case r of - Right a -> (a, new_s) - Left e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n") - } +ioToST (IO io) = ST $ \ s -> + case (io s) of + IOok new_s a -> STret new_s a + IOfail new_s e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n") \end{code} @thenIO_Prim@ is a useful little number for doing _ccall_s in IO-land: \begin{code} thenIO_Prim :: PrimIO a -> (a -> IO b) -> IO b +seqIO_Prim :: PrimIO a -> IO b -> IO b {-# INLINE thenIO_Prim #-} +{-# INLINE seqIO_Prim #-} -thenIO_Prim (ST m) k = IO $ ST $ \ s -> - case (m s) of { (m_res, new_s) -> - case (k m_res) of { (IO (ST k_m_res)) -> - k_m_res new_s }} +thenIO_Prim (ST m) k = IO $ \ s -> + case (m s) of STret new_s m_res -> unIO (k m_res) new_s + +seqIO_Prim m k = thenIO_Prim m (\ _ -> k) \end{code} @@ -139,6 +144,8 @@ errorIO (ST io) where bottom = bottom -- Never evaluated +--errorIO x = (waitRead#, errorIO#, makeForeignObj#, waitWrite#, (+#)) + -- error stops execution and displays an error message error :: String -> a error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s @@ -194,15 +201,6 @@ trace string expr %* * %********************************************************* -The construct $try comp$ exposes errors which occur within a -computation, and which are not fully handled. It always succeeds. -This one didn't make it into the 1.3 defn - -\begin{code} -tryIO :: IO a -> IO (Either IOError a) -tryIO p = catch (p >>= (return . Right)) (return . Left) -\end{code} - I'm not sure why this little function is here... \begin{code} @@ -222,107 +220,83 @@ fputs stream (c : cs) %* * %********************************************************* +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 - = AlreadyExists String - | HardwareFault String - | IllegalOperation String - | InappropriateType String - | Interrupted String - | InvalidArgument String - | NoSuchThing String - | OtherError String - | PermissionDenied String - | ProtocolError String - | ResourceBusy String - | ResourceExhausted String - | ResourceVanished String - | SystemError String - | TimeExpired String - | UnsatisfiedConstraints String - | UnsupportedOperation String - | UserError String +data IOError + = IOError + (Maybe Handle) -- the handle used by the action flagging the + -- the error. + IOErrorType -- what it was. + String -- error type specific information. + + +data IOErrorType + = AlreadyExists | HardwareFault + | IllegalOperation | InappropriateType + | Interrupted | InvalidArgument + | NoSuchThing | OtherError + | PermissionDenied | ProtocolError + | ResourceBusy | ResourceExhausted + | ResourceVanished | SystemError + | TimeExpired | UnsatisfiedConstraints + | UnsupportedOperation | UserError | EOF + deriving (Eq, Show) -instance Eq IOError where - -- I don't know what the (pointless) idea is here, - -- presumably just compare them by their tags (WDP) - a == b = tag a == tag b - where - tag (AlreadyExists _) = (1::Int) - tag (HardwareFault _) = 2 - tag (IllegalOperation _) = 3 - tag (InappropriateType _) = 4 - tag (Interrupted _) = 5 - tag (InvalidArgument _) = 6 - tag (NoSuchThing _) = 7 - tag (OtherError _) = 8 - tag (PermissionDenied _) = 9 - tag (ProtocolError _) = 10 - tag (ResourceBusy _) = 11 - tag (ResourceExhausted _) = 12 - tag (ResourceVanished _) = 13 - tag (SystemError _) = 14 - tag (TimeExpired _) = 15 - tag (UnsatisfiedConstraints _) = 16 - tag (UnsupportedOperation _) = 17 - tag (UserError _) = 18 - tag EOF = 19 \end{code} -Predicates on IOError; almost no effort made on these so far... +Predicates on IOError; little effort made on these so far... \begin{code} -isAlreadyExistsError (AlreadyExists _) = True -isAlreadyExistsError _ = False +isAlreadyExistsError (IOError _ AlreadyExists _) = True +isAlreadyExistsError _ = False -isAlreadyInUseError (ResourceBusy _) = True -isAlreadyInUseError _ = False +isAlreadyInUseError (IOError _ ResourceBusy _) = True +isAlreadyInUseError _ = False -isFullError (ResourceExhausted _) = True -isFullError _ = False +isFullError (IOError _ ResourceExhausted _) = True +isFullError _ = False -isEOFError EOF = True -isEOFError _ = True +isEOFError (IOError _ EOF _) = True +isEOFError _ = True -isIllegalOperation (IllegalOperation _) = True -isIllegalOperation _ = False +isIllegalOperation (IOError _ IllegalOperation _) = True +isIllegalOperation _ = False -isPermissionError (PermissionDenied _) = True -isPermissionError _ = False +isPermissionError (IOError _ PermissionDenied _) = True +isPermissionError _ = False -isUserError (UserError s) = Just s -isUserError _ = Nothing +isDoesNotExistError (IOError _ NoSuchThing _) = True +isDoesNotExistError _ = False + +isUserError (IOError _ UserError s) = Just s +isUserError _ = Nothing \end{code} Showing @IOError@s \begin{code} instance Show IOError where - showsPrec p (AlreadyExists s) = show2 "AlreadyExists: " s - showsPrec p (HardwareFault s) = show2 "HardwareFault: " s - showsPrec p (IllegalOperation s) = show2 "IllegalOperation: " s - showsPrec p (InappropriateType s) = show2 "InappropriateType: " s - showsPrec p (Interrupted s) = show2 "Interrupted: " s - showsPrec p (InvalidArgument s) = show2 "InvalidArgument: " s - showsPrec p (NoSuchThing s) = show2 "NoSuchThing: " s - showsPrec p (OtherError s) = show2 "OtherError: " s - showsPrec p (PermissionDenied s) = show2 "PermissionDenied: " s - showsPrec p (ProtocolError s) = show2 "ProtocolError: " s - showsPrec p (ResourceBusy s) = show2 "ResourceBusy: " s - showsPrec p (ResourceExhausted s) = show2 "ResourceExhausted: " s - showsPrec p (ResourceVanished s) = show2 "ResourceVanished: " s - showsPrec p (SystemError s) = show2 "SystemError: " s - showsPrec p (TimeExpired s) = show2 "TimeExpired: " s - showsPrec p (UnsatisfiedConstraints s) = show2 "UnsatisfiedConstraints: " s - showsPrec p (UnsupportedOperation s)= show2 "UnsupportedOperation: " s - showsPrec p (UserError s) = showString s - showsPrec p EOF = showString "EOF" - -show2 x y = showString x . showString y - + showsPrec p (IOError _ UserError s) rs = + showString s rs {- + showsPrec p (IOError _ EOF _) rs = + showsPrec p EOF rs +-} + showsPrec p (IOError _ iot s) rs = + showsPrec p + iot + (case s of { + "" -> rs; + _ -> showString ": " $ + showString s rs}) + +\end{code} The @String@ part of an @IOError@ is platform-dependent. However, to provide a uniform mechanism for distinguishing among errors within @@ -331,42 +305,162 @@ the exact strings to be used for particular errors. For errors not explicitly mentioned in the standard, any descriptive string may be used. - SOF 4/96 - added argument to indicate function that flagged error --} -constructErrorAndFail :: String -> IO a -constructError :: String -> PrimIO IOError +\begin{change} +SOF & 4/96 & added argument to indicate function that flagged error +\end{change} +% Hmm..does these envs work?!...SOF +\begin{code} +constructErrorAndFail :: String -> IO a constructErrorAndFail call_site = stToIO (constructError call_site) >>= \ io_error -> fail io_error -constructError call_site - = _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) -> - _casm_ ``%r = ghc_errstr;'' >>= \ str -> - let - msg = call_site ++ ':' : ' ' : unpackCString str - in - return (case errtype# of - ERR_ALREADYEXISTS# -> AlreadyExists msg - ERR_HARDWAREFAULT# -> HardwareFault msg - ERR_ILLEGALOPERATION# -> IllegalOperation msg - ERR_INAPPROPRIATETYPE# -> InappropriateType msg - ERR_INTERRUPTED# -> Interrupted msg - ERR_INVALIDARGUMENT# -> InvalidArgument msg - ERR_NOSUCHTHING# -> NoSuchThing msg - ERR_OTHERERROR# -> OtherError msg - ERR_PERMISSIONDENIED# -> PermissionDenied msg - ERR_PROTOCOLERROR# -> ProtocolError msg - ERR_RESOURCEBUSY# -> ResourceBusy msg - ERR_RESOURCEEXHAUSTED# -> ResourceExhausted msg - ERR_RESOURCEVANISHED# -> ResourceVanished msg - ERR_SYSTEMERROR# -> SystemError msg - ERR_TIMEEXPIRED# -> TimeExpired msg - ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints msg - ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation msg - ERR_EOF# -> EOF - _ -> OtherError "bad error construct" - ) \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. + +\begin{code} +constructError :: String -> PrimIO IOError +constructError call_site = + _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) -> + _casm_ ``%r = ghc_errstr;'' >>= \ str -> + let + iot = + case errtype# 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 = + call_site ++ ':' : ' ' : unpackCString str ++ + case iot of + OtherError -> "(error code: " ++ show (I# errtype#) ++ ")" + _ -> "" + in + return (IOError Nothing iot msg) +\end{code} + +%********************************************************* +%* * +\subsection{Types @Handle@, @Handle__@} +%* * +%********************************************************* + +The type for @Handle@ is defined rather than in @IOHandle@ +module, as the @IOError@ type uses it..all operations over +a handles reside in @IOHandle@. + +\begin{code} + +{- + Sigh, the MVar ops in ConcBase depend on IO, the IO + representation here depend on MVars for handles (when + compiling a concurrent way). Break the cycle by having + the definition of MVars go here: + +-} +data MVar a = MVar (SynchVar# RealWorld a) +#if defined(__CONCURRENT_HASKELL__) +type Handle = MVar Handle__ +#else +type Handle = MutableVar RealWorld Handle__ +#endif + +data Handle__ + = ErrorHandle IOError + | ClosedHandle +#ifndef __PARALLEL_HASKELL__ + | SemiClosedHandle ForeignObj (Addr, Int) + | ReadHandle ForeignObj (Maybe BufferMode) Bool + | WriteHandle ForeignObj (Maybe BufferMode) Bool + | AppendHandle ForeignObj (Maybe BufferMode) Bool + | ReadWriteHandle ForeignObj (Maybe BufferMode) Bool +#else + | SemiClosedHandle Addr (Addr, Int) + | ReadHandle Addr (Maybe BufferMode) Bool + | WriteHandle Addr (Maybe BufferMode) Bool + | AppendHandle Addr (Maybe BufferMode) Bool + | ReadWriteHandle Addr (Maybe BufferMode) Bool +#endif + +-- Standard Instances as defined by the Report.. +-- instance Eq Handle (defined in IO) +-- instance Show Handle "" + +\end{code} + +%********************************************************* +%* * +\subsection[BufferMode]{Buffering modes} +%* * +%********************************************************* + +Three kinds of buffering are supported: line-buffering, +block-buffering or no-buffering. These modes have the following +effects. For output, items are written out from the internal +buffer according to the buffer mode: + +\begin{itemize} +\item[line-buffering] the entire output buffer is written +out whenever a newline is output, the output buffer overflows, +a flush is issued, or the handle is closed. + +\item[block-buffering] the entire output buffer is written out whenever +it overflows, a flush is issued, or the handle +is closed. + +\item[no-buffering] output is written immediately, and never stored +in the output buffer. +\end{itemize} + +The output buffer is emptied as soon as it has been written out. + +Similarly, input occurs according to the buffer mode for handle {\em hdl}. +\begin{itemize} +\item[line-buffering] when the input buffer for {\em hdl} is not empty, +the next item is obtained from the buffer; +otherwise, when the input buffer is empty, +characters up to and including the next newline +character are read into the buffer. No characters +are available until the newline character is +available. +\item[block-buffering] when the input buffer for {\em hdl} becomes empty, +the next block of data is read into this buffer. +\item[no-buffering] the next input item is read and returned. +\end{itemize} +For most implementations, physical files will normally be block-buffered +and terminals will normally be line-buffered. + +\begin{code} +data BufferMode + = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) + deriving (Eq, Ord, Read, Show) +\end{code}