X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=e73b592f4306ed9acd025f0084bc7077a3c5cd1e;hb=9875b3cf1ada084cfa3e6c516b11e946f1d6234e;hp=1dee43aaf58d88fc00d24b92e267babd20f85f9c;hpb=b72dda8318394f238214364dc01b8963599f8cd6;p=ghc-base.git diff --git a/GHC/IO.hs b/GHC/IO.hs index 1dee43a..e73b592 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_HADDOCK hide #-} #undef DEBUG_DUMP @@ -16,11 +17,12 @@ -- ----------------------------------------------------------------------------- +-- #hide module GHC.IO ( hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, - commitBuffer', -- hack, see below - hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs - hGetBuf, hPutBuf, slurpFile, + commitBuffer', -- hack, see below + hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs + hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile, memcpy_ba_baoff, memcpy_ptr_baoff, memcpy_baoff_ba, @@ -33,18 +35,22 @@ import Foreign.C import System.IO.Error import Data.Maybe import Control.Monad +#ifndef mingw32_HOST_OS import System.Posix.Internals +#endif import GHC.Enum import GHC.Base import GHC.IOBase -import GHC.Handle -- much of the real stuff is in here +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 ) + +#ifdef mingw32_HOST_OS import GHC.Conc +#endif -- --------------------------------------------------------------------------- -- Simple input operations @@ -59,9 +65,16 @@ import GHC.Conc -- 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. +-- -- This operation may fail with: -- -- * 'isEOFError' if the end of file has been reached. +-- +-- NOTE for GHC users: unless you use the @-threaded@ flag, +-- @hWaitForInput t@ where @t >= 0@ will block all other Haskell +-- threads for the duration of the call. It behaves like a +-- @safe@ foreign call in this respect. hWaitForInput :: Handle -> Int -> IO Bool hWaitForInput h msecs = do @@ -70,15 +83,26 @@ hWaitForInput h msecs = do buf <- readIORef ref if not (bufferEmpty buf) - then return True - else do - - r <- throwErrnoIfMinus1Retry "hWaitForInput" - (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_)) - return (r /= 0) - -foreign import ccall unsafe "inputReady" - inputReady :: CInt -> CInt -> Bool -> IO CInt + then return True + else do + + if msecs < 0 + then do buf' <- fillReadBuffer (haFD handle_) True + (haIsStream handle_) buf + writeIORef ref buf' + return True + else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $ + fdReady (haFD handle_) 0 {- read -} + (fromIntegral msecs) + (fromIntegral $ fromEnum $ haIsStream handle_) + if r /= 0 then do -- Call hLookAhead' to throw an EOF + -- exception if appropriate + hLookAhead' handle_ + return True + else return False + +foreign import ccall safe "fdReady" + fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt -- --------------------------------------------------------------------------- -- hGetChar @@ -99,32 +123,33 @@ hGetChar handle = buf <- readIORef ref if not (bufferEmpty buf) - then hGetcBuffered fd ref buf - else do + then hGetcBuffered fd ref buf + else do -- buffer is empty. case haBufferMode handle_ of LineBuffering -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - hGetcBuffered fd ref new_buf + new_buf <- fillReadBuffer fd True (haIsStream handle_) buf + hGetcBuffered fd ref new_buf BlockBuffering _ -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - -- ^^^^ - -- don't wait for a completely full buffer. - hGetcBuffered fd ref new_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 <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1 - if r == 0 - then ioe_EOF - else do (c,_) <- readCharFromBuffer raw 0 - return c - -hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } - = do (c,r) <- readCharFromBuffer b r + -- make use of the minimal buffer we already have + let raw = bufBuf buf + r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1 + if r == 0 + then ioe_EOF + else do (c,_) <- readCharFromBuffer raw 0 + return c + +hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char +hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w } + = do (c, r) <- readCharFromBuffer b r0 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 } - | otherwise = buf{ bufRPtr=r } + | otherwise = buf{ bufRPtr=r } writeIORef ref new_buf return c @@ -149,87 +174,88 @@ hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } hGetLine :: Handle -> IO String hGetLine h = do m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do - case haBufferMode handle_ of - NoBuffering -> return Nothing - LineBuffering -> do - l <- hGetLineBuffered handle_ - return (Just l) - BlockBuffering _ -> do - l <- hGetLineBuffered handle_ - return (Just l) + case haBufferMode handle_ of + NoBuffering -> return Nothing + LineBuffering -> do + l <- hGetLineBuffered handle_ + return (Just l) + BlockBuffering _ -> do + l <- hGetLineBuffered handle_ + return (Just l) case m of - Nothing -> hGetLineUnBuffered h - Just l -> return l - + Nothing -> hGetLineUnBuffered h + Just l -> return l +hGetLineBuffered :: Handle__ -> IO String hGetLineBuffered handle_ = do let ref = haBuffer handle_ buf <- readIORef ref hGetLineBufferedLoop handle_ ref buf [] - -hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss = - let - -- find the end-of-line character, if there is one - loop raw r - | r == w = return (False, w) - | otherwise = do - (c,r') <- readCharFromBuffer raw r - if c == '\n' - then return (True, r) -- NB. not r': don't include the '\n' - else loop raw r' +hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String] + -> IO String +hGetLineBufferedLoop handle_ ref + buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=raw0 } xss = + let + -- find the end-of-line character, if there is one + loop raw r + | r == w = return (False, w) + | otherwise = do + (c,r') <- readCharFromBuffer raw r + if c == '\n' + then return (True, r) -- NB. not r': don't include the '\n' + else loop raw r' in do - (eol, off) <- loop raw r + (eol, off) <- loop raw0 r0 #ifdef DEBUG_DUMP - puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") + puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") #endif - xs <- unpack raw r off + xs <- unpack raw0 r0 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 } - return (concat (reverse (xs:xss))) - else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) - buf{ bufWPtr=0, bufRPtr=0 } - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - 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) - - + 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_) + buf{ bufWPtr=0, bufRPtr=0 } + case maybe_buf of + -- Nothing indicates we caught an EOF, and we may have a + -- partial line to return. + 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) + +maybeFillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO (Maybe Buffer) maybeFillReadBuffer fd is_line is_stream buf = catch - (do buf <- fillReadBuffer fd is_line is_stream buf - return (Just buf) + (do buf' <- fillReadBuffer fd is_line is_stream buf + return (Just buf') ) (\e -> do if isEOFError e - then return Nothing - else ioError e) + then return Nothing + else ioError e) unpack :: RawBuffer -> Int -> Int -> IO [Char] -unpack buf r 0 = return "" -unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s +unpack _ _ 0 = return "" +unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s where - unpack acc i s + unpackRB acc i s | i <# r = (# s, acc #) | otherwise = case readCharArray# buf i s of - (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s + (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' hGetLineUnBuffered :: Handle -> IO String @@ -247,9 +273,9 @@ hGetLineUnBuffered h = do (hGetChar h) (\ err -> do if isEOFError err then - return '\n' - else - ioError err) + return '\n' + else + ioError err) if c == '\n' then return "" else do @@ -295,12 +321,12 @@ hGetContents :: Handle -> IO String hGetContents handle = withHandle "hGetContents" handle $ \handle_ -> case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> ioe_notReadable + WriteHandle -> ioe_notReadable _ -> do xs <- lazyRead handle - return (handle_{ haType=SemiClosedHandle}, xs ) + return (handle_{ haType=SemiClosedHandle}, xs ) -- Note that someone may close the semi-closed handle (or change its -- buffering), so each time these lazy read functions are pulled on, @@ -309,14 +335,15 @@ hGetContents handle = lazyRead :: Handle -> IO String lazyRead handle = unsafeInterleaveIO $ - withHandle "lazyRead" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return (handle_, "") - SemiClosedHandle -> lazyRead' handle handle_ - _ -> ioException - (IOError (Just handle) IllegalOperation "lazyRead" - "illegal handle type" Nothing) - + withHandle "lazyRead" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> return (handle_, "") + SemiClosedHandle -> lazyRead' handle handle_ + _ -> ioException + (IOError (Just handle) IllegalOperation "lazyRead" + "illegal handle type" Nothing) + +lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyRead' h handle_ = do let ref = haBuffer handle_ fd = haFD handle_ @@ -325,37 +352,40 @@ lazyRead' h handle_ = do -- (see hLookAhead) buf <- readIORef ref if not (bufferEmpty buf) - then lazyReadHaveBuffer h handle_ fd ref buf - else do + then lazyReadHaveBuffer h handle_ fd ref buf + else do case haBufferMode handle_ of NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1 - if r == 0 - then do handle_ <- hClose_help handle_ - return (handle_, "") - else do (c,_) <- readCharFromBuffer raw 0 - rest <- lazyRead h - return (handle_, c : rest) + -- make use of the minimal buffer we already have + let raw = bufBuf buf + r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1 + if r == 0 + then do (handle_', _) <- hClose_help handle_ + return (handle_', "") + else do (c,_) <- readCharFromBuffer raw 0 + rest <- lazyRead h + return (handle_, c : rest) LineBuffering -> lazyReadBuffered h handle_ fd ref buf BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf -- we never want to block during the read, so we call fillReadBuffer with -- is_line==True, which tells it to "just read what there is". +lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer + -> IO (Handle__, [Char]) lazyReadBuffered h handle_ fd ref buf = do catch - (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf - lazyReadHaveBuffer h handle_ fd ref buf - ) - -- all I/O errors are discarded. Additionally, we close the handle. - (\e -> do handle_ <- hClose_help handle_ - return (handle_, "") - ) - -lazyReadHaveBuffer h handle_ fd ref buf = do + (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf + lazyReadHaveBuffer h handle_ fd ref buf' + ) + -- all I/O errors are discarded. Additionally, we close the handle. + (\_ -> do (handle_', _) <- hClose_help handle_ + return (handle_', "") + ) + +lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char]) +lazyReadHaveBuffer h handle_ _ ref buf = do more <- lazyRead h writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more @@ -363,14 +393,14 @@ lazyReadHaveBuffer h handle_ fd ref buf = do unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char] -unpackAcc buf r 0 acc = return acc -unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s +unpackAcc _ _ 0 acc = return acc +unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s where - unpack acc i s + unpackRB acc i s | i <# r = (# s, acc #) | otherwise = case readCharArray# buf i s of - (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s + (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' -- --------------------------------------------------------------------------- -- hPutChar @@ -386,18 +416,19 @@ unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s -- * 'isPermissionError' if another system resource limit would be exceeded. hPutChar :: Handle -> Char -> IO () -hPutChar handle c = - c `seq` do -- must evaluate c before grabbing the handle lock +hPutChar handle c = do + c `seq` return () wantWritableHandle "hPutChar" handle $ \ handle_ -> do let fd = haFD handle_ case haBufferMode handle_ of - LineBuffering -> hPutcBuffered handle_ True c - BlockBuffering _ -> hPutcBuffered handle_ False c - NoBuffering -> - withObject (castCharToCChar c) $ \buf -> do - writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1 - return () - + LineBuffering -> hPutcBuffered handle_ True c + BlockBuffering _ -> hPutcBuffered handle_ False c + NoBuffering -> + with (castCharToCChar c) $ \buf -> do + writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1 + return () + +hPutcBuffered :: Handle__ -> Bool -> Char -> IO () hPutcBuffered handle_ is_line c = do let ref = haBuffer handle_ buf <- readIORef ref @@ -406,14 +437,14 @@ hPutcBuffered handle_ is_line c = do let new_buf = buf{ bufWPtr = w' } if bufferFull new_buf || is_line && c == '\n' then do - flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf - writeIORef ref flushed_buf + flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf + writeIORef ref flushed_buf else do - writeIORef ref new_buf + writeIORef ref new_buf hPutChars :: Handle -> [Char] -> IO () -hPutChars handle [] = return () +hPutChars _ [] = return () hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs -- --------------------------------------------------------------------------- @@ -424,12 +455,12 @@ hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs -- I/O operation on the same handle which would lead to deadlock. The classic -- case is -- --- putStr (trace "hello" "world") +-- putStr (trace "hello" "world") -- -- so the basic scheme is this: -- --- * copy the string into a fresh buffer, --- * "commit" the buffer to the handle. +-- * copy the string into a fresh buffer, +-- * "commit" the buffer to the handle. -- -- Committing may involve simply copying the contents of the new -- buffer into the handle's buffer, flushing one or both buffers, or @@ -448,48 +479,48 @@ hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs hPutStr :: Handle -> String -> IO () hPutStr handle str = do buffer_mode <- wantWritableHandle "hPutStr" handle - (\ handle_ -> do getSpareBuffer handle_) + (\ handle_ -> do getSpareBuffer handle_) case buffer_mode of (NoBuffering, _) -> do - hPutChars handle str -- v. slow, but we don't care + hPutChars handle str -- v. slow, but we don't care (LineBuffering, buf) -> do - writeLines handle buf str + writeLines handle buf str (BlockBuffering _, buf) -> do writeBlocks handle buf str getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer) getSpareBuffer Handle__{haBuffer=ref, - haBuffers=spare_ref, - haBufferMode=mode} + haBuffers=spare_ref, + haBufferMode=mode} = do case mode of NoBuffering -> return (mode, error "no buffer!") _ -> do bufs <- readIORef spare_ref - buf <- readIORef ref - case bufs of - BufferListCons b rest -> do - writeIORef spare_ref rest - return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf)) - BufferListNil -> do - new_buf <- allocateBuffer (bufSize buf) WriteBuffer - return (mode, new_buf) + buf <- readIORef ref + case bufs of + BufferListCons b rest -> do + writeIORef spare_ref rest + return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf)) + BufferListNil -> do + new_buf <- allocateBuffer (bufSize buf) WriteBuffer + return (mode, new_buf) writeLines :: Handle -> Buffer -> String -> IO () writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s = let shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. + -- check n == len first, to ensure that shoveString is strict in n. shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeLines hdl new_buf cs + new_buf <- commitBuffer hdl raw len n True{-needs flush-} False + writeLines hdl new_buf cs shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () + commitBuffer hdl raw len n False{-no flush-} True{-release-} + return () shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c + n' <- writeCharIntoBuffer raw n c if (c == '\n') then do new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False @@ -503,16 +534,16 @@ writeBlocks :: Handle -> Buffer -> String -> IO () writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s = let shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. + -- check n == len first, to ensure that shoveString is strict in n. shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeBlocks hdl new_buf cs + new_buf <- commitBuffer hdl raw len n True{-needs flush-} False + writeBlocks hdl new_buf cs shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () + commitBuffer hdl raw len n False{-no flush-} True{-release-} + return () shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - shoveString n' cs + n' <- writeCharIntoBuffer raw n c + shoveString n' cs in shoveString 0 s @@ -525,29 +556,29 @@ writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s = -- Implementation: -- -- for block/line buffering, --- 1. If there isn't room in the handle buffer, flush the handle --- buffer. +-- 1. If there isn't room in the handle buffer, flush the handle +-- buffer. -- --- 2. If the handle buffer is empty, --- if flush, --- then write buf directly to the device. --- else swap the handle buffer with buf. +-- 2. If the handle buffer is empty, +-- if flush, +-- then write buf directly to the device. +-- else swap the handle buffer with buf. -- --- 3. If the handle buffer is non-empty, copy buf into the --- handle buffer. Then, if flush != 0, flush --- the buffer. +-- 3. If the handle buffer is non-empty, copy buf into the +-- handle buffer. Then, if flush != 0, flush +-- the buffer. commitBuffer - :: Handle -- handle to commit to - -> RawBuffer -> Int -- address and size (in bytes) of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- True <=> flush the handle afterward - -> Bool -- release the buffer? - -> IO Buffer + :: Handle -- handle to commit to + -> RawBuffer -> Int -- address and size (in bytes) of buffer + -> Int -- number of bytes of data in buffer + -> Bool -- True <=> flush the handle afterward + -> Bool -- release the buffer? + -> IO Buffer 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 @@ -560,71 +591,73 @@ 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' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__ + -> IO Buffer +commitBuffer' raw sz@(I# _) count@(I# _) flush release handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do #ifdef DEBUG_DUMP puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count - ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n") + ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n") #endif - old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } - <- readIORef ref + old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size } + <- readIORef ref buf_ret <- -- enough room in handle buffer? - if (not flush && (size - w > count)) - -- The > is to be sure that we never exactly fill - -- up the buffer, which would require a flush. So - -- if copying the new data into the buffer would - -- make the buffer full, we just flush the existing - -- buffer and the new data immediately, rather than - -- copying before flushing. - - -- not flushing, and there's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ba old_raw w raw (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return (newEmptyBuffer raw WriteBuffer sz) - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf - - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=sz } - - -- if: (a) we don't have to flush, and - -- (b) size(new buffer) == size(old buffer), and - -- (c) new buffer is not full, - -- we can just just swap them over... - if (not flush && sz == size && count /= sz) - then do - writeIORef ref this_buf - return flushed_buf - - -- otherwise, we have to flush the new data too, - -- and start with a fresh buffer - else do - flushWriteBuffer fd (haIsStream handle_) this_buf - writeIORef ref flushed_buf - -- if the sizes were different, then allocate - -- a new buffer of the correct size. - if sz == size - then return (newEmptyBuffer raw WriteBuffer sz) - else allocateBuffer size WriteBuffer + if (not flush && (size - w > count)) + -- The > is to be sure that we never exactly fill + -- up the buffer, which would require a flush. So + -- if copying the new data into the buffer would + -- make the buffer full, we just flush the existing + -- buffer and the new data immediately, rather than + -- copying before flushing. + + -- not flushing, and there's enough room in the buffer: + -- just copy the data in and update bufWPtr. + then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count) + writeIORef ref old_buf{ bufWPtr = w + count } + return (newEmptyBuffer raw WriteBuffer sz) + + -- else, we have to flush + else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf + + let this_buf = + Buffer{ bufBuf=raw, bufState=WriteBuffer, + bufRPtr=0, bufWPtr=count, bufSize=sz } + + -- if: (a) we don't have to flush, and + -- (b) size(new buffer) == size(old buffer), and + -- (c) new buffer is not full, + -- we can just just swap them over... + if (not flush && sz == size && count /= sz) + then do + writeIORef ref this_buf + return flushed_buf + + -- otherwise, we have to flush the new data too, + -- and start with a fresh buffer + else do + flushWriteBuffer fd (haIsStream handle_) this_buf + writeIORef ref flushed_buf + -- if the sizes were different, then allocate + -- a new buffer of the correct size. + if sz == size + then return (newEmptyBuffer raw WriteBuffer sz) + else allocateBuffer size WriteBuffer -- release the buffer if necessary case buf_ret of Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do if release && buf_ret_sz == size - then do - spare_bufs <- readIORef spare_buf_ref - writeIORef spare_buf_ref - (BufferListCons buf_ret_raw spare_bufs) - return buf_ret - else - return buf_ret + then do + spare_bufs <- readIORef spare_buf_ref + writeIORef spare_buf_ref + (BufferListCons buf_ret_raw spare_bufs) + return buf_ret + else + return buf_ret -- --------------------------------------------------------------------------- -- Reading/writing sequences of bytes. @@ -642,46 +675,102 @@ commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release -- 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 = return () +hPutBuf :: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> IO () +hPutBuf h ptr count = do hPutBuf' h ptr count True; return () + +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 + +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 } -> do - - 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 () - - -- 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 is_stream (castPtr ptr) count + \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> + bufWrite fd ref is_stream ptr count can_block + +bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int +bufWrite fd ref is_stream ptr count can_block = + seq count $ seq fd $ do -- strictness hack + old_buf@Buffer{ bufBuf=old_raw, 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 (fromIntegral 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 +writeChunk fd is_stream ptr bytes0 = loop 0 bytes0 where loop :: Int -> Int -> IO () loop _ bytes | bytes <= 0 = return () loop off bytes = do r <- fromIntegral `liftM` - writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr - off (fromIntegral bytes) + writeRawBufferPtr "writeChunk" 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 +#ifndef mingw32_HOST_OS + _ +#else + is_stream +#endif + ptr bytes0 = loop 0 bytes0 + where + loop :: Int -> Int -> IO Int + loop off bytes | bytes <= 0 = return off + loop off bytes = do +#ifndef mingw32_HOST_OS + ssize <- c_write 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 (fromIntegral 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 @@ -698,45 +787,155 @@ writeChunk fd is_stream ptr bytes = loop 0 bytes -- is closed, 'hGetBuf' will behave as if EOF was reached. hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf handle ptr count +hGetBuf h ptr count | count == 0 = return 0 - | count < 0 = illegalBufferSize handle "hGetBuf" count + | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = - wantReadableHandle "hGetBuf" handle $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref - if bufferEmpty buf - then readChunk fd is_stream ptr count - 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 is_stream (ptr `plusPtr` copied) remaining - return (rest + copied) - else return count - + wantReadableHandle "hGetBuf" h $ + \ 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 -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int +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 (fromIntegral 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 (fromIntegral r) (fromIntegral count) + writeIORef ref buf{ bufRPtr = r + count } + return (so_far + count) + else do + + memcpy_ptr_baoff ptr raw (fromIntegral 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 + + 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 +readChunk fd is_stream ptr bytes0 = loop 0 bytes0 where loop :: Int -> Int -> IO Int loop off bytes | bytes <= 0 = return off loop off bytes = do r <- fromIntegral `liftM` - readRawBufferPtr "readChunk" (fromIntegral fd) is_stream - (castPtr ptr) off (fromIntegral bytes) + readRawBufferPtr "readChunk" fd is_stream + (castPtr ptr) off (fromIntegral bytes) if r == 0 - then return off - else loop (off + r) (bytes - r) + 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__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do + bufReadNonBlocking fd ref is_stream ptr 0 count + +bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int + -> IO Int +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 (fromIntegral 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 (fromIntegral r) (fromIntegral count) + writeIORef ref buf{ bufRPtr = r + count } + return (so_far + count) + else do + + memcpy_ptr_baoff ptr raw (fromIntegral 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 + fromIntegral `liftM` + readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream + (castPtr ptr) 0 (fromIntegral bytes) + + -- we don't have non-blocking read support on Windows, so just invoke + -- the ordinary low-level read which will block until data is available, + -- but won't wait for the whole buffer to fill. slurpFile :: FilePath -> IO (Ptr (), Int) slurpFile fname = do @@ -756,20 +955,20 @@ slurpFile fname = do -- memcpy wrappers foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ()) + memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ()) + memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ()) + memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ()) foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ()) + memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ()) ----------------------------------------------------------------------------- -- Internal Utils illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn (sz :: Int) = - ioException (IOError (Just handle) - InvalidArgument fn - ("illegal buffer size " ++ showsPrec 9 sz []) - Nothing) +illegalBufferSize handle fn sz = + ioException (IOError (Just handle) + InvalidArgument fn + ("illegal buffer size " ++ showsPrec 9 sz []) + Nothing)