X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=5cb0a401c88862407b2e2a22839c25d755ecb522;hb=fb80d56c0b7617261c93a808e9001bbb25a7562e;hp=fd06fc6a5b2898e59c359f2ae45e73fbb77c3c24;hpb=8dff2a318448b67a99627d54bbad1108010cb61e;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index fd06fc6..5cb0a40 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_HADDOCK hide #-} #undef DEBUG_DUMP #undef DEBUG @@ -21,11 +22,12 @@ 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 @@ -35,7 +37,7 @@ module GHC.Handle ( 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, @@ -55,27 +57,25 @@ module GHC.Handle ( ) 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 @@ -90,7 +90,7 @@ 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 @@ -102,7 +102,7 @@ dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool -- 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) @@ -124,8 +124,8 @@ operation: in these cases we also want to relinquish the lock. 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, @@ -139,15 +139,12 @@ withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act 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 @@ -158,15 +155,12 @@ withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a -withHandle_' fun h m act = +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 @@ -177,15 +171,12 @@ withAllHandles__ fun h@(DuplexHandle _ r w) act = do 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 () @@ -193,10 +184,10 @@ withHandle__' fun h m act = 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. @@ -209,27 +200,27 @@ wantWritableHandle fun h@(DuplexHandle _ _ m) act -- 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. @@ -242,79 +233,79 @@ wantReadableHandle fun h@(DuplexHandle _ m _) act -- 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 @@ -341,13 +332,13 @@ stdHandleFinalizer fp m = do 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) -- --------------------------------------------------------------------------- @@ -355,15 +346,15 @@ handleFinalizer fp m = do #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 () @@ -377,26 +368,20 @@ newEmptyBuffer b state size 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 @@ -422,8 +407,8 @@ flushWriteBufferOnly h_ = 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 @@ -454,7 +439,7 @@ flushReadBuffer fd buf puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") # endif throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek fd (fromIntegral off) sEEK_CUR) + (c_lseek fd (fromIntegral off) sEEK_CUR) return buf{ bufWPtr=0, bufRPtr=0 } flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer @@ -468,7 +453,7 @@ flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = then return (buf{ bufRPtr=0, bufWPtr=0 }) else do res <- writeRawBuffer "flushWriteBuffer" fd is_stream b - (fromIntegral r) (fromIntegral bytes) + (fromIntegral r) (fromIntegral bytes) let res' = fromIntegral res if res' < bytes then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' }) @@ -496,18 +481,18 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do 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 @@ -519,7 +504,7 @@ fillReadBufferWithoutBlocking fd is_stream 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") @@ -529,35 +514,120 @@ fillReadBufferWithoutBlocking fd is_stream -- 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 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 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 :: CInt -> RawBuffer -> Int -> CInt -> IO CInt @@ -571,6 +641,9 @@ foreign import ccall unsafe "__hscore_PrelHandle_write" 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 @@ -597,19 +670,21 @@ writeRawBufferPtr loc fd is_stream buf off len readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt 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 (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) off buf + (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 (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) (buf `plusPtr` off) + (fromIntegral len) (buf `plusPtr` off) if l == (-1) then ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) @@ -617,7 +692,7 @@ asyncReadRawBufferPtr loc fd is_stream buf off len = do asyncWriteRawBuffer loc fd is_stream buf off len = do (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) off buf + (fromIntegral len) off buf if l == (-1) then ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) @@ -625,7 +700,7 @@ asyncWriteRawBuffer loc fd is_stream buf off len = do asyncWriteRawBufferPtr loc fd is_stream buf off len = do (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) (buf `plusPtr` off) + (fromIntegral len) (buf `plusPtr` off) if l == (-1) then ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) @@ -635,62 +710,63 @@ asyncWriteRawBufferPtr loc fd is_stream buf off len = do 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 fd buf off len + safe_send_rawBuffer fd buf off len blockingWriteRawBuffer loc fd False buf off len = throwErrnoIfMinus1Retry loc $ - write_rawBuffer fd buf off len + safe_write_rawBuffer fd buf off len blockingWriteRawBufferPtr loc fd True buf off len = throwErrnoIfMinus1Retry loc $ - send_off fd buf off len + safe_send_off fd buf off len blockingWriteRawBufferPtr loc fd False buf off len = throwErrnoIfMinus1Retry loc $ - write_off 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 :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_read" - read_off :: CInt -> 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 :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_recv" - recv_off :: CInt -> 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 @@ -707,7 +783,9 @@ fd_stderr = 2 :: FD 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 "" ReadHandle buf bmode @@ -715,9 +793,9 @@ stdin = unsafePerformIO $ do 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 "" WriteHandle buf bmode @@ -725,9 +803,9 @@ stdout = unsafePerformIO $ do 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 "" WriteHandle buf NoBuffering @@ -789,18 +867,18 @@ openFile' filepath mode binary = 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 @@ -811,22 +889,22 @@ openFile' filepath mode binary = -- 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" - (c_open f (fromIntegral oflags) 0o666) + (c_open f (fromIntegral oflags) 0o666) - fd_type <- fdType fd + stat@(fd_type,_,_) <- fdStat fd - h <- openFd fd (Just fd_type) False filepath mode binary - `catchException` \e -> do c_close 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). + 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 - -- 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. + -- 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 fd 0) @@ -835,52 +913,6 @@ openFile' filepath mode binary = 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 fd Nothing False filepath ReadWriteMode True - `catchException` \e -> do c_close 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 @@ -889,82 +921,115 @@ rw_flags = output_flags .|. o_RDWR 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) + 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 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 - - 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 + 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 = "" - 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 @@ -976,50 +1041,50 @@ mkFileHandle fd is_stream filepath ha_type binary = do -- 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 + 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) @@ -1027,7 +1092,7 @@ mkDuplexHandle fd is_stream filepath binary = do initBufferState ReadHandle = ReadBuffer -initBufferState _ = WriteBuffer +initBufferState _ = WriteBuffer -- --------------------------------------------------------------------------- -- Closing a handle @@ -1036,46 +1101,66 @@ initBufferState _ = WriteBuffer -- 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_ -- 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_) fd) + (closeFd (haIsStream handle_) fd) #else - (c_close 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 @@ -1085,8 +1170,12 @@ hClose_handle_ handle_ = do -- 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 @@ -1098,14 +1187,14 @@ hFileSize :: Handle -> IO Integer 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. @@ -1114,12 +1203,12 @@ hSetFileSize :: Handle -> Integer -> IO () 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 (haFD handle_) (fromIntegral size)) - return () + throwErrnoIf (/=0) "hSetFileSize" + (c_ftruncate (haFD handle_) (fromIntegral size)) + return () -- --------------------------------------------------------------------------- -- Detecting the End of Input @@ -1128,6 +1217,9 @@ hSetFileSize handle size = -- '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 = @@ -1162,8 +1254,8 @@ hLookAhead handle = do -- fill up the read buffer if necessary new_buf <- if bufferEmpty buf - then fillReadBuffer fd True (haIsStream handle_) buf - else return buf + then fillReadBuffer fd True (haIsStream handle_) buf + else return buf writeIORef ref new_buf @@ -1199,49 +1291,49 @@ hSetBuffering handle mode = 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 () + 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 @@ -1262,9 +1354,9 @@ hFlush handle = 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 () -- ----------------------------------------------------------------------------- @@ -1277,7 +1369,7 @@ instance Eq HandlePosn where 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 @@ -1309,11 +1401,11 @@ hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i -- | 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: @@ -1356,8 +1448,8 @@ hSeek handle mode offset = fd = haFD handle_ let do_seek = - throwErrnoIfMinus1Retry_ "hSeek" - (c_lseek (haFD handle_) (fromIntegral offset) whence) + throwErrnoIfMinus1Retry_ "hSeek" + (c_lseek (haFD handle_) (fromIntegral offset) whence) whence :: CInt whence = case mode of @@ -1366,14 +1458,14 @@ hSeek handle mode offset = 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 @@ -1385,22 +1477,22 @@ hTell handle = 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 = 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") @@ -1420,14 +1512,14 @@ hIsOpen handle = 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: @@ -1444,18 +1536,18 @@ hIsReadable (DuplexHandle _ _ _) = return True 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@. @@ -1464,19 +1556,19 @@ hGetBuffering :: Handle -> IO BufferMode 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 || t == RawDevice) && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED)) @@ -1569,7 +1661,7 @@ dupHandleTo other_side hto_ h_ = do flushBuffer h_ -- Windows' dup2 does not return the new descriptor, unlike Unix throwErrnoIfMinus1 "dupHandleTo" $ - c_dup2 (haFD h_) (haFD hto_) + c_dup2 (haFD h_) (haFD hto_) dupHandle_ other_side h_ (haFD hto_) dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD @@ -1580,9 +1672,9 @@ dupHandle_ other_side h_ new_fd = do ioref_buffers <- newIORef BufferListNil let new_handle_ = h_{ haFD = new_fd, - haBuffer = ioref, - haBuffers = ioref_buffers, - haOtherSide = other_side } + haBuffer = ioref, + haBuffers = ioref_buffers, + haOtherSide = other_side } return (h_, new_handle_) -- ----------------------------------------------------------------------------- @@ -1612,7 +1704,7 @@ hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do 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. @@ -1628,15 +1720,15 @@ showHandle' filepath is_duplex h = 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 @@ -1644,15 +1736,15 @@ showHandle' filepath is_duplex h = 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 @@ -1663,7 +1755,7 @@ showHandle' filepath is_duplex h = #if defined(DEBUG_DUMP) puts :: String -> IO () puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s)) - return () + return () #endif -- ----------------------------------------------------------------------------- @@ -1675,11 +1767,11 @@ throwErrnoIfMinus1RetryOnBlock loc f on_block = 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