% -----------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.7 1999/01/14 18:12:58 sof Exp $
+% $Id: PrelIOBase.lhs,v 1.23 2000/04/14 15:28:24 rrt Exp $
%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#include "cbits/error.h"
+#include "cbits/stgerror.h"
+#include "config.h"
#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelIOBase where
import PrelST
import PrelBase
import {-# SOURCE #-} PrelException ( ioError )
-import PrelST ( ST(..), STret(..) )
import PrelMaybe ( Maybe(..) )
import PrelAddr ( Addr(..), nullAddr )
-import PrelPack ( unpackCString )
+import PrelPack ( unpackCString )
+import PrelShow
#if !defined(__CONCURRENT_HASKELL__)
import PrelArr ( MutableVar, readVar )
#endif
#ifdef __HUGS__
-#define cat2(x,y) x/**/y
-#define CCALL(fun) cat2(prim_,fun)
#define __CONCURRENT_HASKELL__
#define stToIO id
#define unpackCString primUnpackString
-#else
-#define CCALL(fun) _ccall_ fun
-#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)
#endif
#ifndef __PARALLEL_HASKELL__
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 #))
{-# 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?
- -- 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
(# new_s, a #) -> unIO (k a) new_s
)
+returnIO :: a -> IO a
+returnIO x = IO (\ s -> (# s, x #))
#endif
\end{code}
\end{code}
%*********************************************************
-%* *
-\subsection{Utility functions}
-%* *
-%*********************************************************
-
-I'm not sure why this little function is here...
-
-\begin{code}
---fputs :: Addr{-FILE*-} -> String -> IO Bool
-
-userError :: String -> IOError
-userError str = IOError Nothing (UserError Nothing) "" str
-
-{-
-fputs stream (c : cs)
- = CCALL(filePutc) stream c >>
- fputs stream cs
--}
-\end{code}
-
-%*********************************************************
%* *
\subsection{Unsafe @IO@ operations}
%* *
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
| ResourceBusy | ResourceExhausted
| ResourceVanished | SystemError
| TimeExpired | UnsatisfiedConstraints
- | UnsupportedOperation | UserError (Maybe Addr)
+ | UnsupportedOperation | UserError
| EOF
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
+ | ComError Int -- HRESULT
+#endif
deriving (Eq)
instance Show IOErrorType where
SystemError -> "system error"
TimeExpired -> "timeout"
UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
- UserError _ -> "failed"
+ UserError -> "failed"
UnsupportedOperation -> "unsupported operation"
EOF -> "end of file"
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
+ ComError _ -> "COM error"
+#endif
+
+
+userError :: String -> IOError
+userError str = IOError Nothing UserError "" str
\end{code}
Predicates on IOError; little effort made on these so far...
isDoesNotExistError _ = False
isUserError :: IOError -> Bool
-isUserError (IOError _ (UserError _) _ _) = True
-isUserError _ = False
+isUserError (IOError _ UserError _ _) = True
+isUserError _ = False
\end{code}
Showing @IOError@s
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
-}
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
-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__)
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
haFO__ :: FILE_OBJECT,
haType__ :: Handle__Type,
haBufferMode__ :: BufferMode,
- haFilePath__ :: FilePath
- }
+ haFilePath__ :: FilePath,
+ haBuffers__ :: [Addr]
+ }
{-
Internally, we classify handles as being one
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
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
- CCALL(setBuf) fo chunk sz_in_bytes
+ setBuf fo chunk sz_in_bytes
\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}
projects / ghc-hetmet.git / blobdiff