X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelIOBase.lhs;h=bf7a64f52681ccfa8ff76a102434541b07426713;hb=ef33ed94129ee17b577add392e04619ec1f53800;hp=93b26d637c9a3b544bada2cf61c4be27365a7510;hpb=6bfd2f54231675165b3345689f41ab77db0bbba9;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 93b26d6..bf7a64f 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,7 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1996 +% ----------------------------------------------------------------------------- +% $Id: PrelIOBase.lhs,v 1.15 1999/11/26 16:26:32 simonmar Exp $ +% +% (c) The AQUA Project, Glasgow University, 1994-1998 % \section[PrelIOBase]{Module @PrelIOBase@} @@ -8,21 +10,39 @@ Definitions for the @IO@ monad and its friends. Everything is exported concretely; the @IO@ module itself exports abstractly. \begin{code} -{-# OPTIONS -fno-implicit-prelude #-} -#include "error.h" +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} +#include "cbits/stgerror.h" +#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */ module PrelIOBase where import {-# SOURCE #-} PrelErr ( error ) + import PrelST -import PrelTup -import PrelMaybe -import PrelAddr -import PrelPack ( unpackCString ) import PrelBase -import PrelArr ( ByteArray(..), MutableVar ) -import PrelGHC +import {-# SOURCE #-} PrelException ( ioError ) +import PrelST ( ST(..), STret(..) ) +import PrelMaybe ( Maybe(..) ) +import PrelAddr ( Addr(..), nullAddr ) +import PrelPack ( unpackCString ) +import PrelShow + +#if !defined(__CONCURRENT_HASKELL__) +import PrelArr ( MutableVar, readVar ) +#endif +#endif +#ifdef __HUGS__ +#define __CONCURRENT_HASKELL__ +#define stToIO id +#define unpackCString primUnpackString +#endif + +#ifndef __PARALLEL_HASKELL__ +#define FILE_OBJECT ForeignObj +#else +#define FILE_OBJECT Addr +#endif \end{code} %********************************************************* @@ -31,62 +51,44 @@ import PrelGHC %* * %********************************************************* -IO is no longer built on top of PrimIO (which used to be 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. +The IO Monad is just an instance of the ST monad, where the state is +the real world. We use the exception mechanism (in PrelException) to +implement IO exceptions. \begin{code} -newtype IO a = IO (State# RealWorld -> IOResult a) +#ifndef __HUGS__ +newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) -{-# INLINE unIO #-} +unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) 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) + fmap f x = x >>= (return . f) instance Monad IO where {-# INLINE return #-} {-# INLINE (>>) #-} {-# INLINE (>>=) #-} m >> k = m >>= \ _ -> k - return x = IO $ \ s -> IOok s x + return x = IO $ \ s -> (# s, x #) - (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 + m >>= k = bindIO m k + fail s = error s -- not ioError? -fixIO :: (a -> IO a) -> IO a -- not required but worth having around +fixIO :: (a -> IO a) -> IO a +fixIO m = stToIO (fixST (ioToST . m)) -fixIO k = IO $ \ s -> - let - (IO k_loop) = k loop - result = k_loop s - IOok _ loop = result - in - result +liftIO :: IO a -> State# RealWorld -> STret RealWorld a +liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r -fail :: IOError -> IO a -fail err = IO $ \ s -> IOfail s err - -userError :: String -> IOError -userError str = IOError Nothing UserError str +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO (IO m) k = IO ( \ s -> + case m s of + (# new_s, a #) -> unIO (k a) new_s + ) -catch :: IO a -> (IOError -> IO a) -> IO a -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 "<>" - showList = showList__ (showsPrec 0) +#endif \end{code} %********************************************************* @@ -96,35 +98,34 @@ instance Show (IO a) where %********************************************************* \begin{code} -stToIO :: ST RealWorld a -> IO a -stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r - -ioToST :: IO a -> ST RealWorld a -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") +#ifdef __HUGS__ +/* Hugs doesn't distinguish these types so no coercion required) */ +#else +stToIO :: ST RealWorld a -> IO a +stToIO (ST m) = (IO m) + +ioToST :: IO a -> ST RealWorld a +ioToST (IO m) = (ST m) +#endif \end{code} %********************************************************* %* * -\subsection{Utility functions} +\subsection{Unsafe @IO@ operations} %* * %********************************************************* -I'm not sure why this little function is here... - \begin{code} -fputs :: Addr{-FILE*-} -> String -> IO Bool - -fputs stream [] = return True +#ifndef __HUGS__ +{-# NOINLINE unsafePerformIO #-} +unsafePerformIO :: IO a -> a +unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r -fputs stream (c : cs) - = _ccall_ stg_putc c stream >> -- stg_putc expands to putc - fputs stream cs -- (just does some casting stream) +unsafeInterleaveIO :: IO a -> IO a +unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST +#endif \end{code} - %********************************************************* %* * \subsection{Type @IOError@} @@ -142,8 +143,12 @@ data 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 @@ -156,57 +161,108 @@ data IOErrorType | TimeExpired | UnsatisfiedConstraints | UnsupportedOperation | UserError | EOF - deriving (Eq, Show) +#ifdef _WIN32 + | 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" +#ifdef _WIN32 + 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 _ AlreadyExists _) = True -isAlreadyExistsError _ = False +isAlreadyExistsError :: IOError -> Bool +isAlreadyExistsError (IOError _ AlreadyExists _ _) = True +isAlreadyExistsError _ = False -isAlreadyInUseError (IOError _ ResourceBusy _) = True -isAlreadyInUseError _ = False +isAlreadyInUseError :: IOError -> Bool +isAlreadyInUseError (IOError _ ResourceBusy _ _) = True +isAlreadyInUseError _ = False -isFullError (IOError _ ResourceExhausted _) = True -isFullError _ = False +isFullError :: IOError -> Bool +isFullError (IOError _ ResourceExhausted _ _) = True +isFullError _ = False -isEOFError (IOError _ EOF _) = True -isEOFError _ = True +isEOFError :: IOError -> Bool +isEOFError (IOError _ EOF _ _) = True +isEOFError _ = False -isIllegalOperation (IOError _ IllegalOperation _) = True -isIllegalOperation _ = False +isIllegalOperation :: IOError -> Bool +isIllegalOperation (IOError _ IllegalOperation _ _) = True +isIllegalOperation _ = False -isPermissionError (IOError _ PermissionDenied _) = True -isPermissionError _ = False +isPermissionError :: IOError -> Bool +isPermissionError (IOError _ PermissionDenied _ _) = True +isPermissionError _ = False -isDoesNotExistError (IOError _ NoSuchThing _) = True -isDoesNotExistError _ = False +isDoesNotExistError :: IOError -> Bool +isDoesNotExistError (IOError _ NoSuchThing _ _) = True +isDoesNotExistError _ = False -isUserError (IOError _ UserError _) = True -isUserError _ = 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 _ 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}) + 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 @@ -220,12 +276,12 @@ used. constructErrorAndFail :: String -> IO a constructErrorAndFail call_site = constructError call_site >>= \ io_error -> - fail io_error + ioError io_error constructErrorAndFailWithInfo :: String -> String -> IO a constructErrorAndFailWithInfo call_site reason = constructErrorMsg call_site (Just reason) >>= \ io_error -> - fail io_error + ioError io_error \end{code} @@ -239,7 +295,8 @@ 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. +information. Error constructing functions will then reach out +and grab these values when generating \begin{code} constructError :: String -> IO IOError @@ -247,41 +304,48 @@ constructError call_site = constructErrorMsg call_site Nothing constructErrorMsg :: String -> Maybe String -> IO IOError constructErrorMsg call_site reason = - _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) -> - _casm_ ``%r = ghc_errstr;'' >>= \ str -> + getErrType__ >>= \ errtype -> + getErrStr__ >>= \ 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 + 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 = - call_site ++ ':' : ' ' : unpackCString str ++ + unpackCString str ++ (case iot of - OtherError -> "(error code: " ++ show (I# errtype#) ++ ")" + OtherError -> "(error code: " ++ show errtype ++ ")" _ -> "") ++ (case reason of Nothing -> "" Just m -> ' ':m) in - return (IOError Nothing iot msg) + 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} %********************************************************* @@ -296,19 +360,36 @@ a handles reside in @IOHandle@. \begin{code} +#ifndef __HUGS__ {- 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 + compiling in a concurrent way). Break the cycle by having the definition of MVars go here: -} -data MVar a = MVar (SynchVar# RealWorld a) +data MVar a = MVar (MVar# RealWorld a) + +-- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module +instance Eq (MVar a) where + (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# {- Double sigh - ForeignObj is needed here too to break a cycle. -} data ForeignObj = ForeignObj ForeignObj# -- another one +instance CCallable ForeignObj + +eqForeignObj :: ForeignObj -> ForeignObj -> Bool +eqForeignObj mp1 mp2 + = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int) + +foreign import "eqForeignObj" unsafe primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int + +instance Eq ForeignObj where + p == q = eqForeignObj p q + p /= q = not (eqForeignObj p q) +#endif /* ndef __HUGS__ */ #if defined(__CONCURRENT_HASKELL__) newtype Handle = Handle (MVar Handle__) @@ -316,26 +397,112 @@ newtype Handle = Handle (MVar Handle__) newtype Handle = Handle (MutableVar RealWorld Handle__) #endif +instance Eq Handle where + (Handle h1) == (Handle h2) = h1 == h2 + +{- + A Handle is represented by (a reference to) a record + containing the state of the I/O port/device. We record + the following pieces of info: + + * type (read,write,closed etc.) + * pointer to the external file object. + * buffering mode + * user-friendly name (usually the + 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. +-} 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 + = Handle__ { + haFO__ :: FILE_OBJECT, + haType__ :: Handle__Type, + haBufferMode__ :: BufferMode, + haFilePath__ :: FilePath + } + +{- + Internally, we classify handles as being one + of the following: +-} +data Handle__Type + = ErrorHandle IOError + | ClosedHandle + | SemiClosedHandle + | ReadHandle + | WriteHandle + | AppendHandle + | ReadWriteHandle + + +-- handle types are 'show'ed when printing error msgs, so +-- we provide a more user-friendly Show instance for it +-- than the derived one. +instance Show Handle__Type where + showsPrec p t = + case t of + ErrorHandle iot -> showString "error " . showsPrec p iot + ClosedHandle -> showString "closed" + SemiClosedHandle -> showString "semi-closed" + ReadHandle -> showString "readable" + WriteHandle -> showString "writeable" + AppendHandle -> showString "writeable (append)" + ReadWriteHandle -> showString "read-writeable" + +instance Show Handle where + showsPrec p (Handle h) = + let +#if defined(__CONCURRENT_HASKELL__) +#ifdef __HUGS__ + hdl_ = unsafePerformIO (primTakeMVar h) #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 + -- (Big) SIGH: unfolded defn of takeMVar to avoid + -- an (oh-so) unfortunate module loop with PrelConc. + hdl_ = unsafePerformIO (IO $ \ s# -> + case h of { MVar h# -> + case takeMVar# h# s# of { (# s2# , r #) -> + (# s2#, r #) }}) #endif - --- Standard Instances as defined by the Report.. --- instance Eq Handle (defined in IO) --- instance Show Handle "" +#else + hdl_ = unsafePerformIO (stToIO (readVar h)) +#endif + in + showChar '{' . + showHdl (haType__ hdl_) + (showString "loc=" . showString (haFilePath__ hdl_) . showChar ',' . + showString "type=" . showsPrec p (haType__ hdl_) . showChar ',' . + showString "buffering=" . showBufMode (haFO__ hdl_) (haBufferMode__ hdl_) . showString "}\n" ) + where + showHdl :: Handle__Type -> ShowS -> ShowS + showHdl ht cont = + case ht of + ClosedHandle -> showsPrec p ht . showString "}\n" + ErrorHandle _ -> showsPrec p ht . showString "}\n" + _ -> cont + + showBufMode :: FILE_OBJECT -> BufferMode -> ShowS + showBufMode fo bmo = + case bmo of + NoBuffering -> showString "none" + LineBuffering -> showString "line" + BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n) + BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def) + 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} @@ -378,8 +545,10 @@ available. 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. +and terminals will normally be line-buffered. (the IO interface provides +operations for changing the default buffering of a handle tho.) \begin{code} data BufferMode @@ -389,41 +558,18 @@ data BufferMode \end{code} -\begin{code} -performGC :: IO () -performGC = _ccall_GC_ StgPerformGarbageCollection -\end{code} - -%********************************************************* -%* * -\subsection{Unsafe @IO@ operations} -%* * -%********************************************************* +Foreign import declarations to helper routines: \begin{code} -{-# NOINLINE unsafePerformIO #-} -unsafePerformIO :: IO a -> a -unsafePerformIO (IO m) - = case m realWorld# of - IOok _ r -> r - IOfail _ e -> error ("unsafePerformIO: I/O error: " ++ show e ++ "\n") +foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO Addr +foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int +foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int + +foreign import "libHS_cbits" "allocMemory__" unsafe + allocMemory__ :: Int -> IO Addr +foreign import "libHS_cbits" "getBufSize" unsafe + getBufSize :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "setBuf" unsafe + setBuf :: FILE_OBJECT -> Addr -> Int -> IO () -{-# NOINLINE unsafeInterleaveIO #-} -unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO (IO m) = IO ( \ s -> - let - IOok _ r = m s - in - IOok s r) - -{-# NOINLINE trace #-} -trace :: String -> a -> a -trace string expr - = unsafePerformIO ( - ((_ccall_ PreTraceHook sTDERR{-msg-}):: IO ()) >> - fputs sTDERR string >> - ((_ccall_ PostTraceHook sTDERR{-msg-}):: IO ()) >> - return expr ) - where - sTDERR = (``stderr'' :: Addr) \end{code}