X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=14a6696b74294d8e19ae94b3df6b796ea5313372;hb=7c0b04fd273621130062418bb764809c79488dd2;hp=d14df36055e7bddf9ac3a86f5b4eb2e4ed2477ee;hpb=8d4654930cec0fa2c2fa7568fee0c8a4a1074baa;p=haskell-directory.git diff --git a/GHC/IO.hs b/GHC/IO.hs index d14df36..14a6696 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-} #undef DEBUG_DUMP @@ -16,22 +16,18 @@ -- ----------------------------------------------------------------------------- +-- #hide module GHC.IO ( hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, commitBuffer', -- hack, see below hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile, -{- NOTE: As far as I can tell, not defined. - createPipe, createPipeEx, --} memcpy_ba_baoff, memcpy_ptr_baoff, memcpy_baoff_ba, memcpy_baoff_ptr, ) where -#include "config.h" - import Foreign import Foreign.C @@ -49,7 +45,10 @@ 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 @@ -64,9 +63,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 @@ -78,11 +84,17 @@ 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 (haFD handle_) + (fromIntegral msecs) (haIsStream handle_) + return (r /= 0) + +foreign import ccall safe "inputReady" inputReady :: CInt -> CInt -> Bool -> IO CInt -- --------------------------------------------------------------------------- @@ -120,7 +132,7 @@ hGetChar handle = 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 + r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1 if r == 0 then ioe_EOF else do (c,_) <- readCharFromBuffer raw 0 @@ -166,24 +178,25 @@ hGetLine h = do 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=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' in do (eol, off) <- loop raw r @@ -196,24 +209,24 @@ hGetLineBufferedLoop handle_ ref -- 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 is_line is_stream buf @@ -337,7 +350,7 @@ lazyRead' h handle_ = do 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 + r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1 if r == 0 then do handle_ <- hClose_help handle_ return (handle_, "") @@ -391,16 +404,16 @@ 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 + with (castCharToCChar c) $ \buf -> do + writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1 return () hPutcBuffered handle_ is_line c = do @@ -552,7 +565,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 @@ -565,7 +578,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 @@ -688,6 +701,7 @@ bufWrite fd ref is_stream ptr count can_block = -- 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 @@ -695,7 +709,7 @@ 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 ptr count + else writeChunkNonBlocking fd is_stream ptr count writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO () writeChunk fd is_stream ptr bytes = loop 0 bytes @@ -704,18 +718,19 @@ writeChunk fd is_stream ptr bytes = loop 0 bytes loop _ bytes | bytes <= 0 = return () loop off bytes = do r <- fromIntegral `liftM` - writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr + writeRawBufferPtr "writeChunk" fd is_stream ptr off (fromIntegral bytes) -- write can't return 0 loop (off + r) (bytes - r) -writeChunkNonBlocking :: FD -> Ptr a -> Int -> IO Int -writeChunkNonBlocking fd ptr bytes = loop 0 bytes +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 - ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes) +#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 @@ -723,6 +738,16 @@ writeChunkNonBlocking fd ptr bytes = loop 0 bytes 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 @@ -740,37 +765,32 @@ writeChunkNonBlocking fd ptr bytes = loop 0 bytes -- is closed, 'hGetBuf' will behave as if EOF was reached. hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf h ptr count = hGetBuf' h ptr count True - -hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int -hGetBufNonBlocking h ptr count = hGetBuf' h ptr count False - -hGetBuf' :: Handle -> Ptr a -> Int -> Bool -> IO Int -hGetBuf' handle ptr count can_block +hGetBuf h ptr count | count == 0 = return 0 - | count < 0 = illegalBufferSize handle "hGetBuf" count + | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = - wantReadableHandle "hGetBuf" handle $ + wantReadableHandle "hGetBuf" h $ \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - bufRead fd ref is_stream ptr 0 count can_block + bufRead fd ref is_stream ptr 0 count -bufRead fd ref is_stream ptr so_far count can_block = +-- 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 - then do - mb_buf <- maybeFillReadBuffer fd (not can_block) is_stream buf - case mb_buf of - Nothing -> return 0 - Just new_buf -> do - writeIORef ref new_buf - bufRead fd ref is_stream ptr so_far count can_block - else if can_block - then readChunk fd is_stream ptr count - else readChunkNonBlocking fd is_stream ptr count + 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 + let avail = w - r if (count == avail) then do memcpy_ptr_baoff ptr raw r (fromIntegral count) @@ -783,21 +803,18 @@ bufRead fd ref is_stream ptr so_far count can_block = 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 can_block + then bufRead fd ref is_stream ptr' so_far' remaining else do - rest <- if can_block - then readChunk fd is_stream ptr' remaining - else readChunkNonBlocking fd is_stream ptr' remaining + rest <- readChunk fd is_stream ptr' remaining return (so_far' + rest) readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int @@ -807,28 +824,104 @@ readChunk fd is_stream ptr bytes = loop 0 bytes loop off bytes | bytes <= 0 = return off loop off bytes = do r <- fromIntegral `liftM` - readRawBufferPtr "readChunk" (fromIntegral fd) is_stream + readRawBufferPtr "readChunk" 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 = loop 0 bytes - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do - ssize <- c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes) +readChunkNonBlocking fd is_stream ptr bytes = do +#ifndef mingw32_HOST_OS + ssize <- c_read fd (castPtr ptr) (fromIntegral bytes) let r = fromIntegral ssize :: Int if (r == -1) then do errno <- getErrno if (errno == eAGAIN || errno == eWOULDBLOCK) - then return off + then return 0 else throwErrno "readChunk" - else if (r == 0) - then return off - else loop (off + r) (bytes - r) + else return r +#else + fromIntegral `liftM` + readRawBufferPtr "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. +#endif slurpFile :: FilePath -> IO (Ptr (), Int) slurpFile fname = do