From: sof Date: Fri, 14 Aug 1998 12:49:51 +0000 (+0000) Subject: [project @ 1998-08-14 12:49:51 by sof] X-Git-Tag: Approx_2487_patches~376 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=aa692a56fa6544bb31bce9471ff75add0985734a;p=ghc-hetmet.git [project @ 1998-08-14 12:49:51 by sof] New Handle repr;better IOErrors;moved trace+performGC to IOExts;removed fputs(yes!) --- diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 93b26d6..fe13769 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -8,20 +8,18 @@ Definitions for the @IO@ monad and its friends. Everything is exported concretely; the @IO@ module itself exports abstractly. \begin{code} -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} #include "error.h" 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 PrelST ( ST(..), STret(..), StateAndPtr#(..) ) +import PrelMaybe ( Maybe(..) ) +import PrelAddr ( Addr(..), nullAddr ) +import PrelPack ( unpackCString ) +import PrelArr ( MutableVar, readVar ) \end{code} @@ -76,7 +74,7 @@ fail :: IOError -> IO a fail err = IO $ \ s -> IOfail s err userError :: String -> IOError -userError str = IOError Nothing UserError str +userError str = IOError Nothing (UserError Nothing) "" str catch :: IO a -> (IOError -> IO a) -> IO a catch (IO m) k = IO $ \ s -> @@ -108,25 +106,6 @@ ioToST (IO io) = ST $ \ s -> %********************************************************* %* * -\subsection{Utility functions} -%* * -%********************************************************* - -I'm not sure why this little function is here... - -\begin{code} -fputs :: Addr{-FILE*-} -> String -> IO Bool - -fputs stream [] = return True - -fputs stream (c : cs) - = _ccall_ stg_putc c stream >> -- stg_putc expands to putc - fputs stream cs -- (just does some casting stream) -\end{code} - - -%********************************************************* -%* * \subsection{Type @IOError@} %* * %********************************************************* @@ -142,6 +121,7 @@ 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. @@ -154,9 +134,32 @@ data IOErrorType | ResourceBusy | ResourceExhausted | ResourceVanished | SystemError | TimeExpired | UnsatisfiedConstraints - | UnsupportedOperation | UserError + | UnsupportedOperation | UserError (Maybe Addr) | EOF - deriving (Eq, Show) + deriving (Eq) + +instance Show IOErrorType where + showsPrec d 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" + EOF -> "end of file" \end{code} @@ -164,48 +167,51 @@ Predicates on IOError; little effort made on these so far... \begin{code} -isAlreadyExistsError (IOError _ AlreadyExists _) = True -isAlreadyExistsError _ = False +isAlreadyExistsError (IOError _ AlreadyExists _ _) = True +isAlreadyExistsError _ = False -isAlreadyInUseError (IOError _ ResourceBusy _) = True -isAlreadyInUseError _ = False +isAlreadyInUseError (IOError _ ResourceBusy _ _) = True +isAlreadyInUseError _ = False -isFullError (IOError _ ResourceExhausted _) = True -isFullError _ = False +isFullError (IOError _ ResourceExhausted _ _) = True +isFullError _ = False -isEOFError (IOError _ EOF _) = True -isEOFError _ = True +isEOFError (IOError _ EOF _ _) = True +isEOFError _ = False -isIllegalOperation (IOError _ IllegalOperation _) = True -isIllegalOperation _ = False +isIllegalOperation (IOError _ IllegalOperation _ _) = True +isIllegalOperation _ = False -isPermissionError (IOError _ PermissionDenied _) = True -isPermissionError _ = False +isPermissionError (IOError _ PermissionDenied _ _) = True +isPermissionError _ = False -isDoesNotExistError (IOError _ NoSuchThing _) = True -isDoesNotExistError _ = False +isDoesNotExistError (IOError _ NoSuchThing _ _) = True +isDoesNotExistError _ = False -isUserError (IOError _ UserError _) = True -isUserError _ = False +isUserError (IOError _ (UserError _) _ _) = True +isUserError _ = False \end{code} Showing @IOError@s \begin{code} 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) = + 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 + \end{code} @@ -239,7 +245,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,8 +254,8 @@ 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 -> + _ccall_ getErrType__ >>= \ (I# errtype#) -> + _ccall_ getErrStr__ >>= \ str -> let iot = case errtype# of @@ -273,7 +280,7 @@ constructErrorMsg call_site reason = _ -> OtherError msg = - call_site ++ ':' : ' ' : unpackCString str ++ + unpackCString str ++ (case iot of OtherError -> "(error code: " ++ show (I# errtype#) ++ ")" _ -> "") ++ @@ -281,7 +288,7 @@ constructErrorMsg call_site reason = Nothing -> "" Just m -> ' ':m) in - return (IOError Nothing iot msg) + return (IOError Nothing iot call_site msg) \end{code} %********************************************************* @@ -299,7 +306,7 @@ a handles reside in @IOHandle@. {- 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: -} @@ -309,6 +316,16 @@ data MVar a = MVar (SynchVar# RealWorld a) Double sigh - ForeignObj is needed here too to break a cycle. -} data ForeignObj = ForeignObj ForeignObj# -- another one +instance CCallable ForeignObj +instance CCallable ForeignObj# + +makeForeignObj :: Addr -> Addr -> IO ForeignObj +makeForeignObj (A# obj) (A# finaliser) = IO ( \ s# -> + case makeForeignObj# obj finaliser s# of + StateAndForeignObj# s1# fo# -> IOok s1# (ForeignObj fo#)) + +data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj# + #if defined(__CONCURRENT_HASKELL__) newtype Handle = Handle (MVar Handle__) @@ -316,26 +333,151 @@ newtype Handle = Handle (MVar Handle__) newtype Handle = Handle (MutableVar RealWorld Handle__) #endif +#ifndef __PARALLEL_HASKELL__ +#define FILE_OBJECT ForeignObj +#else +#define FILE_OBJECT Addr +#endif + +{- + 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. + +This means that the finaliser for the handle needs to have access to +the buffer and the OS file handle. The current implementation of foreign +objects requires that the finaliser is implemented in C, so to +arrange for this to happen, openFile() returns a pointer to a structure +big enough to hold the OS file handle and a pointer to the buffer. +This pointer is then wrapped up inside a ForeignObj, and finalised +as desired. + +-} data Handle__ - = ErrorHandle IOError - | ClosedHandle + = Handle__ { + haFO__ :: FILE_OBJECT, + haType__ :: Handle__Type, + haBufferMode__ :: BufferMode, + haFilePath__ :: String + } + +{- + 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__) + -- (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 { StateAndPtr# s2# r -> + IOok s2# r }}) +#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 (_ccall_ getBufSize fo) + + +{- + nullFile__ is only used for closed handles, plugging it in as + a null file object reference. +-} +nullFile__ :: FILE_OBJECT +nullFile__ = #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 + unsafePerformIO (makeForeignObj nullAddr nullAddr{-i.e., don't finalise-}) #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 + nullAddr #endif --- Standard Instances as defined by the Report.. --- instance Eq Handle (defined in IO) --- instance Show Handle "" + +mkClosedHandle__ :: Handle__ +mkClosedHandle__ = + Handle__ + nullFile__ + ClosedHandle + NoBuffering + "closed file" + +mkErrorHandle__ :: IOError -> Handle__ +mkErrorHandle__ ioe = + Handle__ + nullFile__ + (ErrorHandle ioe) + NoBuffering + "error handle" + +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 <- _ccall_ allocMemory__ sz_in_bytes + if chunk == nullAddr + then fail (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory") + else return chunk + _ccall_ setBuf fo chunk sz_in_bytes \end{code} @@ -378,8 +520,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,11 +533,6 @@ data BufferMode \end{code} -\begin{code} -performGC :: IO () -performGC = _ccall_GC_ StgPerformGarbageCollection -\end{code} - %********************************************************* %* * \subsection{Unsafe @IO@ operations} @@ -416,14 +555,4 @@ unsafeInterleaveIO (IO m) = IO ( \ 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}