Commit aa692a56 authored by sof's avatar sof
Browse files

[project @ 1998-08-14 12:49:51 by sof]

New Handle repr;better IOErrors;moved trace+performGC to IOExts;removed fputs(yes!)
parent 5dced800
......@@ -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 ->
......@@ -106,25 +104,6 @@ ioToST (IO io) = ST $ \ s ->
IOfail new_s e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
\end{code}
%*********************************************************
%* *
\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}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment