X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=6cc8aaac298d144d546d5cb5881b12308d7d0af5;hb=bb534f206682be14daf72b33c6105ab27295c6ac;hp=d14df36055e7bddf9ac3a86f5b4eb2e4ed2477ee;hpb=8d4654930cec0fa2c2fa7568fee0c8a4a1074baa;p=ghc-base.git diff --git a/GHC/IO.hs b/GHC/IO.hs index d14df36..6cc8aaa 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 @@ -21,17 +21,12 @@ module GHC.IO ( 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 +44,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,6 +62,11 @@ 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. +-- 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. @@ -78,11 +81,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 (fromIntegral (haFD handle_)) + (fromIntegral msecs) (haIsStream handle_) + return (r /= 0) + +foreign import ccall safe "inputReady" inputReady :: CInt -> CInt -> Bool -> IO CInt -- --------------------------------------------------------------------------- @@ -399,7 +408,7 @@ hPutChar handle c = LineBuffering -> hPutcBuffered handle_ True c BlockBuffering _ -> hPutcBuffered handle_ False c NoBuffering -> - withObject (castCharToCChar c) $ \buf -> do + with (castCharToCChar c) $ \buf -> do writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1 return () @@ -552,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 @@ -565,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 @@ -688,6 +697,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 +705,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 @@ -709,12 +719,13 @@ writeChunk fd is_stream ptr bytes = loop 0 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 +#ifndef mingw32_HOST_OS ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes) let r = fromIntegral ssize :: Int if (r == -1) @@ -723,6 +734,15 @@ writeChunkNonBlocking fd ptr bytes = loop 0 bytes 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 @@ -740,37 +760,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 +798,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 @@ -813,22 +825,97 @@ readChunk fd is_stream ptr bytes = loop 0 bytes 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 (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 off + then return 0 else throwErrno "readChunk" - else if (r == 0) - then return off - else loop (off + r) (bytes - r) + 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