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}
%*********************************************************
%* *
%*********************************************************
+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)
{-# 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>>"
%*********************************************************
%* *
-\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}
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
\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}
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 ->
-}
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
\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}
projects / ghc-hetmet.git / blobdiff