[project @ 1997-10-21 20:36:50 by sof]

[ghc-hetmet.git] / ghc / lib / ghc / IOBase.lhs

diff --git a/ghc/lib/ghc/IOBase.lhs b/ghc/lib/ghc/IOBase.lhs
index 8214bd3..9121dfc 100644 (file)
--- 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}
 concretely; the @IO@ module itself exports abstractly.
 
 \begin{code}

-#include "error.h"
-

 {-# OPTIONS -fno-implicit-prelude #-}
 {-# OPTIONS -fno-implicit-prelude #-}

+#include "error.h"

 
 module IOBase where
 
 import STBase
 
 module IOBase where
 
 import STBase

+import UnsafeST

 import PrelTup
 import Foreign
 import PrelTup
 import Foreign

-import PackedString    ( unpackCString )
+import PackBase        ( unpackCString )

 import PrelBase
 import PrelBase

+import ArrBase ( ByteArray(..), MutableVar(..) )
+import PrelRead
+

 import GHC
 
 import GHC
 

-infixr 1 `thenIO_Prim`
+infixr 1 `thenIO_Prim`, `seqIO_Prim`

 \end{code}
 
 %*********************************************************
 \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}
 \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
 
 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 (>>=)  #-}
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}

--}

     m >> k      =  m >>= \ _ -> k
     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 :: (a -> IO a) -> IO a
     -- not required but worth having around
 

-fixIO k = IO $ ST $ \ s ->
+fixIO k = IO $ \ s ->

     let
     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 
     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       :: String  -> IOError

-userError str  =  UserError str
+userError str  =  IOError Nothing UserError str

 
 catch           :: IO a    -> (IOError -> IO a) -> IO a 
 
 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 "<<IO action>>"
 
 instance  Show (IO a)  where
     showsPrec p f  = showString "<<IO action>>"

@@ -99,28 +106,26 @@ ioToPrimIO :: IO a -> PrimIO       a
 primIOToIO = stToIO -- for backwards compatibility
 ioToPrimIO = ioToST
 
 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
 \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 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}
 
 
 \end{code}
 
 

@@ -139,6 +144,8 @@ errorIO (ST io)
   where
     bottom = bottom -- Never evaluated
 
   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
 -- 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}
 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}
 \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
   | 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}
 
 \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}
 
 
 \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
 \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
 
 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.
 
 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
 
 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}
 
 \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}