-{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
+{-# OPTIONS_HADDOCK hide #-}
#undef DEBUG_DUMP
#undef DEBUG
module GHC.Handle (
withHandle, withHandle', withHandle_,
wantWritableHandle, wantReadableHandle, wantSeekableHandle,
-
+
newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
- flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
+ flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
fillReadBuffer, fillReadBufferWithoutBlocking,
readRawBuffer, readRawBufferPtr,
+ readRawBufferNoBlock, readRawBufferPtrNoBlock,
writeRawBuffer, writeRawBufferPtr,
#ifndef mingw32_HOST_OS
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
stdin, stdout, stderr,
- IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle,
+ IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',
hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
hFlush, hDuplicate, hDuplicateTo,
) where
-import System.Directory.Internals
import Control.Monad
-import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C
import System.IO.Error
import System.Posix.Internals
+import System.Posix.Types
import GHC.Real
import GHC.Arr
import GHC.Base
-import GHC.Read ( Read )
+import GHC.Read ( Read )
import GHC.List
import GHC.IOBase
import GHC.Exception
import GHC.Enum
-import GHC.Num ( Integer(..), Num(..) )
+import GHC.Num ( Integer(..), Num(..) )
import GHC.Show
-import GHC.Real ( toInteger )
+#if defined(DEBUG_DUMP)
+import GHC.Pack
+#endif
import GHC.Conc
-- unbuffered hGetLine is a bit dodgy
-- hSetBuffering: can't change buffering on a stream,
--- when the read buffer is non-empty? (no way to flush the buffer)
+-- when the read buffer is non-empty? (no way to flush the buffer)
-- ---------------------------------------------------------------------------
-- Are files opened by default in text or binary mode, if the user doesn't
-- Creating a new handle
newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
-newFileHandle filepath finalizer hc = do
+newFileHandle filepath finalizer hc = do
m <- newMVar hc
addMVarFinalizer m (finalizer m)
return (FileHandle filepath m)
There are three versions of @withHandle@: corresponding to the three
possible combinations of:
- - the operation may side-effect the handle
- - the operation may return a result
+ - the operation may side-effect the handle
+ - the operation may return a result
If the operation generates an error or an exception is raised, the
original handle is always replaced [ this is the case at the moment,
withHandle' :: String -> Handle -> MVar Handle__
-> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle' fun h m act =
+withHandle' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- (h',v) <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h'
putMVar m h'
return v
withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
-withHandle_' fun h m act =
+withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
+withHandle_' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- v <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h_
putMVar m h_
return v
withHandle__' fun h r act
withHandle__' fun h w act
-withHandle__' fun h m act =
+withHandle__' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- h' <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h'
putMVar m h'
return ()
augmentIOError (IOError _ iot _ str fp) fun h
= IOError (Just h) iot fun str filepath
where filepath
- | Just _ <- fp = fp
- | otherwise = case h of
- FileHandle fp _ -> Just fp
- DuplexHandle fp _ _ -> Just fp
+ | Just _ <- fp = fp
+ | otherwise = case h of
+ FileHandle fp _ -> Just fp
+ DuplexHandle fp _ _ -> Just fp
-- ---------------------------------------------------------------------------
-- Wrapper for write operations.
-- ToDo: in the Duplex case, we don't need to checkWritableHandle
wantWritableHandle'
- :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO a) -> IO a
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
wantWritableHandle' fun h m act
= withHandle_' fun h m (checkWritableHandle act)
checkWritableHandle act handle_
- = case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- ReadHandle -> ioe_notWritable
- ReadWriteHandle -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
- new_buf <-
- if not (bufferIsWritable buf)
- then do b <- flushReadBuffer (haFD handle_) buf
- return b{ bufState=WriteBuffer }
- else return buf
- writeIORef ref new_buf
- act handle_
- _other -> act handle_
+ = case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ ReadHandle -> ioe_notWritable
+ ReadWriteHandle -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ new_buf <-
+ if not (bufferIsWritable buf)
+ then do b <- flushReadBuffer (haFD handle_) buf
+ return b{ bufState=WriteBuffer }
+ else return buf
+ writeIORef ref new_buf
+ act handle_
+ _other -> act handle_
-- ---------------------------------------------------------------------------
-- Wrapper for read operations.
-- ToDo: in the Duplex case, we don't need to checkReadableHandle
wantReadableHandle'
- :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO a) -> IO a
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
wantReadableHandle' fun h m act
= withHandle_' fun h m (checkReadableHandle act)
-checkReadableHandle act handle_ =
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notReadable
- WriteHandle -> ioe_notReadable
- ReadWriteHandle -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
- when (bufferIsWritable buf) $ do
- new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
- writeIORef ref new_buf{ bufState=ReadBuffer }
- act handle_
- _other -> act handle_
+checkReadableHandle act handle_ =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioe_notReadable
+ WriteHandle -> ioe_notReadable
+ ReadWriteHandle -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ when (bufferIsWritable buf) $ do
+ new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
+ writeIORef ref new_buf{ bufState=ReadBuffer }
+ act handle_
+ _other -> act handle_
-- ---------------------------------------------------------------------------
-- Wrapper for seek operations.
wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
- ioException (IOError (Just h) IllegalOperation fun
- "handle is not seekable" Nothing)
+ ioException (IOError (Just h) IllegalOperation fun
+ "handle is not seekable" Nothing)
wantSeekableHandle fun h@(FileHandle _ m) act =
withHandle_' fun h m (checkSeekableHandle act)
-
-checkSeekableHandle act handle_ =
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
+
+checkSeekableHandle act handle_ =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
AppendHandle -> ioe_notSeekable
_ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
| otherwise -> ioe_notSeekable_notBin
-
+
-- -----------------------------------------------------------------------------
-- Handy IOErrors
-ioe_closedHandle, ioe_EOF,
- ioe_notReadable, ioe_notWritable,
+ioe_closedHandle, ioe_EOF,
+ ioe_notReadable, ioe_notWritable,
ioe_notSeekable, ioe_notSeekable_notBin :: IO a
-ioe_closedHandle = ioException
- (IOError Nothing IllegalOperation ""
- "handle is closed" Nothing)
-ioe_EOF = ioException
+ioe_closedHandle = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is closed" Nothing)
+ioe_EOF = ioException
(IOError Nothing EOF "" "" Nothing)
-ioe_notReadable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not open for reading" Nothing)
-ioe_notWritable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not open for writing" Nothing)
-ioe_notSeekable = ioException
+ioe_notReadable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not open for reading" Nothing)
+ioe_notWritable = ioException
(IOError Nothing IllegalOperation ""
- "handle is not seekable" Nothing)
-ioe_notSeekable_notBin = ioException
+ "handle is not open for writing" Nothing)
+ioe_notSeekable = ioException
(IOError Nothing IllegalOperation ""
- "seek operations on text-mode handles are not allowed on this platform"
+ "handle is not seekable" Nothing)
+ioe_notSeekable_notBin = ioException
+ (IOError Nothing IllegalOperation ""
+ "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_finalizedHandle fp = throw
+ (IOError Nothing IllegalOperation ""
+ "handle is finalized" (Just fp))
ioe_bufsiz :: Int -> IO a
-ioe_bufsiz n = ioException
+ioe_bufsiz n = ioException
(IOError Nothing InvalidArgument "hSetBuffering"
- ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
- -- 9 => should be parens'ified.
+ ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
+ -- 9 => should be parens'ified.
-- -----------------------------------------------------------------------------
-- Handle Finalizers
handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
handleFinalizer fp m = do
handle_ <- takeMVar m
- case haType handle_ of
+ case haType handle_ of
ClosedHandle -> return ()
- _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
- -- ignore errors and async exceptions, and close the
- -- descriptor anyway...
- hClose_handle_ handle_
- return ()
+ _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return ()
+ -- ignore errors and async exceptions, and close the
+ -- descriptor anyway...
+ hClose_handle_ handle_
+ return ()
putMVar m (ioe_finalizedHandle fp)
-- ---------------------------------------------------------------------------
#ifdef DEBUG
checkBufferInvariants h_ = do
- let ref = haBuffer h_
+ let ref = haBuffer h_
Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
if not (
- size > 0
- && r <= w
- && w <= size
- && ( r /= w || (r == 0 && w == 0) )
- && ( state /= WriteBuffer || r == 0 )
- && ( state /= WriteBuffer || w < size ) -- write buffer is never full
+ size > 0
+ && r <= w
+ && w <= size
+ && ( r /= w || (r == 0 && w == 0) )
+ && ( state /= WriteBuffer || r == 0 )
+ && ( state /= WriteBuffer || w < size ) -- write buffer is never full
)
then error "buffer invariant violation"
else return ()
allocateBuffer :: Int -> BufferState -> IO Buffer
allocateBuffer sz@(I# size) state = IO $ \s ->
-#ifdef mingw32_HOST_OS
- -- To implement asynchronous I/O under Win32, we have to pass
- -- buffer references to external threads that handles the
- -- filling/emptying of their contents. Hence, the buffer cannot
- -- be moved around by the GC.
+ -- We sometimes need to pass the address of this buffer to
+ -- a "safe" foreign call, hence it must be immovable.
case newPinnedByteArray# size s of { (# s, b #) ->
-#else
- case newByteArray# size s of { (# s, b #) ->
-#endif
(# s, newEmptyBuffer b state sz #) }
writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
writeCharIntoBuffer slab (I# off) (C# c)
= IO $ \s -> case writeCharArray# slab off c s of
- s -> (# s, I# (off +# 1#) #)
+ s -> (# s, I# (off +# 1#) #)
readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
readCharFromBuffer slab (I# off)
= IO $ \s -> case readCharArray# slab off s of
- (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
+ (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
getBuffer fd state = do
ref = haBuffer h_
buf <- readIORef ref
new_buf <- if bufferIsWritable buf
- then flushWriteBuffer fd (haIsStream h_) buf
- else return buf
+ then flushWriteBuffer fd (haIsStream h_) buf
+ else return buf
writeIORef ref new_buf
-- flushBuffer syncs the file with the buffer, including moving the
puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
# endif
throwErrnoIfMinus1Retry "flushReadBuffer"
- (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
+ (c_lseek fd (fromIntegral off) sEEK_CUR)
return buf{ bufWPtr=0, bufRPtr=0 }
flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
if bytes == 0
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
- res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
- (fromIntegral r) (fromIntegral bytes)
+ res <- writeRawBuffer "flushWriteBuffer" fd is_stream b
+ (fromIntegral r) (fromIntegral bytes)
let res' = fromIntegral res
if res' < bytes
then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
res <- readRawBuffer "fillReadBuffer" fd is_stream b
- (fromIntegral w) (fromIntegral bytes)
+ (fromIntegral w) (fromIntegral bytes)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
#endif
if res' == 0
then if w == 0
- then ioe_EOF
- else return buf{ bufRPtr=0, bufWPtr=w }
+ then ioe_EOF
+ else return buf{ bufRPtr=0, bufWPtr=w }
else if res' < bytes && not is_line
- then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
- else return buf{ bufRPtr=0, bufWPtr=w+res' }
+ then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
+ else return buf{ bufRPtr=0, bufWPtr=w+res' }
fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
-- buffer better be empty:
assert (r == 0 && w == 0) $ do
#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
+ puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
#endif
res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
- 0 (fromIntegral size)
+ 0 (fromIntegral size)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
-- Low level routines for reading/writing to (raw)buffers:
#ifndef mingw32_HOST_OS
-readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBuffer loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryMayBlock loc
- (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)
+{-
+NOTE [nonblock]:
+
+Unix has broken semantics when it comes to non-blocking I/O: you can
+set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
+attached to the same underlying file, pipe or TTY; there's no way to
+have private non-blocking behaviour for an FD. See bug #724.
+
+We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
+come from external sources or are exposed externally are left in
+blocking mode. This solution has some problems though. We can't
+completely simulate a non-blocking read without O_NONBLOCK: several
+cases are wrong here. The cases that are wrong:
+
+ * reading/writing to a blocking FD in non-threaded mode.
+ In threaded mode, we just make a safe call to read().
+ In non-threaded mode we call select() before attempting to read,
+ but that leaves a small race window where the data can be read
+ from the file descriptor before we issue our blocking read().
+ * readRawBufferNoBlock for a blocking FD
+
+NOTE [2363]:
+
+In the threaded RTS we could just make safe calls to read()/write()
+for file descriptors in blocking mode without worrying about blocking
+other threads, but the problem with this is that the thread will be
+uninterruptible while it is blocked in the foreign call. See #2363.
+So now we always call fdReady() before reading, and if fdReady
+indicates that there's no data, we call threadWaitRead.
+
+-}
+
+readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBuffer loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_read -- unsafe is ok, it can't block
+ | otherwise = do r <- throwErrnoIfMinus1 loc
+ (unsafe_fdReady (fromIntegral fd) 0 0 0)
+ if r /= 0
+ then read
+ else do threadWaitRead (fromIntegral fd); read
+ where
+ do_read call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitRead (fromIntegral fd))
+ read = if threaded then safe_read else unsafe_read
+ unsafe_read = do_read (read_rawBuffer fd buf off len)
+ safe_read = do_read (safe_read_rawBuffer fd buf off len)
readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtr loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryMayBlock loc
- (read_off fd buf off len)
- (threadWaitRead (fromIntegral fd))
+readRawBufferPtr loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_read -- unsafe is ok, it can't block
+ | otherwise = do r <- throwErrnoIfMinus1 loc
+ (unsafe_fdReady (fromIntegral fd) 0 0 0)
+ if r /= 0
+ then read
+ else do threadWaitRead (fromIntegral fd); read
+ where
+ do_read call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitRead (fromIntegral fd))
+ read = if threaded then safe_read else unsafe_read
+ unsafe_read = do_read (read_off fd buf off len)
+ safe_read = do_read (safe_read_off fd buf off len)
+
+readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBufferNoBlock loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_read -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
+ if r /= 0 then safe_read
+ else return 0
+ -- XXX see note [nonblock]
+ where
+ do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
+ unsafe_read = do_read (read_rawBuffer fd buf off len)
+ safe_read = do_read (safe_read_rawBuffer fd buf off len)
+
+readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+readRawBufferPtrNoBlock loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_read -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
+ if r /= 0 then safe_read
+ else return 0
+ -- XXX see note [nonblock]
+ where
+ do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
+ unsafe_read = do_read (read_off fd buf off len)
+ safe_read = do_read (safe_read_off fd buf off len)
writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-writeRawBuffer loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryMayBlock loc
- (write_rawBuffer (fromIntegral fd) buf off len)
- (threadWaitWrite (fromIntegral fd))
+writeRawBuffer loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_write -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
+ if r /= 0
+ then write
+ else do threadWaitWrite (fromIntegral fd); write
+ where
+ do_write call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitWrite (fromIntegral fd))
+ write = if threaded then safe_write else unsafe_write
+ unsafe_write = do_write (write_rawBuffer fd buf off len)
+ safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)
writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-writeRawBufferPtr loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryMayBlock loc
- (write_off (fromIntegral fd) buf off len)
- (threadWaitWrite (fromIntegral fd))
+writeRawBufferPtr loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_write -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
+ if r /= 0
+ then write
+ else do threadWaitWrite (fromIntegral fd); write
+ where
+ do_write call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitWrite (fromIntegral fd))
+ write = if threaded then safe_write else unsafe_write
+ unsafe_write = do_write (write_off fd buf off len)
+ safe_write = do_write (safe_write_off (fromIntegral fd) buf off len)
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+ read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+ read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_write"
write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_write"
write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "fdReady"
+ unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+
#else /* mingw32_HOST_OS.... */
readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-- ToDo: we don't have a non-blocking primitve read on Win32
readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBufferNoBlock = readRawBufferNoBlock
+readRawBufferNoBlock = readRawBuffer
+readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+readRawBufferPtrNoBlock = readRawBufferPtr
-- 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
+ (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0)
+ (fromIntegral len) off buf
if l == (-1)
then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ 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)
+ (l, rc) <- asyncRead (fromIntegral 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
+ (l, rc) <- asyncWriteBA (fromIntegral 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)
+ (l, rc) <- asyncWrite (fromIntegral 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)
blockingReadRawBuffer loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- recv_rawBuffer fd buf off len
+ safe_recv_rawBuffer fd buf off len
blockingReadRawBuffer loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- read_rawBuffer fd buf off len
+ safe_read_rawBuffer fd buf off len
blockingReadRawBufferPtr loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- recv_off fd buf off len
+ safe_recv_off fd buf off len
blockingReadRawBufferPtr loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- read_off fd buf off len
+ safe_read_off fd buf off len
blockingWriteRawBuffer loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- send_rawBuffer (fromIntegral fd) buf off len
+ safe_send_rawBuffer fd buf off len
blockingWriteRawBuffer loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- write_rawBuffer (fromIntegral fd) buf off len
+ safe_write_rawBuffer fd buf off len
blockingWriteRawBufferPtr loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- send_off (fromIntegral fd) buf off len
+ safe_send_off fd buf off len
blockingWriteRawBufferPtr loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- write_off (fromIntegral fd) buf off len
+ safe_write_off 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
+ safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall safe "__hscore_PrelHandle_recv"
- recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+ safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
foreign import ccall safe "__hscore_PrelHandle_send"
- send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+ safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall safe "__hscore_PrelHandle_send"
- send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+ safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
#endif
+foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
+
+foreign import ccall safe "__hscore_PrelHandle_read"
+ safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_read"
+ safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_write"
+ safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_write"
+ safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+
-- ---------------------------------------------------------------------------
-- Standard Handles
stdin :: Handle
stdin = unsafePerformIO $ do
-- ToDo: acquire lock
- setNonBlockingFD fd_stdin
+ -- We don't set non-blocking mode on standard handles, because it may
+ -- confuse other applications attached to the same TTY/pipe
+ -- see Note [nonblock]
(buf, bmode) <- getBuffer fd_stdin ReadBuffer
mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
stdout :: Handle
stdout = unsafePerformIO $ do
-- ToDo: acquire lock
- -- We don't set non-blocking mode on stdout or sterr, because
- -- some shells don't recover properly.
- -- setNonBlockingFD fd_stdout
+ -- We don't set non-blocking mode on standard handles, because it may
+ -- confuse other applications attached to the same TTY/pipe
+ -- see Note [nonblock]
(buf, bmode) <- getBuffer fd_stdout WriteBuffer
mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
stderr :: Handle
stderr = unsafePerformIO $ do
-- ToDo: acquire lock
- -- We don't set non-blocking mode on stdout or sterr, because
- -- some shells don't recover properly.
- -- setNonBlockingFD fd_stderr
+ -- We don't set non-blocking mode on standard handles, because it may
+ -- confuse other applications attached to the same TTY/pipe
+ -- see Note [nonblock]
buf <- mkUnBuffer
mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
let
oflags1 = case mode of
- ReadMode -> read_flags
+ ReadMode -> read_flags
#ifdef mingw32_HOST_OS
- WriteMode -> write_flags .|. o_TRUNC
+ WriteMode -> write_flags .|. o_TRUNC
#else
- WriteMode -> write_flags
+ WriteMode -> write_flags
#endif
- ReadWriteMode -> rw_flags
- AppendMode -> append_flags
+ ReadWriteMode -> rw_flags
+ AppendMode -> append_flags
binary_flags
- | binary = o_BINARY
- | otherwise = 0
+ | binary = o_BINARY
+ | otherwise = 0
oflags = oflags1 .|. binary_flags
in do
-- 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 <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "openFile"
- (c_open f (fromIntegral oflags) 0o666)
-
- h <- openFd fd Nothing False filepath mode binary
- `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).
+ fd <- throwErrnoIfMinus1Retry "openFile"
+ (c_open f (fromIntegral oflags) 0o666)
+
+ stat@(fd_type,_,_) <- fdStat fd
+
+ h <- fdToHandle_stat fd (Just stat) False filepath mode binary
+ `catchAny` \e -> do c_close fd; throw e
+ -- NB. don't forget to close the FD if fdToHandle' fails, otherwise
+ -- this FD leaks.
+ -- ASSERT: if we just created the file, then fdToHandle' won't fail
+ -- (so we don't need to worry about removing the newly created file
+ -- in the event of an error).
+
#ifndef mingw32_HOST_OS
- if mode == WriteMode
+ -- we want to truncate() if this is an open in WriteMode, but only
+ -- if the target is a RegularFile. ftruncate() fails on special files
+ -- like /dev/null.
+ if mode == WriteMode && fd_type == RegularFile
then throwErrnoIf (/=0) "openFile"
- (c_ftruncate (fromIntegral fd) 0)
+ (c_ftruncate fd 0)
else return 0
#endif
return h
--- | The function creates a temporary file in ReadWrite mode.
--- The created file isn\'t deleted automatically, so you need to delete it manually.
-openTempFile :: FilePath -- ^ Directory in which to create the file
- -> String -- ^ File name template. If the template is \"foo.ext\" then
- -- the create file will be \"fooXXX.ext\" where XXX is some
- -- random number.
- -> IO (FilePath, Handle)
-openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE
-
--- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
-openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
-openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True
-
-openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)
-openTempFile' loc tmp_dir template binary = do
- pid <- c_getpid
- findTempName pid
- where
- (prefix,suffix) = break (=='.') template
-
- oflags1 = rw_flags .|. o_EXCL
-
- binary_flags
- | binary = o_BINARY
- | otherwise = 0
-
- oflags = oflags1 .|. binary_flags
-
- findTempName x = do
- fd <- withCString filepath $ \ f ->
- c_open f oflags 0o666
- if fd < 0
- then do
- errno <- getErrno
- if errno == eEXIST
- then findTempName (x+1)
- else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
- else do
- h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True
- `catchException` \e -> do c_close (fromIntegral fd); throw e
- return (filepath, h)
- where
- filename = prefix ++ show x ++ suffix
- filepath = tmp_dir `joinFileName` filename
-
-
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
read_flags = std_flags .|. o_RDONLY
append_flags = write_flags .|. o_APPEND
-- ---------------------------------------------------------------------------
--- openFd
+-- fdToHandle
+
+fdToHandle_stat :: FD
+ -> Maybe (FDType, CDev, CIno)
+ -> Bool
+ -> FilePath
+ -> IOMode
+ -> Bool
+ -> IO Handle
+
+fdToHandle_stat fd mb_stat is_socket filepath mode binary = do
+
+#ifdef mingw32_HOST_OS
+ -- On Windows, the is_socket flag indicates that the Handle is a socket
+#else
+ -- On Unix, the is_socket flag indicates that the FD can be made non-blocking
+ let non_blocking = is_socket
-openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
-openFd fd mb_fd_type is_socket filepath mode binary = do
+ when non_blocking $ setNonBlockingFD fd
-- turn on non-blocking mode
- setNonBlockingFD fd
+#endif
let (ha_type, write) =
- case mode of
- ReadMode -> ( ReadHandle, False )
- WriteMode -> ( WriteHandle, True )
- ReadWriteMode -> ( ReadWriteHandle, True )
- AppendMode -> ( AppendHandle, True )
+ case mode of
+ ReadMode -> ( ReadHandle, False )
+ WriteMode -> ( WriteHandle, True )
+ ReadWriteMode -> ( ReadWriteHandle, True )
+ AppendMode -> ( AppendHandle, True )
-- open() won't tell us if it was a directory if we only opened for
-- reading, so check again.
- fd_type <-
- case mb_fd_type of
+ (fd_type,dev,ino) <-
+ case mb_stat of
Just x -> return x
- Nothing -> fdType fd
+ Nothing -> fdStat fd
case fd_type of
- Directory ->
- ioException (IOError Nothing InappropriateType "openFile"
- "is a directory" Nothing)
-
- Stream
- | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
- | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
+ Directory ->
+ ioException (IOError Nothing InappropriateType "openFile"
+ "is a directory" Nothing)
- -- regular files need to be locked
- RegularFile -> do
+ -- regular files need to be locked
+ RegularFile -> do
#ifndef mingw32_HOST_OS
- r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
- when (r == -1) $
- ioException (IOError Nothing ResourceBusy "openFile"
- "file is locked" Nothing)
+ -- On Windows we use explicit exclusion via sopen() to implement
+ -- this locking (see __hscore_open()); on Unix we have to
+ -- implment it in the RTS.
+ r <- lockFile fd dev ino (fromBool write)
+ when (r == -1) $
+ ioException (IOError Nothing ResourceBusy "openFile"
+ "file is locked" Nothing)
#endif
- mkFileHandle fd is_socket filepath ha_type binary
-
+ mkFileHandle fd is_socket filepath ha_type binary
+
+ Stream
+ -- only *Streams* can be DuplexHandles. Other read/write
+ -- Handles must share a buffer.
+ | ReadWriteHandle <- ha_type ->
+ mkDuplexHandle fd is_socket filepath binary
+ | otherwise ->
+ mkFileHandle fd is_socket filepath ha_type binary
+
+ RawDevice ->
+ mkFileHandle fd is_socket filepath ha_type binary
+
+-- | Old API kept to avoid breaking clients
+fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool
+ -> IO Handle
+fdToHandle' fd mb_type is_socket filepath mode binary
+ = do
+ let mb_stat = case mb_type of
+ Nothing -> Nothing
+ -- fdToHandle_stat will do the stat:
+ Just RegularFile -> Nothing
+ -- no stat required for streams etc.:
+ Just other -> Just (other,0,0)
+ fdToHandle_stat fd mb_stat is_socket filepath mode binary
fdToHandle :: FD -> IO Handle
fdToHandle fd = do
mode <- fdGetMode fd
let fd_str = "<file descriptor: " ++ show fd ++ ">"
- openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
-
+ fdToHandle_stat fd Nothing False fd_str mode True{-bin mode-}
+ -- NB. the is_socket flag is False, meaning that:
+ -- on Unix the file descriptor will *not* be put in non-blocking mode
+ -- on Windows we're guessing this is not a socket (XXX)
#ifndef mingw32_HOST_OS
foreign import ccall unsafe "lockFile"
- lockFile :: CInt -> CInt -> CInt -> IO CInt
+ lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
foreign import ccall unsafe "unlockFile"
unlockFile :: CInt -> IO CInt
#endif
mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
- -> IO Handle
+ -> IO Handle
mkStdHandle fd filepath ha_type buf bmode = do
spares <- newIORef BufferListNil
newFileHandle filepath (stdHandleFinalizer filepath)
- (Handle__ { haFD = fd,
- haType = ha_type,
+ (Handle__ { haFD = fd,
+ haType = ha_type,
haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haIsStream = False,
- haBufferMode = bmode,
- haBuffer = buf,
- haBuffers = spares,
- haOtherSide = Nothing
- })
+ haIsStream = False, -- means FD is blocking on Unix
+ haBufferMode = bmode,
+ haBuffer = buf,
+ haBuffers = spares,
+ haOtherSide = Nothing
+ })
mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
mkFileHandle fd is_stream filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
+
+#ifdef mingw32_HOST_OS
+ -- On Windows, if this is a read/write handle and we are in text mode,
+ -- turn off buffering. We don't correctly handle the case of switching
+ -- from read mode to write mode on a buffered text-mode handle, see bug
+ -- \#679.
+ bmode <- case ha_type of
+ ReadWriteHandle | not binary -> return NoBuffering
+ _other -> return bmode
+#endif
+
spares <- newIORef BufferListNil
newFileHandle filepath (handleFinalizer filepath)
- (Handle__ { haFD = fd,
- haType = ha_type,
+ (Handle__ { haFD = fd,
+ haType = ha_type,
haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = bmode,
- haBuffer = buf,
- haBuffers = spares,
- haOtherSide = Nothing
- })
+ haIsStream = is_stream,
+ haBufferMode = bmode,
+ haBuffer = buf,
+ haBuffers = spares,
+ haOtherSide = Nothing
+ })
mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
mkDuplexHandle fd is_stream filepath binary = do
(w_buf, w_bmode) <- getBuffer fd WriteBuffer
w_spares <- newIORef BufferListNil
let w_handle_ =
- Handle__ { haFD = fd,
- haType = WriteHandle,
+ Handle__ { haFD = fd,
+ haType = WriteHandle,
haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = w_bmode,
- haBuffer = w_buf,
- haBuffers = w_spares,
- haOtherSide = Nothing
- }
+ haIsStream = is_stream,
+ haBufferMode = w_bmode,
+ haBuffer = w_buf,
+ haBuffers = w_spares,
+ haOtherSide = Nothing
+ }
write_side <- newMVar w_handle_
(r_buf, r_bmode) <- getBuffer fd ReadBuffer
r_spares <- newIORef BufferListNil
let r_handle_ =
- Handle__ { haFD = fd,
- haType = ReadHandle,
+ Handle__ { haFD = fd,
+ haType = ReadHandle,
haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = r_bmode,
- haBuffer = r_buf,
- haBuffers = r_spares,
- haOtherSide = Just write_side
- }
+ haIsStream = is_stream,
+ haBufferMode = r_bmode,
+ haBuffer = r_buf,
+ haBuffers = r_spares,
+ haOtherSide = Just write_side
+ }
read_side <- newMVar r_handle_
addMVarFinalizer write_side (handleFinalizer filepath write_side)
initBufferState ReadHandle = ReadBuffer
-initBufferState _ = WriteBuffer
+initBufferState _ = WriteBuffer
-- ---------------------------------------------------------------------------
-- Closing a handle
-- computation finishes, if @hdl@ is writable its buffer is flushed as
-- for 'hFlush'.
-- Performing 'hClose' on a handle that has already been closed has no effect;
--- doing so not an error. All other operations on a closed handle will fail.
+-- doing so is not an error. All other operations on a closed handle will fail.
-- If 'hClose' fails for any reason, any further operations (apart from
-- 'hClose') on the handle will still fail as if @hdl@ had been successfully
-- closed.
hClose :: Handle -> IO ()
-hClose h@(FileHandle _ m) = hClose' h m
-hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
-
-hClose' h m = withHandle__' "hClose" h m $ hClose_help
+hClose h@(FileHandle _ m) = do
+ mb_exc <- hClose' h m
+ case mb_exc of
+ Nothing -> return ()
+ Just e -> throwIO e
+hClose h@(DuplexHandle _ r w) = do
+ mb_exc1 <- hClose' h w
+ mb_exc2 <- hClose' h r
+ case (do mb_exc1; mb_exc2) of
+ Nothing -> return ()
+ Just e -> throwIO e
+
+hClose' h m = withHandle' "hClose" h m $ hClose_help
-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
-- or an IO error occurs on a lazy stream. The semi-closed Handle is
-- then closed immediately. We have to be careful with DuplexHandles
-- though: we have to leave the closing to the finalizer in that case,
-- because the write side may still be in use.
-hClose_help :: Handle__ -> IO Handle__
+hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_help handle_ =
case haType handle_ of
- ClosedHandle -> return handle_
+ ClosedHandle -> return (handle_,Nothing)
_ -> do flushWriteBufferOnly handle_ -- interruptible
- hClose_handle_ handle_
+ hClose_handle_ handle_
+hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_handle_ handle_ = do
let fd = haFD handle_
- c_fd = fromIntegral fd
-- close the file descriptor, but not when this is the read
-- side of a duplex handle.
- case haOtherSide handle_ of
- Nothing ->
- throwErrnoIfMinus1Retry_ "hClose"
+ -- If an exception is raised by the close(), we want to continue
+ -- to close the handle and release the lock if it has one, then
+ -- we return the exception to the caller of hClose_help which can
+ -- raise it if necessary.
+ maybe_exception <-
+ case haOtherSide handle_ of
+ Nothing -> (do
+ throwErrnoIfMinus1Retry_ "hClose"
#ifdef mingw32_HOST_OS
- (closeFd (haIsStream handle_) c_fd)
+ (closeFd (haIsStream handle_) fd)
#else
- (c_close c_fd)
+ (c_close fd)
#endif
- Just _ -> return ()
+ return Nothing
+ )
+ `catchException` \e -> return (Just e)
+
+ Just _ -> return Nothing
-- free the spare buffers
writeIORef (haBuffers handle_) BufferListNil
+ writeIORef (haBuffer handle_) noBuffer
#ifndef mingw32_HOST_OS
-- unlock it
- unlockFile c_fd
+ unlockFile fd
#endif
-- we must set the fd to -1, because the finalizer is going
-- to run eventually and try to close/unlock it.
return (handle_{ haFD = -1,
- haType = ClosedHandle
- })
+ haType = ClosedHandle
+ },
+ maybe_exception)
+
+{-# NOINLINE noBuffer #-}
+noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
-----------------------------------------------------------------------------
-- Detecting and changing the size of a file
hFileSize handle =
withHandle_ "hFileSize" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
_ -> do flushWriteBufferOnly handle_
- r <- fdFileSize (haFD handle_)
- if r /= -1
- then return r
- else ioException (IOError Nothing InappropriateType "hFileSize"
- "not a regular file" Nothing)
+ r <- fdFileSize (haFD handle_)
+ if r /= -1
+ then return r
+ else ioException (IOError Nothing InappropriateType "hFileSize"
+ "not a regular file" Nothing)
-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
hSetFileSize handle size =
withHandle_ "hSetFileSize" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
_ -> do flushWriteBufferOnly handle_
- throwErrnoIf (/=0) "hSetFileSize"
- (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
- return ()
+ throwErrnoIf (/=0) "hSetFileSize"
+ (c_ftruncate (haFD handle_) (fromIntegral size))
+ return ()
-- ---------------------------------------------------------------------------
-- Detecting the End of Input
-- 'True' if no further input can be taken from @hdl@ or for a
-- physical file, if the current I\/O position is equal to the length of
-- the file. Otherwise, it returns 'False'.
+--
+-- NOTE: 'hIsEOF' may block, because it is the same as calling
+-- 'hLookAhead' and checking for an EOF exception.
hIsEOF :: Handle -> IO Bool
hIsEOF handle =
-- fill up the read buffer if necessary
new_buf <- if bufferEmpty buf
- then fillReadBuffer fd is_line (haIsStream handle_) buf
- else return buf
+ then fillReadBuffer fd True (haIsStream handle_) buf
+ else return buf
writeIORef ref new_buf
case haType handle_ of
ClosedHandle -> ioe_closedHandle
_ -> do
- {- Note:
- - we flush the old buffer regardless of whether
- the new buffer could fit the contents of the old buffer
- or not.
- - allow a handle's buffering to change even if IO has
- occurred (ANSI C spec. does not allow this, nor did
- the previous implementation of IO.hSetBuffering).
- - a non-standard extension is to allow the buffering
- of semi-closed handles to change [sof 6/98]
- -}
- flushBuffer handle_
-
- let state = initBufferState (haType handle_)
- new_buf <-
- case mode of
- -- we always have a 1-character read buffer for
- -- unbuffered handles: it's needed to
- -- support hLookAhead.
- NoBuffering -> allocateBuffer 1 ReadBuffer
- LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
- BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
- BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
- | otherwise -> allocateBuffer n state
- writeIORef (haBuffer handle_) new_buf
-
- -- for input terminals we need to put the terminal into
- -- cooked or raw mode depending on the type of buffering.
- is_tty <- fdIsTTY (haFD handle_)
- when (is_tty && isReadableHandleType (haType handle_)) $
- case mode of
+ {- Note:
+ - we flush the old buffer regardless of whether
+ the new buffer could fit the contents of the old buffer
+ or not.
+ - allow a handle's buffering to change even if IO has
+ occurred (ANSI C spec. does not allow this, nor did
+ the previous implementation of IO.hSetBuffering).
+ - a non-standard extension is to allow the buffering
+ of semi-closed handles to change [sof 6/98]
+ -}
+ flushBuffer handle_
+
+ let state = initBufferState (haType handle_)
+ new_buf <-
+ case mode of
+ -- we always have a 1-character read buffer for
+ -- unbuffered handles: it's needed to
+ -- support hLookAhead.
+ NoBuffering -> allocateBuffer 1 ReadBuffer
+ LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
+ BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
+ BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
+ | otherwise -> allocateBuffer n state
+ writeIORef (haBuffer handle_) new_buf
+
+ -- for input terminals we need to put the terminal into
+ -- cooked or raw mode depending on the type of buffering.
+ is_tty <- fdIsTTY (haFD handle_)
+ when (is_tty && isReadableHandleType (haType handle_)) $
+ case mode of
#ifndef mingw32_HOST_OS
- -- 'raw' mode under win32 is a bit too specialised (and troublesome
- -- for most common uses), so simply disable its use here.
- NoBuffering -> setCooked (haFD handle_) False
+ -- 'raw' mode under win32 is a bit too specialised (and troublesome
+ -- for most common uses), so simply disable its use here.
+ NoBuffering -> setCooked (haFD handle_) False
+#else
+ NoBuffering -> return ()
#endif
- _ -> setCooked (haFD handle_) True
+ _ -> setCooked (haFD handle_) True
- -- throw away spare buffers, they might be the wrong size
- writeIORef (haBuffers handle_) BufferListNil
+ -- throw away spare buffers, they might be the wrong size
+ writeIORef (haBuffers handle_) BufferListNil
- return (handle_{ haBufferMode = mode })
+ return (handle_{ haBufferMode = mode })
-- -----------------------------------------------------------------------------
-- hFlush
wantWritableHandle "hFlush" handle $ \ handle_ -> do
buf <- readIORef (haBuffer handle_)
if bufferIsWritable buf && not (bufferEmpty buf)
- then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
- writeIORef (haBuffer handle_) flushed_buf
- else return ()
+ then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
+ writeIORef (haBuffer handle_) flushed_buf
+ else return ()
-- -----------------------------------------------------------------------------
instance Show HandlePosn where
showsPrec p (HandlePosn h pos) =
- showsPrec p h . showString " at position " . shows pos
+ showsPrec p h . showString " at position " . shows pos
-- HandlePosition is the Haskell equivalent of POSIX' off_t.
-- We represent it as an Integer on the Haskell side, but
-- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
data SeekMode
- = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
- | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
- -- from the current position.
- | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
- -- from the end of the file.
+ = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
+ | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
+ -- from the current position.
+ | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
+ -- from the end of the file.
deriving (Eq, Ord, Ix, Enum, Read, Show)
{- Note:
fd = haFD handle_
let do_seek =
- throwErrnoIfMinus1Retry_ "hSeek"
- (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
+ throwErrnoIfMinus1Retry_ "hSeek"
+ (c_lseek (haFD handle_) (fromIntegral offset) whence)
whence :: CInt
whence = case mode of
SeekFromEnd -> sEEK_END
if bufferIsWritable buf
- then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
- writeIORef ref new_buf
- do_seek
- else do
+ then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
+ writeIORef ref new_buf
+ do_seek
+ else do
if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
- then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
- else do
+ then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
+ else do
new_buf <- flushReadBuffer (haFD handle_) buf
writeIORef ref new_buf
wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
#if defined(mingw32_HOST_OS)
- -- urgh, on Windows we have to worry about \n -> \r\n translation,
- -- so we can't easily calculate the file position using the
- -- current buffer size. Just flush instead.
+ -- urgh, on Windows we have to worry about \n -> \r\n translation,
+ -- so we can't easily calculate the file position using the
+ -- current buffer size. Just flush instead.
flushBuffer handle_
#endif
- let fd = fromIntegral (haFD handle_)
+ let fd = haFD handle_
posn <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "hGetPosn"
- (c_lseek fd 0 sEEK_CUR)
+ throwErrnoIfMinus1Retry "hGetPosn"
+ (c_lseek fd 0 sEEK_CUR)
let ref = haBuffer handle_
buf <- readIORef ref
let real_posn
- | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
- | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
+ | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
+ | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
# ifdef DEBUG_DUMP
puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
case haType handle_ of
ClosedHandle -> return False
SemiClosedHandle -> return False
- _ -> return True
+ _ -> return True
hIsClosed :: Handle -> IO Bool
hIsClosed handle =
withHandle_ "hIsClosed" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> return True
- _ -> return False
+ ClosedHandle -> return True
+ _ -> return False
{- not defined, nor exported, but mentioned
here for documentation purposes:
hIsReadable handle =
withHandle_ "hIsReadable" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- htype -> return (isReadableHandleType htype)
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isReadableHandleType htype)
hIsWritable :: Handle -> IO Bool
hIsWritable (DuplexHandle _ _ _) = return True
hIsWritable handle =
withHandle_ "hIsWritable" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- htype -> return (isWritableHandleType htype)
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isWritableHandleType htype)
-- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
-- for @hdl@.
hGetBuffering handle =
withHandle_ "hGetBuffering" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
+ ClosedHandle -> ioe_closedHandle
_ ->
- -- We're being non-standard here, and allow the buffering
- -- of a semi-closed handle to be queried. -- sof 6/98
- return (haBufferMode handle_) -- could be stricter..
+ -- We're being non-standard here, and allow the buffering
+ -- of a semi-closed handle to be queried. -- sof 6/98
+ return (haBufferMode handle_) -- could be stricter..
hIsSeekable :: Handle -> IO Bool
hIsSeekable handle =
withHandle_ "hIsSeekable" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> return False
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> return False
_ -> do t <- fdType (haFD handle_)
- return (t == RegularFile
- && (haIsBin handle_
- || tEXT_MODE_SEEK_ALLOWED))
+ return ((t == RegularFile || t == RawDevice)
+ && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
-- -----------------------------------------------------------------------------
-- Changing echo status (Non-standard GHC extensions)
hSetBinaryMode handle bin =
withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
do throwErrnoIfMinus1_ "hSetBinaryMode"
- (setmode (fromIntegral (haFD handle_)) bin)
+ (setmode (haFD handle_) bin)
return handle_{haIsBin=bin}
foreign import ccall unsafe "__hscore_setmode"
hDuplicate :: Handle -> IO Handle
hDuplicate h@(FileHandle path m) = do
- new_h_ <- withHandle' "hDuplicate" h m (dupHandle Nothing)
+ new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
newFileHandle path (handleFinalizer path) new_h_
hDuplicate h@(DuplexHandle path r w) = do
- new_w_ <- withHandle' "hDuplicate" h w (dupHandle Nothing)
+ new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
new_w <- newMVar new_w_
- new_r_ <- withHandle' "hDuplicate" h r (dupHandle (Just new_w))
+ new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (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
+dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
+ -> IO (Handle__, Handle__)
+dupHandle h other_side h_ = do
-- flush the buffer first, so we don't have to copy its contents
flushBuffer h_
- new_fd <- throwErrnoIfMinus1 "dupHandle" $
- c_dup (fromIntegral (haFD h_))
+ new_fd <- case other_side of
+ Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
+ Just r -> withHandle_' "dupHandle" h r (return . haFD)
dupHandle_ other_side h_ new_fd
dupHandleTo other_side hto_ h_ = do
flushBuffer h_
- new_fd <- throwErrnoIfMinus1 "dupHandleTo" $
- c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_))
- dupHandle_ other_side h_ new_fd
+ -- Windows' dup2 does not return the new descriptor, unlike Unix
+ throwErrnoIfMinus1 "dupHandleTo" $
+ c_dup2 (haFD h_) (haFD hto_)
+ dupHandle_ other_side h_ (haFD hto_)
+dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
+ -> IO (Handle__, Handle__)
dupHandle_ other_side h_ new_fd = do
buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
ioref <- newIORef buffer
ioref_buffers <- newIORef BufferListNil
- let new_handle_ = h_{ haFD = fromIntegral new_fd,
- haBuffer = ioref,
- haBuffers = ioref_buffers,
- haOtherSide = other_side }
+ let new_handle_ = h_{ haFD = new_fd,
+ haBuffer = ioref,
+ haBuffers = ioref_buffers,
+ haOtherSide = other_side }
return (h_, new_handle_)
-- -----------------------------------------------------------------------------
withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
hDuplicateTo h1 _ =
ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
- "handles are incompatible" Nothing)
+ "handles are incompatible" Nothing)
-- ---------------------------------------------------------------------------
-- showing Handles.
withHandle_ "showHandle" h $ \hdl_ ->
let
showType | is_duplex = showString "duplex (read-write)"
- | otherwise = shows (haType hdl_)
+ | otherwise = shows (haType hdl_)
in
return
(( showChar '{' .
showHdl (haType hdl_)
- (showString "loc=" . showString filepath . showChar ',' .
- showString "type=" . showType . showChar ',' .
- showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
- showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
+ (showString "loc=" . showString filepath . showChar ',' .
+ showString "type=" . showType . showChar ',' .
+ showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
+ showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
) "")
where
showHdl ht cont =
case ht of
ClosedHandle -> shows ht . showString "}"
- _ -> cont
+ _ -> cont
showBufMode :: Buffer -> BufferMode -> ShowS
showBufMode buf bmo =
case bmo of
NoBuffering -> showString "none"
- LineBuffering -> showString "line"
- BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
- BlockBuffering Nothing -> showString "block " . showParen True (shows def)
+ LineBuffering -> showString "line"
+ BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
+ BlockBuffering Nothing -> showString "block " . showParen True (shows def)
where
def :: Int
def = bufSize buf
-- ---------------------------------------------------------------------------
-- debugging
-#ifdef DEBUG_DUMP
+#if defined(DEBUG_DUMP)
puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
- return ()
+puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
+ return ()
#endif
-- -----------------------------------------------------------------------------
res <- f
if (res :: CInt) == -1
then do
- err <- getErrno
- if err == eINTR
- then throwErrnoIfMinus1RetryOnBlock loc f on_block
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfMinus1RetryOnBlock loc f on_block
else if err == eWOULDBLOCK || err == eAGAIN
- then do on_block
+ then do on_block
else throwErrno loc
else return res
projects / ghc-base.git / blobdiff