wantWritableHandle, wantReadableHandle, wantSeekableHandle,
newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
- flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
+ flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
+ fillReadBuffer, fillReadBufferWithoutBlocking,
readRawBuffer, readRawBufferPtr,
writeRawBuffer, writeRawBufferPtr,
unlockFile,
- {- ought to be unnecessary, but just in case.. -}
- write_off, write_rawBuffer,
- read_off, read_rawBuffer,
-
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
stdin, stdout, stderr,
) where
-#include "config.h"
+#include "ghcconfig.h"
import Control.Monad
import Data.Bits
"seek operations on text-mode handles are not allowed on this platform"
Nothing)
+ioe_finalizedHandle fp = throw (IOException
+ (IOError Nothing IllegalOperation ""
+ "handle is finalized" (Just fp)))
+
ioe_bufsiz :: Int -> IO a
ioe_bufsiz n = ioException
(IOError Nothing InvalidArgument "hSetBuffering"
-- The finalizer is then placed on the write side, and the handle only gets
-- finalized once, when both sides are no longer required.
-stdHandleFinalizer :: MVar Handle__ -> IO ()
-stdHandleFinalizer m = do
+-- NOTE about finalized handles: It's possible that a handle can be
+-- finalized and then we try to use it later, for example if the
+-- handle is referenced from another finalizer, or from a thread that
+-- has become unreferenced and then resurrected (arguably in the
+-- latter case we shouldn't finalize the Handle...). Anyway,
+-- we try to emit a helpful message which is better than nothing.
+
+stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+stdHandleFinalizer fp m = do
h_ <- takeMVar m
flushWriteBufferOnly h_
+ putMVar m (ioe_finalizedHandle fp)
-handleFinalizer :: MVar Handle__ -> IO ()
-handleFinalizer m = do
+handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+handleFinalizer fp m = do
handle_ <- takeMVar m
case haType handle_ of
ClosedHandle -> return ()
-- descriptor anyway...
hClose_handle_ handle_
return ()
+ putMVar m (ioe_finalizedHandle fp)
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
return buf{ bufWPtr=0, bufRPtr=0 }
flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
-flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
+flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } =
+ seq fd $ do -- strictness hack
let bytes = w - r
#ifdef DEBUG_DUMP
puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
else return buf{ bufRPtr=0, bufWPtr=w+res' }
+fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
+fillReadBufferWithoutBlocking fd is_stream
+ buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
+ -- buffer better be empty:
+ assert (r == 0 && w == 0) $ do
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
+#endif
+ res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
+ 0 (fromIntegral size)
+ let res' = fromIntegral res
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
+#endif
+ return buf{ bufRPtr=0, bufWPtr=res' }
+
-- Low level routines for reading/writing to (raw)buffers:
#ifndef mingw32_TARGET_OS
readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBuffer loc fd is_stream buf off len =
throwErrnoIfMinus1RetryMayBlock loc
- (read_rawBuffer fd is_stream buf off len)
- (threadWaitRead fd)
+ (read_rawBuffer fd buf off len)
+ (threadWaitRead (fromIntegral fd))
+
+readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBufferNoBlock loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryOnBlock loc
+ (read_rawBuffer fd buf off len)
+ (return 0)
readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtr loc fd is_stream buf off len =
throwErrnoIfMinus1RetryMayBlock loc
- (read_off fd is_stream buf off len)
- (threadWaitRead fd)
+ (read_off fd buf off len)
+ (threadWaitRead (fromIntegral fd))
writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
writeRawBuffer loc fd is_stream buf off len =
throwErrnoIfMinus1RetryMayBlock loc
- (write_rawBuffer (fromIntegral fd) is_stream buf off len)
- (threadWaitWrite fd)
+ (write_rawBuffer (fromIntegral fd) buf off len)
+ (threadWaitWrite (fromIntegral fd))
writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
writeRawBufferPtr loc fd is_stream buf off len =
throwErrnoIfMinus1RetryMayBlock loc
- (write_off (fromIntegral fd) is_stream buf off len)
- (threadWaitWrite fd)
+ (write_off (fromIntegral fd) buf off len)
+ (threadWaitWrite (fromIntegral fd))
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+ read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+ read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+ write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+ write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+
+#else /* mingw32_TARGET_OS.... */
-#else
readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBuffer loc fd is_stream buf off len = do
- (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
+readRawBuffer loc fd is_stream buf off len
+ | threaded = blockingReadRawBuffer loc fd is_stream buf off len
+ | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtr loc fd is_stream buf off len = do
- (l, rc) <- asyncRead fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
+readRawBufferPtr loc fd is_stream buf off len
+ | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len
+ | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-writeRawBuffer loc fd is_stream buf off len = do
- (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
+writeRawBuffer loc fd is_stream buf off len
+ | threaded = blockingWriteRawBuffer loc fd is_stream buf off len
+ | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len
writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-writeRawBufferPtr loc fd is_stream buf off len = do
- (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
-foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-
+writeRawBufferPtr loc fd is_stream buf off len
+ | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len
+ | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len
+
+-- ToDo: we don't have a non-blocking primitve read on Win32
+readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBufferNoBlock = readRawBufferNoBlock
+
+-- Async versions of the read/write primitives, for the non-threaded RTS
+
+asyncReadRawBuffer loc fd is_stream buf off len = do
+ (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0)
+ (fromIntegral len) off buf
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+asyncReadRawBufferPtr loc fd is_stream buf off len = do
+ (l, rc) <- asyncRead fd (if is_stream then 1 else 0)
+ (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+asyncWriteRawBuffer loc fd is_stream buf off len = do
+ (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0)
+ (fromIntegral len) off buf
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+asyncWriteRawBufferPtr loc fd is_stream buf off len = do
+ (l, rc) <- asyncWrite fd (if is_stream then 1 else 0)
+ (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+-- Blocking versions of the read/write primitives, for the threaded RTS
+
+blockingReadRawBuffer loc fd True buf off len =
+ throwErrnoIfMinus1Retry loc $
+ recv_rawBuffer fd buf off len
+blockingReadRawBuffer loc fd False buf off len =
+ throwErrnoIfMinus1Retry loc $
+ read_rawBuffer fd buf off len
+
+blockingReadRawBufferPtr loc fd True buf off len =
+ throwErrnoIfMinus1Retry loc $
+ recv_off fd buf off len
+blockingReadRawBufferPtr loc fd False buf off len =
+ throwErrnoIfMinus1Retry loc $
+ read_off fd buf off len
+
+blockingWriteRawBuffer loc fd True buf off len =
+ throwErrnoIfMinus1Retry loc $
+ send_rawBuffer (fromIntegral fd) buf off len
+blockingWriteRawBuffer loc fd False buf off len =
+ throwErrnoIfMinus1Retry loc $
+ write_rawBuffer (fromIntegral fd) buf off len
+
+blockingWriteRawBufferPtr loc fd True buf off len =
+ throwErrnoIfMinus1Retry loc $
+ send_off (fromIntegral fd) buf off len
+blockingWriteRawBufferPtr loc fd False buf off len =
+ throwErrnoIfMinus1Retry loc $
+ write_off (fromIntegral fd) buf off len
+
+-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
+-- These calls may block, but that's ok.
+
+foreign import ccall safe "__hscore_PrelHandle_read"
+ read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_read"
+ read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_write"
+ write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_write"
+ write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_recv"
+ recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_recv"
+ recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_send"
+ send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_send"
+ send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
#endif
-- ---------------------------------------------------------------------------
-- * 'isDoesNotExistError' if the file does not exist; or
--
-- * 'isPermissionError' if the user does not have permission to open the file.
-
+--
+-- Note: if you will be working with files containing binary data, you'll want to
+-- be using 'openBinaryFile'.
openFile :: FilePath -> IOMode -> IO Handle
openFile fp im =
catch
throwErrnoIfMinus1Retry "openFile"
(c_open f (fromIntegral oflags) 0o666)
- openFd fd Nothing filepath mode binary truncate
+ openFd fd Nothing False filepath mode binary truncate
+ `catchException` \e -> do c_close (fromIntegral fd); throw e
+ -- NB. don't forget to close the FD if openFd fails, otherwise
+ -- this FD leaks.
-- ASSERT: if we just created the file, then openFd won't fail
-- (so we don't need to worry about removing the newly created file
-- in the event of an error).
-- ---------------------------------------------------------------------------
-- openFd
-openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
-openFd fd mb_fd_type filepath mode binary truncate = do
+openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
+openFd fd mb_fd_type is_socket filepath mode binary truncate = do
-- turn on non-blocking mode
setNonBlockingFD fd
case mb_fd_type of
Just x -> return x
Nothing -> fdType fd
- let is_stream = fd_type == Stream
+
case fd_type of
Directory ->
ioException (IOError Nothing InappropriateType "openFile"
"is a directory" Nothing)
Stream
- | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
- | otherwise -> mkFileHandle fd is_stream filepath ha_type binary
+ | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
+ | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
-- regular files need to be locked
RegularFile -> do
-- truncate the file if necessary
when truncate (fileTruncate filepath)
- mkFileHandle fd is_stream filepath ha_type binary
+ mkFileHandle fd is_socket filepath ha_type binary
fdToHandle :: FD -> IO Handle
fdToHandle fd = do
mode <- fdGetMode fd
let fd_str = "<file descriptor: " ++ show fd ++ ">"
- openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-}
+ openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} False{-no truncate-}
foreign import ccall unsafe "lockFile"
lockFile :: CInt -> CInt -> CInt -> IO CInt
-> IO Handle
mkStdHandle fd filepath ha_type buf bmode = do
spares <- newIORef BufferListNil
- newFileHandle filepath stdHandleFinalizer
+ newFileHandle filepath (stdHandleFinalizer filepath)
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
mkFileHandle fd is_stream filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
spares <- newIORef BufferListNil
- newFileHandle filepath handleFinalizer
+ newFileHandle filepath (handleFinalizer filepath)
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = binary,
}
read_side <- newMVar r_handle_
- addMVarFinalizer write_side (handleFinalizer write_side)
+ addMVarFinalizer write_side (handleFinalizer filepath write_side)
return (DuplexHandle filepath read_side write_side)
-- -----------------------------------------------------------------------------
-- Changing echo status (Non-standard GHC extensions)
--- | Set the echoing status of a handle connected to a terminal (GHC only).
+-- | Set the echoing status of a handle connected to a terminal.
hSetEcho :: Handle -> Bool -> IO ()
hSetEcho handle on = do
ClosedHandle -> ioe_closedHandle
_ -> setEcho (haFD handle_) on
--- | Get the echoing status of a handle connected to a terminal (GHC only).
+-- | Get the echoing status of a handle connected to a terminal.
hGetEcho :: Handle -> IO Bool
hGetEcho handle = do
ClosedHandle -> ioe_closedHandle
_ -> getEcho (haFD handle_)
--- | Is the handle connected to a terminal? (GHC only)
+-- | Is the handle connected to a terminal?
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice handle = do
-- hSetBinaryMode
-- | Select binary mode ('True') or text mode ('False') on a open handle.
--- (GHC only; see also 'openBinaryFile'.)
+-- (See also 'openBinaryFile'.)
hSetBinaryMode :: Handle -> Bool -> IO ()
hSetBinaryMode handle bin =
hDuplicate :: Handle -> IO Handle
hDuplicate h@(FileHandle path m) = do
new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
- new_m <- newMVar new_h_
- return (FileHandle path new_m)
+ newFileHandle path (handleFinalizer path) new_h_
hDuplicate h@(DuplexHandle path r w) = do
new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
new_w <- newMVar new_w_
new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
new_r <- newMVar new_r_
+ addMVarFinalizer new_w (handleFinalizer path new_w)
return (DuplexHandle path new_r new_w)
dupHandle_ other_side h_ = do
#endif
-- -----------------------------------------------------------------------------
+-- utils
+
+throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
+throwErrnoIfMinus1RetryOnBlock loc f on_block =
+ do
+ res <- f
+ if (res :: CInt) == -1
+ then do
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfMinus1RetryOnBlock loc f on_block
+ else if err == eWOULDBLOCK || err == eAGAIN
+ then do on_block
+ else throwErrno loc
+ else return res
+
+-- -----------------------------------------------------------------------------
-- wrappers to platform-specific constants:
foreign import ccall unsafe "__hscore_supportsTextMode"
projects / ghc-base.git / blobdiff