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}
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 ->
%*********************************************************
%* *
-\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@}
%* *
%*********************************************************
(Maybe Handle) -- the handle used by the action flagging the
-- the error.
IOErrorType -- what it was.
+ String -- location
String -- error type specific information.
| 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}
\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}
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
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
_ -> OtherError
msg =
- call_site ++ ':' : ' ' : unpackCString str ++
+ unpackCString str ++
(case iot of
OtherError -> "(error code: " ++ show (I# errtype#) ++ ")"
_ -> "") ++
Nothing -> ""
Just m -> ' ':m)
in
- return (IOError Nothing iot msg)
+ return (IOError Nothing iot call_site msg)
\end{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
+ compiling in a concurrent way). Break the cycle by having
the definition of MVars go here:
-}
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__)
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}
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
\end{code}
-\begin{code}
-performGC :: IO ()
-performGC = _ccall_GC_ StgPerformGarbageCollection
-\end{code}
-
%*********************************************************
%* *
\subsection{Unsafe @IO@ operations}
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}
projects / ghc-hetmet.git / commitdiff