[project @ 2001-03-27 14:05:09 by simonpj]

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

diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs
index 1efaee6..8e1971f 100644 (file)
--- a/ghc/lib/std/PrelIOBase.lhs
+++ b/ghc/lib/std/PrelIOBase.lhs
@@ -1,5 +1,5 @@
 % ------------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.31 2001/01/11 07:04:16 qrczak Exp $
+% $Id: PrelIOBase.lhs,v 1.37 2001/02/27 13:38:58 simonmar Exp $
 % 
 % (c) The University of Glasgow, 1994-2000
 %
@@ -21,12 +21,12 @@ import {-# SOURCE #-} PrelErr ( error )
 
 import PrelST
 import PrelBase
-import PrelNum   ( fromInteger )       -- Integer literals
+import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude
 import PrelMaybe  ( Maybe(..) )
-import PrelAddr          ( Addr(..), nullAddr )
 import PrelShow
 import PrelList
 import PrelDynamic
+import PrelPtr
 import PrelPack ( unpackCString )
 
 #if !defined(__CONCURRENT_HASKELL__)
@@ -41,9 +41,10 @@ import PrelArr         ( MutableVar, readVar )
 #endif
 
 #ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT        ForeignObj
+#define FILE_OBJECT        (ForeignPtr ())
 #else
-#define FILE_OBJECT        Addr
+#define FILE_OBJECT        (Ptr ())
+
 #endif
 \end{code}
 
@@ -92,7 +93,10 @@ instance  Monad IO  where
     return x   = returnIO x
 
     m >>= k     = bindIO m k
-    fail s     = ioError (userError s)
+    fail s     = failIO s
+
+failIO :: String -> IO a
+failIO s = ioError (userError s)
 
 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
@@ -118,8 +122,9 @@ returnIO x = IO (\ s -> (# s, x #))
 #ifdef __HUGS__
 /* Hugs doesn't distinguish these types so no coercion required) */
 #else
+-- stToIO     :: (forall s. ST s a) -> IO a
 stToIO       :: ST RealWorld a -> IO a
-stToIO (ST m) = (IO m)
+stToIO (ST m) = IO m
 
 ioToST       :: IO a -> ST RealWorld a
 ioToST (IO m) = (ST m)
@@ -138,8 +143,13 @@ ioToST (IO m) = (ST m)
 unsafePerformIO        :: IO a -> a
 unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 
+{-# NOINLINE unsafeInterleaveIO #-}
 unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST
+unsafeInterleaveIO (IO m)
+  = IO ( \ s -> let
+                  r = case m s of (# _, res #) -> res
+               in
+               (# s, r #))
 #endif
 \end{code}
 
@@ -170,20 +180,21 @@ instance Eq (MVar a) where
        (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
 
 {-
-  Double sigh - ForeignObj is needed here too to break a cycle.
+  Double sigh - ForeignPtr is needed here too to break a cycle.
 -}
-data ForeignObj = ForeignObj ForeignObj#   -- another one
-instance CCallable ForeignObj
+data ForeignPtr a = ForeignPtr ForeignObj#
+instance CCallable (ForeignPtr a)
 
-eqForeignObj :: ForeignObj  -> ForeignObj -> Bool
-eqForeignObj mp1 mp2
-  = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int)
+eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool
+eqForeignPtr mp1 mp2
+  = unsafePerformIO (primEqForeignPtr mp1 mp2) /= (0::Int)
 
-foreign import "eqForeignObj" unsafe primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int
+foreign import "eqForeignObj" unsafe 
+  primEqForeignPtr :: ForeignPtr a -> ForeignPtr a -> IO Int
 
-instance Eq ForeignObj where 
-    p == q = eqForeignObj p q
-    p /= q = not (eqForeignObj p q)
+instance Eq (ForeignPtr a) where 
+    p == q = eqForeignPtr p q
+    p /= q = not (eqForeignPtr p q)
 #endif /* ndef __HUGS__ */
 
 #if defined(__CONCURRENT_HASKELL__)
@@ -215,7 +226,7 @@ data Handle__
       haType__        :: Handle__Type,
       haBufferMode__  :: BufferMode,
       haFilePath__    :: FilePath,
-      haBuffers__     :: [Addr]
+      haBuffers__     :: [Ptr ()]
     }
 
 {-
@@ -267,9 +278,10 @@ instance Show Handle where
      -- (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 { (# s2# , r #) -> 
-                   (# s2#, r #) }})
+            case h                 of { MVar h# ->
+            case takeMVar# h# s#   of { (# s2# , r #) -> 
+            case putMVar# h# r s2# of { s3# ->
+            (# s3#, r #) }}})
 #endif
 #else
      hdl_ = unsafePerformIO (stToIO (readVar h))
@@ -354,24 +366,25 @@ data BufferMode
 Foreign import declarations to helper routines:
 
 \begin{code}
-foreign import "libHS_cbits" "getErrStr__"  unsafe getErrStr__  :: IO Addr 
+foreign import "libHS_cbits" "getErrStr__"  unsafe getErrStr__  :: IO (Ptr ())
 foreign import "libHS_cbits" "getErrNo__"   unsafe getErrNo__   :: IO Int  
 foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int  
   
-malloc :: Int -> IO Addr
+-- ToDo: use mallocBytes from PrelMarshal?
+malloc :: Int -> IO (Ptr ())
 malloc sz = do
   a <- _malloc sz
-  if (a == nullAddr)
+  if (a == nullPtr)
        then ioException (IOError Nothing ResourceExhausted
            "malloc" "out of memory" Nothing)
        else return a
 
-foreign import "malloc" unsafe _malloc :: Int -> IO Addr
+foreign import "malloc" unsafe _malloc :: Int -> IO (Ptr ())
 
 foreign import "libHS_cbits" "getBufSize"  unsafe
            getBufSize       :: FILE_OBJECT -> IO Int
 foreign import "libHS_cbits" "setBuf" unsafe
-           setBuf       :: FILE_OBJECT -> Addr -> Int -> IO ()
+           setBuf       :: FILE_OBJECT -> Ptr () -> Int -> IO ()
 
 \end{code}
 
@@ -395,7 +408,6 @@ data Exception
   | AssertionFailed    String          -- Assertions
   | DynException       Dynamic         -- Dynamic exceptions
   | AsyncException     AsyncException  -- Externally generated errors
-  | PutFullMVar                        -- Put on a full MVar
   | BlockedOnDeadMVar                  -- Blocking on a dead MVar
   | NonTermination
   | UserError          String
@@ -458,7 +470,6 @@ instance Show Exception where
   showsPrec _ (AssertionFailed err)      = showString err
   showsPrec _ (DynException _err)        = showString "unknown exception"
   showsPrec _ (AsyncException e)        = shows e
-  showsPrec _ (PutFullMVar)             = showString "putMVar: full MVar"
   showsPrec _ (BlockedOnDeadMVar)       = showString "thread blocked indefinitely"
   showsPrec _ (NonTermination)           = showString "<<loop>>"
   showsPrec _ (UserError err)            = showString err