{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
#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
import System.Posix.Internals
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
import GHC.Exception ( ioError, catch )
#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_)
return (r /= 0)
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 ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
= do (c,r) <- readCharFromBuffer b r
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=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
#ifdef DEBUG_DUMP
puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
#endif
xs <- unpack raw r 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 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 buf r 0 = return ""
unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
where
unpack acc i s
| i <# r = (# s, acc #)
| otherwise =
case readCharArray# buf i s of
(# s, ch #) -> unpack (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' 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 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
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 buf r 0 acc = return acc
unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
where
unpack acc i s
| i <# r = (# s, acc #)
| otherwise =
case readCharArray# buf i s of
(# s, ch #) -> unpack (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_ 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 handle [] = 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' 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, bufRPtr=r, 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_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
bufWrite fd ref is_stream ptr count can_block
bufWrite fd ref is_stream ptr count can_block =
seq count $ seq fd $ do -- strictness hack
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 (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
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 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 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_@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 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
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_@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 (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
#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 0
else throwErrno "readChunk"
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
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 :: Int) =
ioException (IOError (Just handle)
InvalidArgument fn
("illegal buffer size " ++ showsPrec 9 sz [])
Nothing)
|
