[project @ 2000-04-14 09:54:12 by simonmar]

[ghc-hetmet.git] / ghc / lib / std / PrelIOBase.lhs

diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs
index 2e43613..e83ddd5 100644 (file)
--- a/ghc/lib/std/PrelIOBase.lhs
+++ b/ghc/lib/std/PrelIOBase.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
 % -----------------------------------------------------------------------------

-% $Id: PrelIOBase.lhs,v 1.12 1999/08/23 12:53:25 keithw Exp $
+% $Id: PrelIOBase.lhs,v 1.22 2000/04/12 17:33:16 simonmar Exp $

 % 
 % (c) The AQUA Project, Glasgow University, 1994-1998
 %
 % 
 % (c) The AQUA Project, Glasgow University, 1994-1998
 %

@@ -10,8 +10,9 @@ 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}

-{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#include "cbits/error.h"
+{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude -#include "cbits/stgio.h" #-}
+#include "cbits/stgerror.h"
+#include "config.h"

 
 #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
 module PrelIOBase where
 
 #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
 module PrelIOBase where

@@ -21,10 +22,9 @@ import {-# SOURCE #-} PrelErr ( error )
 import PrelST
 import PrelBase
 import {-# SOURCE #-} PrelException ( ioError )
 import PrelST
 import PrelBase
 import {-# SOURCE #-} PrelException ( ioError )

-import PrelST    ( ST(..), STret(..) )

 import PrelMaybe  ( Maybe(..) )
 import PrelAddr          ( Addr(..), nullAddr )
 import PrelMaybe  ( Maybe(..) )
 import PrelAddr          ( Addr(..), nullAddr )

-import PrelPack   ( unpackCString )
+import PrelPack ( unpackCString )

 import PrelShow
 
 #if !defined(__CONCURRENT_HASKELL__)
 import PrelShow
 
 #if !defined(__CONCURRENT_HASKELL__)

@@ -33,14 +33,9 @@ import PrelArr         ( MutableVar, readVar )
 #endif
 
 #ifdef __HUGS__
 #endif
 
 #ifdef __HUGS__

-#define cat2(x,y)  x/**/y
-#define CCALL(fun) cat2(prim_,fun)

 #define __CONCURRENT_HASKELL__
 #define stToIO id
 #define unpackCString primUnpackString
 #define __CONCURRENT_HASKELL__
 #define stToIO id
 #define unpackCString primUnpackString

-#else
-#define CCALL(fun) _ccall_ fun
-#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)

 #endif
 
 #ifndef __PARALLEL_HASKELL__
 #endif
 
 #ifndef __PARALLEL_HASKELL__

@@ -60,6 +55,23 @@ 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.
 
 the real world.  We use the exception mechanism (in PrelException) to
 implement IO exceptions.
 

+NOTE: The IO representation is deeply wired in to various parts of the
+system.  The following list may or may not be exhaustive:
+
+Compiler  - types of various primitives in PrimOp.lhs
+
+RTS      - forceIO (StgMiscClosures.hc)
+         - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast 
+           (Exceptions.hc)
+         - raiseAsync (Schedule.c)
+
+Prelude   - PrelIOBase.lhs, and several other places including
+           PrelException.lhs.
+
+Libraries - parts of hslibs/lang.
+
+--SDM
+

 \begin{code}
 #ifndef __HUGS__
 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
 \begin{code}
 #ifndef __HUGS__
 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))

@@ -75,15 +87,11 @@ instance  Monad IO  where
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
     m >> k      =  m >>= \ _ -> k
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
     m >> k      =  m >>= \ _ -> k

-    return x   = IO $ \ s -> (# s, x #)
+    return x   = returnIO x

 
     m >>= k     = bindIO m k
     fail s     = error s -- not ioError?
 
 
     m >>= k     = bindIO m k
     fail s     = error s -- not ioError?
 

-    -- not required but worth having around
-fixIO          :: (a -> IO a) -> IO a
-fixIO m         = stToIO (fixST (ioToST . m))
-

 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
 
 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
 

@@ -93,6 +101,8 @@ bindIO (IO m) k = IO ( \ s ->
     (# new_s, a #) -> unIO (k a) new_s
   )
 
     (# new_s, a #) -> unIO (k a) new_s
   )
 

+returnIO :: a -> IO a
+returnIO x = IO (\ s -> (# s, x #))

 #endif
 \end{code}
 
 #endif
 \end{code}
 

@@ -151,6 +161,9 @@ data IOError
      String         -- location
      String          -- error type specific information.
 
      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
 
 data IOErrorType
   = AlreadyExists        | HardwareFault

@@ -163,7 +176,7 @@ data IOErrorType
   | TimeExpired          | UnsatisfiedConstraints
   | UnsupportedOperation | UserError
   | EOF
   | TimeExpired          | UnsatisfiedConstraints
   | UnsupportedOperation | UserError
   | EOF

-#ifdef _WIN32
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)

   | ComError Int           -- HRESULT
 #endif
   deriving (Eq)
   | ComError Int           -- HRESULT
 #endif
   deriving (Eq)

@@ -191,7 +204,7 @@ instance Show IOErrorType where
       UserError         -> "failed"
       UnsupportedOperation -> "unsupported operation"
       EOF              -> "end of file"
       UserError         -> "failed"
       UnsupportedOperation -> "unsupported operation"
       EOF              -> "end of file"

-#ifdef _WIN32
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)

       ComError _       -> "COM error"
 #endif
 
       ComError _       -> "COM error"
 #endif
 

@@ -306,8 +319,8 @@ constructError call_site = constructErrorMsg call_site Nothing
 
 constructErrorMsg            :: String -> Maybe String -> IO IOError
 constructErrorMsg call_site reason =
 
 constructErrorMsg            :: String -> Maybe String -> IO IOError
 constructErrorMsg call_site reason =

- CCALL(getErrType__)            >>= \ errtype ->
- CCALL(getErrStr__)             >>= \ str ->
+ getErrType__            >>= \ errtype ->
+ getErrStr__             >>= \ str ->

  let
   iot =
    case (errtype::Int) of
  let
   iot =
    case (errtype::Int) of

@@ -372,12 +385,25 @@ a handles reside in @IOHandle@.
 -}
 data MVar a = MVar (MVar# 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
 {-
   Double sigh - ForeignObj is needed here too to break a cycle.
 -}
 data ForeignObj = ForeignObj ForeignObj#   -- another one
 instance CCallable ForeignObj

-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__)
 #endif /* ndef __HUGS__ */
 
 #if defined(__CONCURRENT_HASKELL__)

@@ -386,6 +412,9 @@ newtype Handle = Handle (MVar Handle__)
 newtype Handle = Handle (MutableVar RealWorld Handle__)
 #endif
 
 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
 {-
   A Handle is represented by (a reference to) a record 
   containing the state of the I/O port/device. We record

@@ -405,8 +434,9 @@ data Handle__
       haFO__         :: FILE_OBJECT,
       haType__        :: Handle__Type,
       haBufferMode__  :: BufferMode,
       haFO__         :: FILE_OBJECT,
       haType__        :: Handle__Type,
       haBufferMode__  :: BufferMode,

-      haFilePath__    :: FilePath
-    }      
+      haFilePath__    :: FilePath,
+      haBuffers__     :: [Addr]
+    }

 
 {-
   Internally, we classify handles as being one
 
 {-
   Internally, we classify handles as being one

@@ -476,7 +506,7 @@ instance Show Handle where
        BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
       where
        def :: Int 
        BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
       where
        def :: Int 

-       def = unsafePerformIO (CCALL(getBufSize) fo)
+       def = unsafePerformIO (getBufSize fo)

 
 mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
 mkBuffer__ fo sz_in_bytes = do
 
 mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
 mkBuffer__ fo sz_in_bytes = do

@@ -484,11 +514,11 @@ mkBuffer__ fo sz_in_bytes = do
   case sz_in_bytes of
     0 -> return nullAddr  -- this has the effect of overwriting the pointer to the old buffer.
     _ -> do
   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
+     chunk <- allocMemory__ sz_in_bytes

      if chunk == nullAddr
       then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
       else return chunk
      if chunk == nullAddr
       then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
       else return chunk

- CCALL(setBuf) fo chunk sz_in_bytes
+ setBuf fo chunk sz_in_bytes

 
 \end{code}
 
 
 \end{code}
 

@@ -543,3 +573,19 @@ data BufferMode
    {- Read instance defined in IO. -}
 
 \end{code}
    {- Read instance defined in IO. -}
 
 \end{code}

+
+Foreign import declarations to helper routines:
+
+\begin{code}
+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 ()
+
+\end{code}