X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=14a6696b74294d8e19ae94b3df6b796ea5313372;hb=7c0b04fd273621130062418bb764809c79488dd2;hp=aa4c0c8f7edb9bd9903c01ae085d4a46c541b211;hpb=ec3ba94b254bd444e7a1c560c1d91c4879948c69;p=haskell-directory.git diff --git a/GHC/IO.hs b/GHC/IO.hs index aa4c0c8..14a6696 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -16,6 +16,7 @@ -- ----------------------------------------------------------------------------- +-- #hide module GHC.IO ( hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, commitBuffer', -- hack, see below @@ -27,8 +28,6 @@ module GHC.IO ( memcpy_baoff_ptr, ) where -#include "ghcconfig.h" - import Foreign import Foreign.C @@ -65,13 +64,15 @@ import GHC.Conc -- 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. +-- +-- 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 @@ -89,7 +90,7 @@ hWaitForInput h msecs = do writeIORef ref buf' return True else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $ - inputReady (fromIntegral (haFD handle_)) + inputReady (haFD handle_) (fromIntegral msecs) (haIsStream handle_) return (r /= 0) @@ -131,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 @@ -177,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 @@ -207,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 @@ -348,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_, "") @@ -402,8 +404,8 @@ 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 @@ -411,7 +413,7 @@ hPutChar handle c = BlockBuffering _ -> hPutcBuffered handle_ False c NoBuffering -> with (castCharToCChar c) $ \buf -> do - writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1 + writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1 return () hPutcBuffered handle_ is_line c = do @@ -716,7 +718,7 @@ 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) @@ -728,7 +730,7 @@ writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes 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) + ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes) let r = fromIntegral ssize :: Int if (r == -1) then do errno <- getErrno @@ -737,7 +739,8 @@ writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes else throwErrno "writeChunk" else loop (off + r) (bytes - r) #else - (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream) + (ssize, rc) <- asyncWrite (fromIntegral fd) + (fromIntegral $ fromEnum is_stream) (fromIntegral bytes) (ptr `plusPtr` off) let r = fromIntegral ssize :: Int @@ -821,7 +824,7 @@ 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 @@ -902,7 +905,7 @@ bufReadNonBlocking fd ref is_stream ptr so_far count = 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) + ssize <- c_read fd (castPtr ptr) (fromIntegral bytes) let r = fromIntegral ssize :: Int if (r == -1) then do errno <- getErrno @@ -911,12 +914,13 @@ readChunkNonBlocking fd is_stream ptr bytes = do 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 + 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)