X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Flib%2Fstd%2FPrelIOBase.lhs;h=6ef3f277ce8f9b26501b737bc1df369f7130957c;hb=956d36d236054aa1a71ef7ec15e80f6c7c4d10c8;hp=7c53b59b1e61d24c0e810dae212bbeebabc12fa7;hpb=6151c960d6df040a5bfd94791f934969dfb55050;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 7c53b59..6ef3f27 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelIOBase.lhs,v 1.26 2000/07/07 11:03:58 simonmar Exp $ +% $Id: PrelIOBase.lhs,v 1.33 2001/02/06 11:42:30 simonmar Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -21,11 +21,12 @@ import {-# SOURCE #-} PrelErr ( error ) import PrelST import PrelBase +import PrelNum ( fromInteger ) -- Integer literals import PrelMaybe ( Maybe(..) ) -import PrelAddr ( Addr(..) ) import PrelShow import PrelList import PrelDynamic +import PrelPtr import PrelPack ( unpackCString ) #if !defined(__CONCURRENT_HASKELL__) @@ -40,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} @@ -91,7 +93,7 @@ instance Monad IO where return x = returnIO x m >>= k = bindIO m k - fail s = error s -- not ioError? + fail 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 @@ -169,20 +171,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__) @@ -214,7 +217,7 @@ data Handle__ haType__ :: Handle__Type, haBufferMode__ :: BufferMode, haFilePath__ :: FilePath, - haBuffers__ :: [Addr] + haBuffers__ :: [Ptr ()] } {- @@ -222,8 +225,7 @@ data Handle__ of the following: -} data Handle__Type - = ErrorHandle IOException - | ClosedHandle + = ClosedHandle | SemiClosedHandle | ReadHandle | WriteHandle @@ -250,7 +252,6 @@ type FilePath = String instance Show Handle__Type where showsPrec p t = case t of - ErrorHandle iot -> showString "error " . showsPrec p iot ClosedHandle -> showString "closed" SemiClosedHandle -> showString "semi-closed" ReadHandle -> showString "readable" @@ -268,9 +269,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)) @@ -286,7 +288,6 @@ instance Show Handle where showHdl ht cont = case ht of ClosedHandle -> showsPrec p ht . showString "}\n" - ErrorHandle _ -> showsPrec p ht . showString "}\n" _ -> cont showBufMode :: FILE_OBJECT -> BufferMode -> ShowS @@ -356,16 +357,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 + +-- ToDo: use mallocBytes from PrelMarshal? +malloc :: Int -> IO (Ptr ()) +malloc sz = do + a <- _malloc sz + if (a == nullPtr) + then ioException (IOError Nothing ResourceExhausted + "malloc" "out of memory" Nothing) + else return a + +foreign import "malloc" unsafe _malloc :: Int -> IO (Ptr ()) -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 () + setBuf :: FILE_OBJECT -> Ptr () -> Int -> IO () \end{code} @@ -450,11 +460,12 @@ instance Show Exception where showsPrec _ (RecConError err) = showString err showsPrec _ (RecUpdError err) = showString err showsPrec _ (AssertionFailed err) = showString err - showsPrec _ (AsyncException e) = shows e 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 "<>" + showsPrec _ (UserError err) = showString err \end{code} %********************************************************* @@ -490,15 +501,16 @@ type IOError = Exception data IOException = IOError - (Maybe Handle) -- the handle used by the action flagging the - -- the error. - IOErrorType -- what it was. - String -- location - String -- error type specific information. + (Maybe Handle) -- the handle used by the action flagging the + -- the error. + IOErrorType -- what it was. + String -- location. + String -- error type specific information. + (Maybe FilePath) -- filename the error is related to. instance Eq IOException where - (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) = - e1==e2 && str1==str2 && h1==h2 && loc1 == loc2 + (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = + e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2 data IOErrorType = AlreadyExists | HardwareFault @@ -553,36 +565,36 @@ Predicates on IOError; little effort made on these so far... \begin{code} isAlreadyExistsError :: IOError -> Bool -isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _)) = True -isAlreadyExistsError _ = False +isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True +isAlreadyExistsError _ = False isAlreadyInUseError :: IOError -> Bool -isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _)) = True -isAlreadyInUseError _ = False +isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True +isAlreadyInUseError _ = False isFullError :: IOError -> Bool -isFullError (IOException (IOError _ ResourceExhausted _ _)) = True -isFullError _ = False +isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True +isFullError _ = False isEOFError :: IOError -> Bool -isEOFError (IOException (IOError _ EOF _ _)) = True -isEOFError _ = False +isEOFError (IOException (IOError _ EOF _ _ _)) = True +isEOFError _ = False isIllegalOperation :: IOError -> Bool -isIllegalOperation (IOException (IOError _ IllegalOperation _ _)) = True -isIllegalOperation _ = False +isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True +isIllegalOperation _ = False isPermissionError :: IOError -> Bool -isPermissionError (IOException (IOError _ PermissionDenied _ _)) = True -isPermissionError _ = False +isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True +isPermissionError _ = False isDoesNotExistError :: IOError -> Bool -isDoesNotExistError (IOException (IOError _ NoSuchThing _ _)) = True -isDoesNotExistError _ = False +isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True +isDoesNotExistError _ = False isUserError :: IOError -> Bool isUserError (UserError _) = True -isUserError _ = False +isUserError _ = False \end{code} Showing @IOError@s @@ -592,24 +604,26 @@ Showing @IOError@s -- For now we give a fairly uninformative error message which just happens to -- be like the ones that Hugs used to give. instance Show IOException where - showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n' + showsPrec p (IOError _ _ _ s _) = showString s . showChar '\n' #else instance Show IOException where - showsPrec p (IOError hdl iot loc s) = + showsPrec p (IOError hdl iot loc s fn) = showsPrec p iot . - showChar '\n' . (case loc of "" -> id - _ -> showString "Action: " . showString loc . showChar '\n') . + _ -> showString "\nAction: " . showString loc) . showHdl . (case s of "" -> id - _ -> showString "Reason: " . showString s) + _ -> showString "\nReason: " . showString s) . + (case fn of + Nothing -> id + Just name -> showString "\nFile: " . showString name) where showHdl = case hdl of Nothing -> id - Just h -> showString "Handle: " . showsPrec p h + Just h -> showString "\nHandle: " . showsPrec p h #endif \end{code} @@ -628,8 +642,8 @@ constructErrorAndFail call_site ioError (IOException io_error) constructErrorAndFailWithInfo :: String -> String -> IO a -constructErrorAndFailWithInfo call_site reason - = constructErrorMsg call_site (Just reason) >>= \ io_error -> +constructErrorAndFailWithInfo call_site fn + = constructErrorMsg call_site (Just fn) >>= \ io_error -> ioError (IOException io_error) \end{code} @@ -652,7 +666,7 @@ constructError :: String -> IO IOException constructError call_site = constructErrorMsg call_site Nothing constructErrorMsg :: String -> Maybe String -> IO IOException -constructErrorMsg call_site reason = +constructErrorMsg call_site fn = getErrType__ >>= \ errtype -> getErrStr__ >>= \ str -> let @@ -673,8 +687,8 @@ constructErrorMsg call_site reason = ERR_RESOURCEVANISHED -> ResourceVanished ERR_SYSTEMERROR -> SystemError ERR_TIMEEXPIRED -> TimeExpired - ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints - ERR_UNSUPPORTEDOPERATION -> UnsupportedOperation + ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints + ERR_UNSUPPORTEDOPERATION -> UnsupportedOperation ERR_EOF -> EOF _ -> OtherError @@ -682,10 +696,7 @@ constructErrorMsg call_site reason = unpackCString str ++ (case iot of OtherError -> "(error code: " ++ show errtype ++ ")" - _ -> "") ++ - (case reason of - Nothing -> "" - Just m -> ' ':m) + _ -> "") in - return (IOError Nothing iot call_site msg) + return (IOError Nothing iot call_site msg fn) \end{code}