diff options
Diffstat (limited to 'libraries/base/GHC/IO/FD.hs')
| -rw-r--r-- | libraries/base/GHC/IO/FD.hs | 67 |
1 files changed, 39 insertions, 28 deletions
diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs index 8eafe08fdc..d5567f0838 100644 --- a/libraries/base/GHC/IO/FD.hs +++ b/libraries/base/GHC/IO/FD.hs @@ -45,6 +45,7 @@ import GHC.Conc.IO import GHC.IO.Exception #if defined(mingw32_HOST_OS) import GHC.Windows +import Data.Bool #endif import Foreign @@ -179,14 +180,10 @@ openFile filepath iomode non_blocking = | otherwise = oflags2 in do - -- the old implementation had a complicated series of three opens, - -- which is perhaps because we have to be careful not to open - -- directories. However, the man pages I've read say that open() - -- always returns EISDIR if the file is a directory and was opened - -- for writing, so I think we're ok with a single open() here... - fd <- throwErrnoIfMinus1Retry "openFile" - (if non_blocking then c_open f oflags 0o666 - else c_safe_open f oflags 0o666) + -- NB. always use a safe open(), because we don't know whether open() + -- will be fast or not. It can be slow on NFS and FUSE filesystems, + -- for example. + fd <- throwErrnoIfMinus1Retry "openFile" $ c_safe_open f oflags 0o666 (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-} False{-not a socket-} @@ -405,7 +402,7 @@ ready fd write msecs = do return (toEnum (fromIntegral r)) foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt -- --------------------------------------------------------------------------- -- Terminal-related stuff @@ -566,7 +563,7 @@ isNonBlocking :: FD -> Bool isNonBlocking fd = fdIsNonBlocking fd /= 0 foreign import ccall unsafe "fdReady" - unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt #else /* mingw32_HOST_OS.... */ @@ -593,8 +590,10 @@ asyncReadRawBufferPtr loc !fd !buf !off !len = do (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + then let sock_errno = c_maperrno_func (fromIntegral rc) + non_sock_errno = Errno (fromIntegral rc) + errno = bool non_sock_errno sock_errno (fdIsSocket fd) + in ioError (errnoToIOError loc errno Nothing Nothing) else return (fromIntegral l) asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt @@ -602,34 +601,46 @@ asyncWriteRawBufferPtr loc !fd !buf !off !len = do (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + then let sock_errno = c_maperrno_func (fromIntegral rc) + non_sock_errno = Errno (fromIntegral rc) + errno = bool non_sock_errno sock_errno (fdIsSocket fd) + in ioError (errnoToIOError loc errno Nothing Nothing) else return (fromIntegral l) -- Blocking versions of the read/write primitives, for the threaded RTS blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt blockingReadRawBufferPtr loc !fd !buf !off !len - = throwErrnoIfMinus1Retry loc $ - if fdIsSocket fd - then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 - else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len) + = throwErrnoIfMinus1Retry loc $ do + let start_ptr = buf `plusPtr` off + recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0 + read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len) + r <- bool read_ret recv_ret (fdIsSocket fd) + when ((fdIsSocket fd) && (r == -1)) c_maperrno + return r + -- We trust read() to give us the correct errno but recv(), as a + -- Winsock function, doesn't do the errno conversion so if the fd + -- is for a socket, we do it from GetLastError() ourselves. blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt blockingWriteRawBufferPtr loc !fd !buf !off !len - = throwErrnoIfMinus1Retry loc $ - if fdIsSocket fd - then c_safe_send (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 - else do - r <- c_safe_write (fdFD fd) (buf `plusPtr` off) (fromIntegral len) - when (r == -1) c_maperrno - return r - -- we don't trust write() to give us the correct errno, and + = throwErrnoIfMinus1Retry loc $ do + let start_ptr = buf `plusPtr` off + send_ret = c_safe_send (fdFD fd) start_ptr (fromIntegral len) 0 + write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len) + r <- bool write_ret send_ret (fdIsSocket fd) + when (r == -1) c_maperrno + return r + -- We don't trust write() to give us the correct errno, and -- instead do the errno conversion from GetLastError() - -- ourselves. The main reason is that we treat ERROR_NO_DATA + -- ourselves. The main reason is that we treat ERROR_NO_DATA -- (pipe is closing) as EPIPE, whereas write() returns EINVAL - -- for this case. We need to detect EPIPE correctly, because it + -- for this case. We need to detect EPIPE correctly, because it -- shouldn't be reported as an error when it happens on stdout. + -- As for send()'s case, Winsock functions don't do errno + -- conversion in any case so we have to do it ourselves. + -- That means we're doing the errno conversion no matter if the + -- fd is from a socket or not. -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. -- These calls may block, but that's ok. |