X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=6cc8aaac298d144d546d5cb5881b12308d7d0af5;hb=bb534f206682be14daf72b33c6105ab27295c6ac;hp=bd0ce45d2907e483c96b9e770a5f57f56ed14bf6;hpb=f2ee01e06cc9a596f1495b6e675eae871bb27d94;p=ghc-base.git diff --git a/GHC/IO.hs b/GHC/IO.hs index bd0ce45..6cc8aaa 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -1,18 +1,26 @@ -{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-} #undef DEBUG_DUMP --- ----------------------------------------------------------------------------- --- $Id: IO.hs,v 1.5 2002/02/11 12:28:31 simonmar Exp $ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO +-- Copyright : (c) The University of Glasgow, 1992-2001 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable -- --- (c) The University of Glasgow, 1992-2001 +-- String I\/O functions -- +----------------------------------------------------------------------------- module GHC.IO ( hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, commitBuffer', -- hack, see below hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs - hGetBuf, hPutBuf, slurpFile, + hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile, memcpy_ba_baoff, memcpy_ptr_baoff, memcpy_baoff_ba, @@ -25,30 +33,44 @@ import Foreign.C import System.IO.Error import Data.Maybe import Control.Monad +import System.Posix.Internals import GHC.Enum import GHC.Base -import GHC.Posix import GHC.IOBase import GHC.Handle -- much of the real stuff is in here import GHC.Real import GHC.Num import GHC.Show import GHC.List -import GHC.Exception ( ioError, catch, throw ) +import GHC.Exception ( ioError, catch ) + +#ifdef mingw32_HOST_OS import GHC.Conc +#endif -- --------------------------------------------------------------------------- -- Simple input operations --- Computation "hReady hdl" indicates whether at least --- one item is available for input from handle "hdl". - -- If hWaitForInput finds anything in the Handle's buffer, it -- immediately returns. If not, it tries to read from the underlying -- OS handle. Notice that for buffered Handles connected to terminals -- this means waiting until a complete line is available. +-- | Computation 'hWaitForInput' @hdl t@ +-- waits until input is available on handle @hdl@. +-- It returns 'True' as soon as input is available on @hdl@, +-- or 'False' if no input is available within @t@ milliseconds. +-- +-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely. +-- NOTE: in the current implementation, this is the only case that works +-- correctly (if @t@ is non-zero, then all other concurrent threads are +-- blocked until data is available). +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + hWaitForInput :: Handle -> Int -> IO Bool hWaitForInput h msecs = do wantReadableHandle "hWaitForInput" h $ \ handle_ -> do @@ -59,18 +81,28 @@ hWaitForInput h msecs = do then return True else do - r <- throwErrnoIfMinus1Retry "hWaitForInput" - (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_)) - return (r /= 0) - -foreign import ccall unsafe "inputReady" + if msecs < 0 + then do buf' <- fillReadBuffer (haFD handle_) True + (haIsStream handle_) buf + writeIORef ref buf' + return True + else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $ + inputReady (fromIntegral (haFD handle_)) + (fromIntegral msecs) (haIsStream handle_) + return (r /= 0) + +foreign import ccall safe "inputReady" inputReady :: CInt -> CInt -> Bool -> IO CInt -- --------------------------------------------------------------------------- -- hGetChar --- hGetChar reads the next character from a handle, --- blocking until a character is available. +-- | Computation 'hGetChar' @hdl@ reads a character from the file or +-- channel managed by @hdl@, blocking until a character is available. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. hGetChar :: Handle -> IO Char hGetChar handle = @@ -90,14 +122,14 @@ hGetChar handle = new_buf <- fillReadBuffer fd True (haIsStream handle_) buf hGetcBuffered fd ref new_buf BlockBuffering _ -> do - new_buf <- fillReadBuffer fd False (haIsStream handle_) buf + new_buf <- fillReadBuffer fd True (haIsStream handle_) buf + -- ^^^^ + -- don't wait for a completely full buffer. hGetcBuffered fd ref new_buf NoBuffering -> do -- make use of the minimal buffer we already have let raw = bufBuf buf - r <- throwErrnoIfMinus1RetryMayBlock "hGetChar" - (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1) - (threadWaitRead fd) + r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1 if r == 0 then ioe_EOF else do (c,_) <- readCharFromBuffer raw 0 @@ -113,12 +145,21 @@ hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } -- --------------------------------------------------------------------------- -- hGetLine --- If EOF is reached before EOL is encountered, ignore the EOF and --- return the partial line. Next attempt at calling hGetLine on the --- handle will yield an EOF IO exception though. - -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for -- the duration. + +-- | Computation 'hGetLine' @hdl@ reads a line from the file or +-- channel managed by @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file is encountered when reading +-- the /first/ character of the line. +-- +-- If 'hGetLine' encounters end-of-file at any other point while reading +-- in a line, it is treated as a line terminator and the (partial) +-- line is returned. + hGetLine :: Handle -> IO String hGetLine h = do m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do @@ -160,10 +201,13 @@ hGetLineBufferedLoop handle_ ref #endif xs <- unpack raw r off + + -- if eol == True, then off is the offset of the '\n' + -- otherwise off == w and the buffer is now empty. if eol - then do if w == off + 1 - then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - else writeIORef ref buf{ bufRPtr = off + 1 } + then do if (w == off + 1) + then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } + else writeIORef ref buf{ bufRPtr = off + 1 } return (concat (reverse (xs:xss))) else do maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) @@ -171,10 +215,12 @@ hGetLineBufferedLoop handle_ ref case maybe_buf of -- Nothing indicates we caught an EOF, and we may have a -- partial line to return. - Nothing -> let str = concat (reverse (xs:xss)) in - if not (null str) - then return str - else ioe_EOF + Nothing -> do + writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } + let str = concat (reverse (xs:xss)) + if not (null str) + then return str + else ioe_EOF Just new_buf -> hGetLineBufferedLoop handle_ ref new_buf (xs:xss) @@ -186,7 +232,7 @@ maybeFillReadBuffer fd is_line is_stream buf ) (\e -> do if isEOFError e then return Nothing - else throw e) + else ioError e) unpack :: RawBuffer -> Int -> Int -> IO [Char] @@ -227,13 +273,38 @@ hGetLineUnBuffered h = do -- ----------------------------------------------------------------------------- -- hGetContents --- hGetContents returns the list of characters corresponding to the --- unread portion of the channel or file managed by the handle, which --- is made semi-closed. - -- hGetContents on a DuplexHandle only affects the read side: you can -- carry on writing to it afterwards. +-- | Computation 'hGetContents' @hdl@ returns the list of characters +-- corresponding to the unread portion of the channel or file managed +-- by @hdl@, which is put into an intermediate state, /semi-closed/. +-- In this state, @hdl@ is effectively closed, +-- but items are read from @hdl@ on demand and accumulated in a special +-- list returned by 'hGetContents' @hdl@. +-- +-- Any operation that fails because a handle is closed, +-- also fails if a handle is semi-closed. The only exception is 'hClose'. +-- A semi-closed handle becomes closed: +-- +-- * if 'hClose' is applied to it; +-- +-- * if an I\/O error occurs when reading an item from the handle; +-- +-- * or once the entire contents of the handle has been read. +-- +-- Once a semi-closed handle becomes closed, the contents of the +-- associated list becomes fixed. The contents of this final list is +-- only partially specified: it will contain at least all the items of +-- the stream that were evaluated prior to the handle becoming closed. +-- +-- Any I\/O errors encountered while a handle is semi-closed are simply +-- discarded. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + hGetContents :: Handle -> IO String hGetContents handle = withHandle "hGetContents" handle $ \handle_ -> @@ -275,9 +346,7 @@ lazyRead' h handle_ = do NoBuffering -> do -- make use of the minimal buffer we already have let raw = bufBuf buf - r <- throwErrnoIfMinus1RetryMayBlock "lazyRead" - (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1) - (threadWaitRead fd) + r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1 if r == 0 then do handle_ <- hClose_help handle_ return (handle_, "") @@ -308,7 +377,7 @@ lazyReadHaveBuffer h handle_ fd ref buf = do unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char] -unpackAcc buf r 0 acc = return "" +unpackAcc buf r 0 acc = return acc unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s where unpack acc i s @@ -320,9 +389,15 @@ unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s -- --------------------------------------------------------------------------- -- hPutChar --- `hPutChar hdl ch' writes the character `ch' to the file or channel --- managed by `hdl'. Characters may be buffered if buffering is --- enabled for `hdl'. +-- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the +-- file or channel managed by @hdl@. Characters may be buffered if +-- buffering is enabled for @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; or +-- +-- * 'isPermissionError' if another system resource limit would be exceeded. hPutChar :: Handle -> Char -> IO () hPutChar handle c = @@ -333,11 +408,9 @@ hPutChar handle c = LineBuffering -> hPutcBuffered handle_ True c BlockBuffering _ -> hPutcBuffered handle_ False c NoBuffering -> - withObject (castCharToCChar c) $ \buf -> - throwErrnoIfMinus1RetryMayBlock_ "hPutChar" - (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1) - (threadWaitWrite fd) - + with (castCharToCChar c) $ \buf -> do + writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1 + return () hPutcBuffered handle_ is_line c = do let ref = haBuffer handle_ @@ -360,9 +433,6 @@ hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs -- --------------------------------------------------------------------------- -- hPutStr --- `hPutStr hdl s' writes the string `s' to the file or --- hannel managed by `hdl', buffering the output if needs be. - -- We go to some trouble to avoid keeping the handle locked while we're -- evaluating the string argument to hPutStr, in case doing so triggers another -- I/O operation on the same handle which would lead to deadlock. The classic @@ -380,6 +450,15 @@ hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs -- maybe just swapping the buffers over (if the handle's buffer was -- empty). See commitBuffer below. +-- | Computation 'hPutStr' @hdl s@ writes the string +-- @s@ to the file or channel managed by @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; or +-- +-- * 'isPermissionError' if another system resource limit would be exceeded. + hPutStr :: Handle -> String -> IO () hPutStr handle str = do buffer_mode <- wantWritableHandle "hPutStr" handle @@ -482,7 +561,7 @@ commitBuffer commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do wantWritableHandle "commitAndReleaseBuffer" hdl $ - commitBuffer' hdl raw sz count flush release + commitBuffer' raw sz count flush release -- Explicitly lambda-lift this function to subvert GHC's full laziness -- optimisations, which otherwise tends to float out subexpressions @@ -495,7 +574,7 @@ commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do -- -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 -- -commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release +commitBuffer' raw sz@(I# _) count@(I# _) flush release handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do #ifdef DEBUG_DUMP @@ -564,120 +643,280 @@ commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release -- --------------------------------------------------------------------------- -- Reading/writing sequences of bytes. -{- -Semantics of hGetBuf: - - - hGetBuf reads data into the buffer until either - - (a) EOF is reached - (b) the buffer is full - - It returns the amount of data actually read. This may - be zero in case (a). hGetBuf never raises - an EOF exception, it always returns zero instead. - - If the handle is a pipe or socket, and the writing end - is closed, hGetBuf will behave as for condition (a). - -Semantics of hPutBuf: - - - hPutBuf writes data from the buffer to the handle - until the buffer is empty. It returns (). - - If the handle is a pipe or socket, and the reading end is - closed, hPutBuf will raise a ResourceVanished exception. - (If this is a POSIX system, and the program has not - asked to ignore SIGPIPE, then a SIGPIPE may be delivered - instead, whose default action is to terminate the program). --} - -- --------------------------------------------------------------------------- -- hPutBuf +-- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the +-- buffer @buf@ to the handle @hdl@. It returns (). +-- +-- This operation may fail with: +-- +-- * 'ResourceVanished' if the handle is a pipe or socket, and the +-- reading end is closed. (If this is a POSIX system, and the program +-- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered +-- instead, whose default action is to terminate the program). + hPutBuf :: Handle -- handle to write to -> Ptr a -- address of buffer -> Int -- number of bytes of data in buffer -> IO () -hPutBuf handle ptr count - | count <= 0 = illegalBufferSize handle "hPutBuf" count - | otherwise = - wantWritableHandle "hPutBuf" handle $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - - old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } - <- readIORef ref +hPutBuf h ptr count = do hPutBuf' h ptr count True; return () - -- enough room in handle buffer? - if (size - w > count) - -- There's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return () - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd is_stream old_buf - writeIORef ref flushed_buf - -- ToDo: should just memcpy instead of writing if possible - writeChunk fd ptr count +hPutBufNonBlocking + :: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> IO Int -- returns: number of bytes written +hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False -writeChunk :: FD -> Ptr a -> Int -> IO () -writeChunk fd ptr bytes = loop 0 bytes +hPutBuf':: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> Bool -- allow blocking? + -> IO Int +hPutBuf' handle ptr count can_block + | count == 0 = return 0 + | count < 0 = illegalBufferSize handle "hPutBuf" count + | otherwise = + wantWritableHandle "hPutBuf" handle $ + \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> + bufWrite fd ref is_stream ptr count can_block + +bufWrite fd ref is_stream ptr count can_block = + seq count $ seq fd $ do -- strictness hack + old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } + <- readIORef ref + + -- enough room in handle buffer? + if (size - w > count) + -- There's enough room in the buffer: + -- just copy the data in and update bufWPtr. + then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count) + writeIORef ref old_buf{ bufWPtr = w + count } + return count + + -- else, we have to flush + else do flushed_buf <- flushWriteBuffer fd is_stream old_buf + -- TODO: we should do a non-blocking flush here + writeIORef ref flushed_buf + -- if we can fit in the buffer, then just loop + if count < size + then bufWrite fd ref is_stream ptr count can_block + else if can_block + then do writeChunk fd is_stream (castPtr ptr) count + return count + else writeChunkNonBlocking fd is_stream ptr count + +writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO () +writeChunk fd is_stream ptr bytes = loop 0 bytes where loop :: Int -> Int -> IO () loop _ bytes | bytes <= 0 = return () loop off bytes = do r <- fromIntegral `liftM` - throwErrnoIfMinus1RetryMayBlock "writeChunk" - (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)) - (threadWaitWrite fd) + writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr + off (fromIntegral bytes) -- write can't return 0 loop (off + r) (bytes - r) +writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int +writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes + where + loop :: Int -> Int -> IO Int + loop off bytes | bytes <= 0 = return off + loop off bytes = do +#ifndef mingw32_HOST_OS + ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes) + let r = fromIntegral ssize :: Int + if (r == -1) + then do errno <- getErrno + if (errno == eAGAIN || errno == eWOULDBLOCK) + then return off + else throwErrno "writeChunk" + else loop (off + r) (bytes - r) +#else + (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream) + (fromIntegral bytes) + (ptr `plusPtr` off) + let r = fromIntegral ssize :: Int + if r == (-1) + then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing) + else loop (off + r) (bytes - r) +#endif + -- --------------------------------------------------------------------------- -- hGetBuf +-- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@ until either EOF is reached or +-- @count@ 8-bit bytes have been read. +-- It returns the number of bytes actually read. This may be zero if +-- EOF was reached before any data was read (or if @count@ is zero). +-- +-- 'hGetBuf' never raises an EOF exception, instead it returns a value +-- smaller than @count@. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBuf' will behave as if EOF was reached. + hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf handle ptr count - | count <= 0 = illegalBufferSize handle "hGetBuf" count +hGetBuf h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = - wantReadableHandle "hGetBuf" handle $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref - if bufferEmpty buf - then readChunk fd ptr count + wantReadableHandle "hGetBuf" h $ + \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do + bufRead fd ref is_stream ptr 0 count + +-- small reads go through the buffer, large reads are satisfied by +-- taking data first from the buffer and then direct from the file +-- descriptor. +bufRead fd ref is_stream ptr so_far count = + seq fd $ seq so_far $ seq count $ do -- strictness hack + buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref + if bufferEmpty buf + then if count > sz -- small read? + then do rest <- readChunk fd is_stream ptr count + return (so_far + rest) + else do mb_buf <- maybeFillReadBuffer fd True is_stream buf + case mb_buf of + Nothing -> return so_far -- got nothing, we're done + Just buf' -> do + writeIORef ref buf' + bufRead fd ref is_stream ptr so_far count + else do + let avail = w - r + if (count == avail) + then do + memcpy_ptr_baoff ptr raw r (fromIntegral count) + writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } + return (so_far + count) + else do + if (count < avail) + then do + memcpy_ptr_baoff ptr raw r (fromIntegral count) + writeIORef ref buf{ bufRPtr = r + count } + return (so_far + count) + else do + + memcpy_ptr_baoff ptr raw r (fromIntegral avail) + writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } + let remaining = count - avail + so_far' = so_far + avail + ptr' = ptr `plusPtr` avail + + if remaining < sz + then bufRead fd ref is_stream ptr' so_far' remaining else do - let avail = w - r - copied <- if (count >= avail) - then do - memcpy_ptr_baoff ptr raw r (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - return avail - else do - memcpy_ptr_baoff ptr raw r (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return count - - let remaining = count - copied - if remaining > 0 - then do rest <- readChunk fd (ptr `plusPtr` copied) remaining - return (rest + copied) - else return count - -readChunk :: FD -> Ptr a -> Int -> IO Int -readChunk fd ptr bytes = loop 0 bytes + + rest <- readChunk fd is_stream ptr' remaining + return (so_far' + rest) + +readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int +readChunk fd is_stream ptr bytes = loop 0 bytes where loop :: Int -> Int -> IO Int loop off bytes | bytes <= 0 = return off loop off bytes = do r <- fromIntegral `liftM` - throwErrnoIfMinus1RetryMayBlock "readChunk" - (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)) - (threadWaitRead fd) + readRawBufferPtr "readChunk" (fromIntegral fd) is_stream + (castPtr ptr) off (fromIntegral bytes) if r == 0 then return off else loop (off + r) (bytes - r) + +-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@ until either EOF is reached, or +-- @count@ 8-bit bytes have been read, or there is no more data available +-- to read immediately. +-- +-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will +-- never block waiting for data to become available, instead it returns +-- only whatever data is available. To wait for data to arrive before +-- calling 'hGetBufNonBlocking', use 'hWaitForInput'. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. +-- +hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int +hGetBufNonBlocking h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count + | otherwise = + wantReadableHandle "hGetBufNonBlocking" h $ + \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do + bufReadNonBlocking fd ref is_stream ptr 0 count + +bufReadNonBlocking fd ref is_stream ptr so_far count = + seq fd $ seq so_far $ seq count $ do -- strictness hack + buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref + if bufferEmpty buf + then if count > sz -- large read? + then do rest <- readChunkNonBlocking fd is_stream ptr count + return (so_far + rest) + else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf + case buf' of { Buffer{ bufWPtr=w } -> + if (w == 0) + then return so_far + else do writeIORef ref buf' + bufReadNonBlocking fd ref is_stream ptr + so_far (min count w) + -- NOTE: new count is 'min count w' + -- so we will just copy the contents of the + -- buffer in the recursive call, and not + -- loop again. + } + else do + let avail = w - r + if (count == avail) + then do + memcpy_ptr_baoff ptr raw r (fromIntegral count) + writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } + return (so_far + count) + else do + if (count < avail) + then do + memcpy_ptr_baoff ptr raw r (fromIntegral count) + writeIORef ref buf{ bufRPtr = r + count } + return (so_far + count) + else do + + memcpy_ptr_baoff ptr raw r (fromIntegral avail) + writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } + let remaining = count - avail + so_far' = so_far + avail + ptr' = ptr `plusPtr` avail + + -- we haven't attempted to read anything yet if we get to here. + if remaining < sz + then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining + else do + + rest <- readChunkNonBlocking fd is_stream ptr' remaining + return (so_far' + rest) + + +readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int +readChunkNonBlocking fd is_stream ptr bytes = do +#ifndef mingw32_HOST_OS + ssize <- c_read (fromIntegral fd) (castPtr ptr) (fromIntegral bytes) + let r = fromIntegral ssize :: Int + if (r == -1) + then do errno <- getErrno + if (errno == eAGAIN || errno == eWOULDBLOCK) + then return 0 + else throwErrno "readChunk" + else return r +#else + (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream) + (fromIntegral bytes) ptr + let r = fromIntegral ssize :: Int + if r == (-1) + then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing) + else return r +#endif + slurpFile :: FilePath -> IO (Ptr (), Int) slurpFile fname = do handle <- openFile fname ReadMode @@ -686,6 +925,7 @@ slurpFile fname = do ioError (userError "slurpFile: file too big") else do let sz_i = fromIntegral sz + if sz_i == 0 then return (nullPtr, 0) else do chunk <- mallocBytes sz_i r <- hGetBuf handle chunk sz_i hClose handle