{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} {-# OPTIONS_HADDOCK hide #-} #undef DEBUG_DUMP ----------------------------------------------------------------------------- -- | -- 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 -- -- String I\/O functions -- ----------------------------------------------------------------------------- -- #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, memcpy_ba_baoff, memcpy_ptr_baoff, memcpy_baoff_ba, memcpy_baoff_ptr, ) where import Foreign 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.Real import GHC.Num import GHC.Show import GHC.List #ifdef mingw32_HOST_OS import GHC.Conc #endif -- --------------------------------------------------------------------------- -- Simple input operations -- 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. -- -- 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 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do let ref = haBuffer handle_ buf <- readIORef ref if not (bufferEmpty buf) 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 -- | 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 = wantReadableHandle "hGetChar" handle $ \handle_ -> do let fd = haFD handle_ ref = haBuffer handle_ buf <- readIORef ref if not (bufferEmpty buf) 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 BlockBuffering _ -> do 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" 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 } writeIORef ref new_buf return c -- --------------------------------------------------------------------------- -- hGetLine -- 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 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 hGetLineBuffered :: Handle__ -> IO String hGetLineBuffered handle_ = do let ref = haBuffer handle_ buf <- readIORef ref hGetLineBufferedLoop handle_ ref buf [] 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 raw0 r0 #ifdef DEBUG_DUMP puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") #endif 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) 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') ) (\e -> do if isEOFError e then return Nothing else ioError e) unpack :: RawBuffer -> Int -> Int -> IO [Char] unpack _ _ 0 = return "" unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s where unpackRB acc i s | i <# r = (# s, acc #) | otherwise = case readCharArray# buf i s of (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' hGetLineUnBuffered :: Handle -> IO String hGetLineUnBuffered h = do c <- hGetChar h if c == '\n' then return "" else do l <- getRest return (c:l) where getRest = do c <- catch (hGetChar h) (\ err -> do if isEOFError err then return '\n' else ioError err) if c == '\n' then return "" else do s <- getRest return (c:s) -- ----------------------------------------------------------------------------- -- hGetContents -- 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_ -> case haType handle_ of ClosedHandle -> ioe_closedHandle SemiClosedHandle -> ioe_closedHandle AppendHandle -> ioe_notReadable WriteHandle -> ioe_notReadable _ -> do xs <- lazyRead handle 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, -- they have to check whether the handle has indeed been closed. 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) lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyRead' h handle_ = do let ref = haBuffer handle_ fd = haFD handle_ -- even a NoBuffering handle can have a char in the buffer... -- (see hLookAhead) buf <- readIORef ref if not (bufferEmpty buf) 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" 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. (\_ -> 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 return (handle_, s) unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char] unpackAcc _ _ 0 acc = return acc unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s where unpackRB acc i s | i <# r = (# s, acc #) | otherwise = case readCharArray# buf i s of (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' -- --------------------------------------------------------------------------- -- hPutChar -- | 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 = 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 -> 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 let w = bufWPtr buf w' <- writeCharIntoBuffer (bufBuf buf) w c 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 else do writeIORef ref new_buf hPutChars :: Handle -> [Char] -> IO () hPutChars _ [] = return () hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs -- --------------------------------------------------------------------------- -- hPutStr -- 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 -- case is -- -- putStr (trace "hello" "world") -- -- so the basic scheme is this: -- -- * 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 -- 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 (\ handle_ -> do getSpareBuffer handle_) case buffer_mode of (NoBuffering, _) -> do hPutChars handle str -- v. slow, but we don't care (LineBuffering, buf) -> do 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} = 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) 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. shoveString n cs | n == len = do 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 () shoveString n (c:cs) = do n' <- writeCharIntoBuffer raw n c if (c == '\n') then do new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False writeLines hdl new_buf cs else shoveString n' cs in shoveString 0 s 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. shoveString n cs | n == len = do 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 () shoveString n (c:cs) = do n' <- writeCharIntoBuffer raw n c shoveString n' cs in shoveString 0 s -- ----------------------------------------------------------------------------- -- commitBuffer handle buf sz count flush release -- -- Write the contents of the buffer 'buf' ('sz' bytes long, containing -- 'count' bytes of data) to handle (handle must be block or line buffered). -- -- Implementation: -- -- for block/line buffering, -- 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. -- -- 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 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do wantWritableHandle "commitAndReleaseBuffer" hdl $ 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 -- past the \handle, which is really a pessimisation in this case because -- that lambda is a one-shot lambda. -- -- Don't forget to export the function, to stop it being inlined too -- (this appears to be better than NOINLINE, because the strictness -- analyser still gets to worker-wrapper it). -- -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 -- 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") #endif 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 (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 -- --------------------------------------------------------------------------- -- Reading/writing sequences of bytes. -- --------------------------------------------------------------------------- -- 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 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__{ 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 bytes0 = loop 0 bytes0 where loop :: Int -> Int -> IO () loop _ bytes | bytes <= 0 = return () loop off bytes = do r <- fromIntegral `liftM` 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 -- | '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 h ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = 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 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" 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__{ 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 handle <- openFile fname ReadMode sz <- hFileSize handle if sz > fromIntegral (maxBound::Int) then 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 return (chunk, r) -- --------------------------------------------------------------------------- -- memcpy wrappers foreign import ccall unsafe "__hscore_memcpy_src_off" memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) foreign import ccall unsafe "__hscore_memcpy_src_off" memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) foreign import ccall unsafe "__hscore_memcpy_dst_off" memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ()) foreign import ccall unsafe "__hscore_memcpy_dst_off" memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ()) ----------------------------------------------------------------------------- -- Internal Utils illegalBufferSize :: Handle -> String -> Int -> IO a illegalBufferSize handle fn sz = ioException (IOError (Just handle) InvalidArgument fn ("illegal buffer size " ++ showsPrec 9 sz []) Nothing)