X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Flib%2Fghc%2FIOBase.lhs;h=39fe2542c3bb939ba34011c89bd98f4baf9525c0;hb=bedf494ff399f2096221b8f1e8ead5849f0f9bce;hp=47015c375f792d469c7db7499164155af67c598d;hpb=5fe86713e62002bf594fd051c97bc239bd4b9987;p=ghc-hetmet.git

diff --git a/ghc/lib/ghc/IOBase.lhs b/ghc/lib/ghc/IOBase.lhs
index 47015c3..39fe254 100644
--- a/ghc/lib/ghc/IOBase.lhs
+++ b/ghc/lib/ghc/IOBase.lhs
@@ -13,18 +13,17 @@ concretely; the @IO@ module itself exports abstractly.
 
 module IOBase where
 
+import {-# SOURCE #-} Error
 import STBase
-import UnsafeST
 import PrelTup
-import Foreign
+import PrelMaybe
+import Addr
 import PackBase	( unpackCString )
 import PrelBase
 import ArrBase	( ByteArray(..), MutableVar(..) )
-import PrelRead
 
 import GHC
 
-infixr 1 `thenIO_Prim`, `seqIO_Prim`
 \end{code}
 
 %*********************************************************
@@ -33,8 +32,19 @@ infixr 1 `thenIO_Prim`, `seqIO_Prim`
 %*							*
 %*********************************************************
 
+IO is no longer built on top of PrimIO (which used to be 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}
-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)
@@ -44,40 +54,36 @@ instance  Monad IO  where
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
     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 k = IO $ ST $ \ s ->
+fixIO k = IO $ \ s ->
     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 
-fail err	=  IO $ ST $ \ s -> (Left err, s)
+fail err	=  IO $ \ s -> IOfail s err
 
 userError       :: String  -> IOError
 userError str	=  IOError Nothing UserError str
 
 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>>"
@@ -86,114 +92,22 @@ instance  Show (IO a)  where
 
 %*********************************************************
 %*							*
-\subsection{Coercions to @ST@ and @PrimIO@}
+\subsection{Coercions to @ST@}
 %*							*
 %*********************************************************
 
 \begin{code}
 stToIO	   :: ST RealWorld a -> IO a
-primIOToIO :: PrimIO a       -> IO a
 ioToST	   :: IO a -> ST RealWorld a
-ioToPrimIO :: IO a -> PrimIO       a
-
-primIOToIO = stToIO -- for backwards compatibility
-ioToPrimIO = ioToST
-
-stToIO (ST m) = IO $ ST $ \ s ->
-    case (m s) of { (r, new_s) ->
-    (Right r, new_s) }
-
-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")
-    }
-\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 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 }}
+stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r
 
-seqIO_Prim m k = thenIO_Prim m (\ _ -> k)
+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}
 
-
-%*********************************************************
-%*							*
-\subsection{Error/trace-ish functions}
-%*							*
-%*********************************************************
-
-\begin{code}
-errorIO :: PrimIO () -> a
-
-errorIO (ST io)
-  = case (errorIO# io) of
-      _ -> bottom
-  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__ :: (Addr{-FILE *-} -> PrimIO ()) -> String -> a
-
-error__ msg_hdr s
-#ifdef __PARALLEL_HASKELL__
-  = errorIO (msg_hdr sTDERR{-msg hdr-}	>>
-	     _ccall_ fflush sTDERR	>>
-	     fputs sTDERR s		>>
-	     _ccall_ fflush sTDERR	>>
-	     _ccall_ stg_exit (1::Int)
-	    )
-#else
-  = errorIO (msg_hdr sTDERR{-msg hdr-}	>>
-	     _ccall_ fflush sTDERR	>>
-	     fputs sTDERR s		>>
-	     _ccall_ fflush sTDERR	>>
-	     _ccall_ getErrorHandler	>>= \ errorHandler ->
-	     if errorHandler == (-1::Int) then
-		_ccall_ stg_exit (1::Int)
-	     else
-		_casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
-						>>= \ osptr ->
-		_ccall_ decrementErrorCount     >>= \ () ->
-		deRefStablePtr osptr            >>= \ oact ->
-		oact
-	    )
-#endif {- !parallel -}
-  where
-    sTDERR = (``stderr'' :: Addr)
-\end{code}
-
-\begin{code}
-{-# GENERATE_SPECS _trace a #-}
-trace :: String -> a -> a
-
-trace string expr
-  = unsafePerformPrimIO (
-	((_ccall_ PreTraceHook sTDERR{-msg-}):: PrimIO ())  >>
-	fputs sTDERR string				    >>
-	((_ccall_ PostTraceHook sTDERR{-msg-}):: PrimIO ()) >>
-	returnPrimIO expr )
-  where
-    sTDERR = (``stderr'' :: Addr)
-\end{code}
-
-
 %*********************************************************
 %*							*
 \subsection{Utility functions}
@@ -203,7 +117,7 @@ trace string expr
 I'm not sure why this little function is here...
 
 \begin{code}
-fputs :: Addr{-FILE*-} -> String -> PrimIO Bool
+fputs :: Addr{-FILE*-} -> String -> IO Bool
 
 fputs stream [] = return True
 
@@ -312,7 +226,7 @@ SOF & 4/96 & added argument to indicate function that flagged error
 \begin{code}
 constructErrorAndFail :: String -> IO a
 constructErrorAndFail call_site
-  = stToIO (constructError call_site) >>= \ io_error ->
+  = constructError call_site >>= \ io_error ->
     fail io_error
 
 \end{code}
@@ -330,7 +244,7 @@ to a value that is one of the \tr{#define}s in @includes/error.h@.
 information.
 
 \begin{code}
-constructError	      :: String -> PrimIO IOError
+constructError	      :: String -> IO IOError
 constructError call_site =
  _casm_ ``%r = ghc_errtype;''    >>= \ (I# errtype#) ->
  _casm_ ``%r = ghc_errstr;''	 >>= \ str ->
@@ -387,6 +301,11 @@ a handles reside in @IOHandle@.
 -}
 data MVar a = MVar (SynchVar# RealWorld a)
 
+{-
+  Double sigh - ForeignObj is needed here too to break a cycle.
+-}
+data ForeignObj = ForeignObj ForeignObj#   -- another one
+
 #if defined(__CONCURRENT_HASKELL__)
 type Handle = MVar Handle__
 #else
@@ -461,5 +380,12 @@ and terminals will normally be line-buffered.
 \begin{code}
 data BufferMode  
  = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
-   deriving (Eq, Ord, Read, Show)
+   deriving (Eq, Ord, Show)
+   {- Read instance defined in IO. -}
+
+\end{code}
+
+\begin{code}
+performGC :: IO ()
+performGC = _ccall_GC_ StgPerformGarbageCollection
 \end{code}