X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelCError.lhs;h=9979a00534833287f2637d1eb00cddbcfb58bfc8;hb=9acd03bddf3d603cf3df5d9e03937588e0e2dfb4;hp=6fae07dfea612e199d24d67b19e0e32b62e62c54;hpb=4d0f108451cc199b55dfa44c40790be6196a39e2;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelCError.lhs b/ghc/lib/std/PrelCError.lhs index 6fae07d..9979a00 100644 --- a/ghc/lib/std/PrelCError.lhs +++ b/ghc/lib/std/PrelCError.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelCError.lhs,v 1.5 2001/01/26 17:51:54 rrt Exp $ +% $Id: PrelCError.lhs,v 1.10 2001/07/13 11:11:34 rrt Exp $ % % (c) The FFI task force, 2000 % @@ -7,7 +7,7 @@ C-specific Marshalling support: Handling of C "errno" error codes \begin{code} -{-# OPTIONS -fno-implicit-prelude -#include "cbits/errno.h" #-} +{-# OPTIONS -fno-implicit-prelude -#include "HsStd.h" #-} -- this is were we get the CCONST_XXX definitions from that configure -- calculated for us @@ -70,7 +70,13 @@ module PrelCError ( -- :: Num a -- => String -> IO a -> IO () throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a) - throwErrnoIfNullRetry -- :: String -> IO (Ptr a) -> IO (Ptr a) + throwErrnoIfNullRetry,-- :: String -> IO (Ptr a) -> IO (Ptr a) + + throwErrnoIfRetryMayBlock, + throwErrnoIfRetryMayBlock_, + throwErrnoIfMinus1RetryMayBlock, + throwErrnoIfMinus1RetryMayBlock_, + throwErrnoIfNullRetryMayBlock ) where @@ -80,23 +86,18 @@ module PrelCError ( -- GHC allows us to get at the guts inside IO errors/exceptions -- #if __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ < 409 -import PrelIOBase (IOError(..), IOErrorType(..)) -#else import PrelIOBase (Exception(..), IOException(..), IOErrorType(..)) -#endif #endif /* __GLASGOW_HASKELL__ */ -- regular imports -- --------------- -import Monad (liftM) - #if __GLASGOW_HASKELL__ import PrelStorable import PrelMarshalError import PrelCTypes +import PrelCString import PrelIOBase import PrelPtr import PrelNum @@ -106,37 +107,18 @@ import PrelBase #else import Ptr (Ptr, nullPtr) import CTypes (CInt) +import CString (peekCString) import MarshalError (void) import IO (IOError, Handle, ioError) #endif --- system dependent re-definitions --- ------------------------------- - --- we bring GHC's `IOErrorType' in scope in other compilers to simplify the --- routine `errnoToIOError' below --- -#if !__GLASGOW_HASKELL__ -data IOErrorType - = AlreadyExists | HardwareFault - | IllegalOperation | InappropriateType - | Interrupted | InvalidArgument - | NoSuchThing | OtherError - | PermissionDenied | ProtocolError - | ResourceBusy | ResourceExhausted - | ResourceVanished | SystemError - | TimeExpired | UnsatisfiedConstraints - | UnsupportedOperation - | EOF -#endif - - -- "errno" type -- ------------ -- import of C function that gives address of errno --- +-- This function exists because errno is a variable on some systems, but on +-- Windows it is a macro for a function... foreign import "ghcErrno" unsafe _errno :: Ptr CInt -- Haskell representation for "errno" values @@ -284,8 +266,7 @@ isValidErrno (Errno errno) = errno /= -1 -- yield the current thread's "errno" value -- getErrno :: IO Errno -getErrno = liftM Errno (peek _errno) - +getErrno = do e <- peek _errno; return (Errno e) -- set the current thread's "errno" value to 0 -- @@ -338,11 +319,34 @@ throwErrnoIfRetry pred loc f = else throwErrno loc else return res +-- as `throwErrnoIfRetry', but checks for operations that would block and +-- executes an alternative action in that case. + +throwErrnoIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a +throwErrnoIfRetryMayBlock pred loc f on_block = + do + res <- f + if pred res + then do + err <- getErrno + if err == eINTR + then throwErrnoIfRetryMayBlock pred loc f on_block + else if err == eWOULDBLOCK || err == eAGAIN + then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block + else throwErrno loc + else return res + -- as `throwErrnoIfRetry', but discards the result -- throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO () throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f +-- as `throwErrnoIfRetryMayBlock', but discards the result +-- +throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO () +throwErrnoIfRetryMayBlock_ pred loc f on_block + = void $ throwErrnoIfRetryMayBlock pred loc f on_block + -- throws "errno" if a result of "-1" is returned -- throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a @@ -364,6 +368,16 @@ throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1) throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO () throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1) +-- as throwErrnoIfMinus1Retry, but checks for operations that would block +-- +throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a +throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1) + +-- as `throwErrnoIfMinus1RetryMayBlock', but discards the result +-- +throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO () +throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1) + -- throws "errno" if a result of a NULL pointer is returned -- throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a) @@ -375,6 +389,10 @@ throwErrnoIfNull = throwErrnoIf (== nullPtr) throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a) throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr) +-- as throwErrnoIfNullRetry, but checks for operations that would block +-- +throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a) +throwErrnoIfNullRetryMayBlock = throwErrnoIfRetryMayBlock (== nullPtr) -- conversion of an "errno" value into IO error -- -------------------------------------------- @@ -383,219 +401,115 @@ throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr) -- and an optional filename into a matching IO error -- errnoToIOError :: String -> Errno -> Maybe Handle -> Maybe String -> IOError -errnoToIOError loc errno@(Errno no) maybeHdl maybeName = +errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do + str <- strerror errno >>= peekCString #if __GLASGOW_HASKELL__ - IOException (IOError maybeHdl errType loc str maybeName) + return (IOException (IOError maybeHdl errType loc str maybeName)) + where + errType + | errno == eOK = OtherError + | errno == e2BIG = ResourceExhausted + | errno == eACCES = PermissionDenied + | errno == eADDRINUSE = ResourceBusy + | errno == eADDRNOTAVAIL = UnsupportedOperation + | errno == eADV = OtherError + | errno == eAFNOSUPPORT = UnsupportedOperation + | errno == eAGAIN = ResourceExhausted + | errno == eALREADY = AlreadyExists + | errno == eBADF = OtherError + | errno == eBADMSG = InappropriateType + | errno == eBADRPC = OtherError + | errno == eBUSY = ResourceBusy + | errno == eCHILD = NoSuchThing + | errno == eCOMM = ResourceVanished + | errno == eCONNABORTED = OtherError + | errno == eCONNREFUSED = NoSuchThing + | errno == eCONNRESET = ResourceVanished + | errno == eDEADLK = ResourceBusy + | errno == eDESTADDRREQ = InvalidArgument + | errno == eDIRTY = UnsatisfiedConstraints + | errno == eDOM = InvalidArgument + | errno == eDQUOT = PermissionDenied + | errno == eEXIST = AlreadyExists + | errno == eFAULT = OtherError + | errno == eFBIG = PermissionDenied + | errno == eFTYPE = InappropriateType + | errno == eHOSTDOWN = NoSuchThing + | errno == eHOSTUNREACH = NoSuchThing + | errno == eIDRM = ResourceVanished + | errno == eILSEQ = InvalidArgument + | errno == eINPROGRESS = AlreadyExists + | errno == eINTR = Interrupted + | errno == eINVAL = InvalidArgument + | errno == eIO = HardwareFault + | errno == eISCONN = AlreadyExists + | errno == eISDIR = InappropriateType + | errno == eLOOP = InvalidArgument + | errno == eMFILE = ResourceExhausted + | errno == eMLINK = ResourceExhausted + | errno == eMSGSIZE = ResourceExhausted + | errno == eMULTIHOP = UnsupportedOperation + | errno == eNAMETOOLONG = InvalidArgument + | errno == eNETDOWN = ResourceVanished + | errno == eNETRESET = ResourceVanished + | errno == eNETUNREACH = NoSuchThing + | errno == eNFILE = ResourceExhausted + | errno == eNOBUFS = ResourceExhausted + | errno == eNODATA = NoSuchThing + | errno == eNODEV = NoSuchThing + | errno == eNOENT = NoSuchThing + | errno == eNOEXEC = InvalidArgument + | errno == eNOLCK = ResourceExhausted + | errno == eNOLINK = ResourceVanished + | errno == eNOMEM = ResourceExhausted + | errno == eNOMSG = NoSuchThing + | errno == eNONET = NoSuchThing + | errno == eNOPROTOOPT = UnsupportedOperation + | errno == eNOSPC = ResourceExhausted + | errno == eNOSR = ResourceExhausted + | errno == eNOSTR = InvalidArgument + | errno == eNOSYS = UnsupportedOperation + | errno == eNOTBLK = InvalidArgument + | errno == eNOTCONN = InvalidArgument + | errno == eNOTDIR = InappropriateType + | errno == eNOTEMPTY = UnsatisfiedConstraints + | errno == eNOTSOCK = InvalidArgument + | errno == eNOTTY = IllegalOperation + | errno == eNXIO = NoSuchThing + | errno == eOPNOTSUPP = UnsupportedOperation + | errno == ePERM = PermissionDenied + | errno == ePFNOSUPPORT = UnsupportedOperation + | errno == ePIPE = ResourceVanished + | errno == ePROCLIM = PermissionDenied + | errno == ePROCUNAVAIL = UnsupportedOperation + | errno == ePROGMISMATCH = ProtocolError + | errno == ePROGUNAVAIL = UnsupportedOperation + | errno == ePROTO = ProtocolError + | errno == ePROTONOSUPPORT = ProtocolError + | errno == ePROTOTYPE = ProtocolError + | errno == eRANGE = UnsupportedOperation + | errno == eREMCHG = ResourceVanished + | errno == eREMOTE = IllegalOperation + | errno == eROFS = PermissionDenied + | errno == eRPCMISMATCH = ProtocolError + | errno == eRREMOTE = IllegalOperation + | errno == eSHUTDOWN = IllegalOperation + | errno == eSOCKTNOSUPPORT = UnsupportedOperation + | errno == eSPIPE = UnsupportedOperation + | errno == eSRCH = NoSuchThing + | errno == eSRMNT = UnsatisfiedConstraints + | errno == eSTALE = ResourceVanished + | errno == eTIME = TimeExpired + | errno == eTIMEDOUT = TimeExpired + | errno == eTOOMANYREFS = ResourceExhausted + | errno == eTXTBSY = ResourceBusy + | errno == eUSERS = ResourceExhausted + | errno == eWOULDBLOCK = OtherError + | errno == eXDEV = UnsupportedOperation + | otherwise = OtherError #else - userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName) + return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName)) #endif - where - (errType, str) - | errno == eOK = (OtherError, - "no error") - | errno == e2BIG = (ResourceExhausted, - "argument list too long") - | errno == eACCES = (PermissionDenied, - "inadequate access permission") - | errno == eADDRINUSE = (ResourceBusy, - "address already in use") - | errno == eADDRNOTAVAIL = (UnsupportedOperation, - "address not available") - | errno == eADV = (OtherError, - "RFS advertise error") - | errno == eAFNOSUPPORT = (UnsupportedOperation, - "address family not supported by " ++ - "protocol family") - -- no multiline strings with cpp - | errno == eAGAIN = (ResourceExhausted, - "insufficient resources") - | errno == eALREADY = (AlreadyExists, - "operation already in progress") - | errno == eBADF = (OtherError, - "internal error (EBADF)") - | errno == eBADMSG = (InappropriateType, - "next message has wrong type") - | errno == eBADRPC = (OtherError, - "invalid RPC request or response") - | errno == eBUSY = (ResourceBusy, - "device busy") - | errno == eCHILD = (NoSuchThing, - "no child processes") - | errno == eCOMM = (ResourceVanished, - "no virtual circuit could be found") - | errno == eCONNABORTED = (OtherError, - "aborted connection") - | errno == eCONNREFUSED = (NoSuchThing, - "no listener on remote host") - | errno == eCONNRESET = (ResourceVanished, - "connection reset by peer") - | errno == eDEADLK = (ResourceBusy, - "resource deadlock avoided") - | errno == eDESTADDRREQ = (InvalidArgument, - "destination address required") - | errno == eDIRTY = (UnsatisfiedConstraints, - "file system dirty") - | errno == eDOM = (InvalidArgument, - "argument too large") - | errno == eDQUOT = (PermissionDenied, - "quota exceeded") - | errno == eEXIST = (AlreadyExists, - "file already exists") - | errno == eFAULT = (OtherError, - "internal error (EFAULT)") - | errno == eFBIG = (PermissionDenied, - "file too large") - | errno == eFTYPE = (InappropriateType, - "inappropriate NFS file type or format") - | errno == eHOSTDOWN = (NoSuchThing, - "destination host down") - | errno == eHOSTUNREACH = (NoSuchThing, - "remote host is unreachable") - | errno == eIDRM = (ResourceVanished, - "IPC identifier removed") - | errno == eILSEQ = (InvalidArgument, - "invalid wide character") - | errno == eINPROGRESS = (AlreadyExists, - "operation now in progress") - | errno == eINTR = (Interrupted, - "interrupted system call") - | errno == eINVAL = (InvalidArgument, - "invalid argument") - | errno == eIO = (HardwareFault, - "unknown I/O fault") - | errno == eISCONN = (AlreadyExists, - "socket is already connected") - | errno == eISDIR = (InappropriateType, - "file is a directory") - | errno == eLOOP = (InvalidArgument, - "too many symbolic links") - | errno == eMFILE = (ResourceExhausted, - "process file table full") - | errno == eMLINK = (ResourceExhausted, - "too many links") - | errno == eMSGSIZE = (ResourceExhausted, - "message too long") - | errno == eMULTIHOP = (UnsupportedOperation, - "multi-hop RFS request") - | errno == eNAMETOOLONG = (InvalidArgument, - "filename too long") - | errno == eNETDOWN = (ResourceVanished, - "network is down") - | errno == eNETRESET = (ResourceVanished, - "remote host rebooted; connection lost") - | errno == eNETUNREACH = (NoSuchThing, - "remote network is unreachable") - | errno == eNFILE = (ResourceExhausted, - "system file table full") - | errno == eNOBUFS = (ResourceExhausted, - "no buffer space available") - | errno == eNODATA = (NoSuchThing, - "no message on the stream head read " ++ - "queue") - -- no multiline strings with cpp - | errno == eNODEV = (NoSuchThing, - "no such device") - | errno == eNOENT = (NoSuchThing, - "no such file or directory") - | errno == eNOEXEC = (InvalidArgument, - "not an executable file") - | errno == eNOLCK = (ResourceExhausted, - "no file locks available") - | errno == eNOLINK = (ResourceVanished, - "RFS link has been severed") - | errno == eNOMEM = (ResourceExhausted, - "not enough virtual memory") - | errno == eNOMSG = (NoSuchThing, - "no message of desired type") - | errno == eNONET = (NoSuchThing, - "host is not on a network") - | errno == eNOPROTOOPT = (UnsupportedOperation, - "operation not supported by protocol") - | errno == eNOSPC = (ResourceExhausted, - "no space left on device") - | errno == eNOSR = (ResourceExhausted, - "out of stream resources") - | errno == eNOSTR = (InvalidArgument, - "not a stream device") - | errno == eNOSYS = (UnsupportedOperation, - "function not implemented") - | errno == eNOTBLK = (InvalidArgument, - "not a block device") - | errno == eNOTCONN = (InvalidArgument, - "socket is not connected") - | errno == eNOTDIR = (InappropriateType, - "not a directory") - | errno == eNOTEMPTY = (UnsatisfiedConstraints, - "directory not empty") - | errno == eNOTSOCK = (InvalidArgument, - "not a socket") - | errno == eNOTTY = (IllegalOperation, - "inappropriate ioctl for device") - | errno == eNXIO = (NoSuchThing, - "no such device or address") - | errno == eOPNOTSUPP = (UnsupportedOperation, - "operation not supported on socket") - | errno == ePERM = (PermissionDenied, - "privileged operation") - | errno == ePFNOSUPPORT = (UnsupportedOperation, - "protocol family not supported") - | errno == ePIPE = (ResourceVanished, - "broken pipe") - | errno == ePROCLIM = (PermissionDenied, - "too many processes") - | errno == ePROCUNAVAIL = (UnsupportedOperation, - "unimplemented RPC procedure") - | errno == ePROGMISMATCH = (ProtocolError, - "unsupported RPC program version") - | errno == ePROGUNAVAIL = (UnsupportedOperation, - "RPC program unavailable") - | errno == ePROTO = (ProtocolError, - "error in streams protocol") - | errno == ePROTONOSUPPORT = (ProtocolError, - "protocol not supported") - | errno == ePROTOTYPE = (ProtocolError, - "wrong protocol for socket") - | errno == eRANGE = (UnsupportedOperation, - "result too large") - | errno == eREMCHG = (ResourceVanished, - "remote address changed") - | errno == eREMOTE = (IllegalOperation, - "too many levels of remote in path") - | errno == eROFS = (PermissionDenied, - "read-only file system") - | errno == eRPCMISMATCH = (ProtocolError, - "RPC version is wrong") - | errno == eRREMOTE = (IllegalOperation, - "object is remote") - | errno == eSHUTDOWN = (IllegalOperation, - "can't send after socket shutdown") - | errno == eSOCKTNOSUPPORT = (UnsupportedOperation, - "socket type not supported") - | errno == eSPIPE = (UnsupportedOperation, - "can't seek on a pipe") - | errno == eSRCH = (NoSuchThing, - "no such process") - | errno == eSRMNT = (UnsatisfiedConstraints, - "RFS resources still mounted by " ++ - "remote host(s)") - -- no multiline strings with cpp - | errno == eSTALE = (ResourceVanished, - "stale NFS file handle") - | errno == eTIME = (TimeExpired, - "timer expired") - | errno == eTIMEDOUT = (TimeExpired, - "connection timed out") - | errno == eTOOMANYREFS = (ResourceExhausted, - "too many references; can't splice") - | errno == eTXTBSY = (ResourceBusy, - "text file in-use") - | errno == eUSERS = (ResourceExhausted, - "quota table full") - | errno == eWOULDBLOCK = (OtherError, - "operation would block") - | errno == eXDEV = (UnsupportedOperation, - "can't make a cross-device link") - | otherwise = (OtherError, - "unexpected error (error code: " - ++ show no ++")") + +foreign import unsafe strerror :: Errno -> IO (Ptr CChar) \end{code}