_ -> do
if mode == haBufferMode then return handle_ else do
- {- Note:
- - we flush the old buffer regardless of whether
- the new buffer could fit the contents of the old buffer
- or not.
- - allow a handle's buffering to change even if IO has
- occurred (ANSI C spec. does not allow this, nor did
- the previous implementation of IO.hSetBuffering).
- - a non-standard extension is to allow the buffering
- of semi-closed handles to change [sof 6/98]
- -}
- flushCharBuffer handle_
-
- let state = initBufferState haType
- reading = not (isWritableHandleType haType)
-
- new_buf <-
- case mode of
- -- See [note Buffer Sizing], GHC.IO.Handle.Types
- NoBuffering | reading -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
- | otherwise -> newCharBuffer 1 state
- LineBuffering -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
- BlockBuffering Nothing -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
- BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
- | otherwise -> newCharBuffer n state
+ -- See [note Buffer Sizing] in GHC.IO.Handle.Types
- writeIORef haCharBuffer new_buf
+ -- check for errors:
+ case mode of
+ BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
+ _ -> return ()
-- for input terminals we need to put the terminal into
-- cooked or raw mode depending on the type of buffering.
openTextEncoding, closeTextCodecs, initBufferState,
dEFAULT_CHAR_BUFFER_SIZE,
- flushBuffer, flushWriteBuffer, flushWriteBuffer_, flushCharReadBuffer,
- flushCharBuffer, flushByteReadBuffer,
+ flushBuffer, flushWriteBuffer, flushCharReadBuffer,
+ flushCharBuffer, flushByteReadBuffer, flushByteWriteBuffer,
- readTextDevice, writeTextDevice, readTextDeviceNonBlocking,
+ readTextDevice, writeCharBuffer, readTextDeviceNonBlocking,
decodeByteBuf,
augmentIOError,
ReadWriteHandle -> do
-- a read/write handle and we want to read from it. We must
-- flush all buffered write data first.
- cbuf <- readIORef haCharBuffer
- when (isWriteBuffer cbuf) $ do
- cbuf' <- flushWriteBuffer_ h_ cbuf
+ bbuf <- readIORef haByteBuffer
+ when (isWriteBuffer bbuf) $ do
+ when (not (isEmptyBuffer bbuf)) $ flushByteWriteBuffer h_
+ cbuf' <- readIORef haCharBuffer
writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer }
bbuf <- readIORef haByteBuffer
writeIORef haByteBuffer bbuf{ bufState = ReadBuffer }
mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)
mkUnBuffer state = do
- buffer <- case state of -- See [note Buffer Sizing], GHC.IO.Handle.Types
- ReadBuffer -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
- WriteBuffer -> newCharBuffer 1 state
+ buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
+ -- See [note Buffer Sizing], GHC.IO.Handle.Types
ref <- newIORef buffer
return (ref, NoBuffering)
flushCharReadBuffer h_
flushByteReadBuffer h_
WriteBuffer -> do
- buf' <- flushWriteBuffer_ h_ buf
- writeIORef haCharBuffer buf'
+ flushByteWriteBuffer h_
--- | flushes at least the Char buffer, and the byte buffer for a write
--- Handle. Works on all Handles.
+-- | flushes the Char buffer only. Works on all Handles.
flushCharBuffer :: Handle__ -> IO ()
flushCharBuffer h_@Handle__{..} = do
- buf <- readIORef haCharBuffer
- case bufState buf of
+ cbuf <- readIORef haCharBuffer
+ case bufState cbuf of
ReadBuffer -> do
flushCharReadBuffer h_
- WriteBuffer -> do
- buf' <- flushWriteBuffer_ h_ buf
- writeIORef haCharBuffer buf'
+ WriteBuffer ->
+ when (not (isEmptyBuffer cbuf)) $
+ error "internal IO library error: Char buffer non-empty"
-- -----------------------------------------------------------------------------
-- Writing data (flushing write buffers)
-- empty.
flushWriteBuffer :: Handle__ -> IO ()
flushWriteBuffer h_@Handle__{..} = do
- buf <- readIORef haCharBuffer
- if isWriteBuffer buf
- then do buf' <- flushWriteBuffer_ h_ buf
- writeIORef haCharBuffer buf'
- else return ()
+ buf <- readIORef haByteBuffer
+ when (isWriteBuffer buf) $ flushByteWriteBuffer h_
-flushWriteBuffer_ :: Handle__ -> CharBuffer -> IO CharBuffer
-flushWriteBuffer_ h_@Handle__{..} cbuf = do
+flushByteWriteBuffer :: Handle__ -> IO ()
+flushByteWriteBuffer h_@Handle__{..} = do
+ bbuf <- readIORef haByteBuffer
+ when (not (isEmptyBuffer bbuf)) $ do
+ bbuf' <- Buffered.flushWriteBuffer haDevice bbuf
+ writeIORef haByteBuffer bbuf'
+
+-- write the contents of the CharBuffer to the Handle__.
+-- The data will be encoded and pushed to the byte buffer,
+-- flushing if the buffer becomes full.
+writeCharBuffer :: Handle__ -> CharBuffer -> IO ()
+writeCharBuffer h_@Handle__{..} !cbuf = do
+ --
bbuf <- readIORef haByteBuffer
- if not (isEmptyBuffer cbuf) || not (isEmptyBuffer bbuf)
- then do writeTextDevice h_ cbuf
- return cbuf{ bufL=0, bufR=0 }
- else return cbuf
+
+ debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++
+ " bbuf=" ++ summaryBuffer bbuf)
+
+ (cbuf',bbuf') <- case haEncoder of
+ Nothing -> latin1_encode cbuf bbuf
+ Just encoder -> (encode encoder) cbuf bbuf
+
+ debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++
+ " bbuf=" ++ summaryBuffer bbuf')
+
+ -- flush if the write buffer is full
+ if isFullBuffer bbuf'
+ -- or we made no progress
+ || not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf
+ -- or the byte buffer has more elements than the user wanted buffered
+ || (case haBufferMode of
+ BlockBuffering (Just s) -> bufferElems bbuf' >= s
+ NoBuffering -> True
+ _other -> False)
+ then do
+ bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf'
+ writeIORef haByteBuffer bbuf''
+ else
+ writeIORef haByteBuffer bbuf'
+
+ if not (isEmptyBuffer cbuf')
+ then writeCharBuffer h_ cbuf'
+ else return ()
-- -----------------------------------------------------------------------------
-- Flushing read buffers
-- ----------------------------------------------------------------------------
-- Text input/output
--- Write the contents of the supplied Char buffer to the device, return
--- only when all the data has been written.
-writeTextDevice :: Handle__ -> CharBuffer -> IO ()
-writeTextDevice h_@Handle__{..} cbuf = do
- --
- bbuf <- readIORef haByteBuffer
-
- debugIO ("writeTextDevice: cbuf=" ++ summaryBuffer cbuf ++
- " bbuf=" ++ summaryBuffer bbuf)
-
- (cbuf',bbuf') <- case haEncoder of
- Nothing -> latin1_encode cbuf bbuf
- Just encoder -> (encode encoder) cbuf bbuf
-
- debugIO ("writeTextDevice after encoding: cbuf=" ++ summaryBuffer cbuf' ++
- " bbuf=" ++ summaryBuffer bbuf')
-
- bbuf' <- Buffered.flushWriteBuffer haDevice bbuf'
- writeIORef haByteBuffer bbuf'
- if not (isEmptyBuffer cbuf')
- then writeTextDevice h_ cbuf'
- else return ()
-
-- Read characters into the provided buffer. Return when any
-- characters are available; raise an exception if the end of
-- file is reached.
hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
commitBuffer', -- hack, see below
hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
- memcpy,
+ memcpy, hPutStrLn,
) where
import GHC.IO
hPutChar handle c = do
c `seq` return ()
wantWritableHandle "hPutChar" handle $ \ handle_ -> do
- case haBufferMode handle_ of
- LineBuffering -> hPutcBuffered handle_ True c
- _other -> hPutcBuffered handle_ False c
+ hPutcBuffered handle_ c
-hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
-hPutcBuffered handle_@Handle__{..} is_line c = do
+hPutcBuffered :: Handle__ -> Char -> IO ()
+hPutcBuffered handle_@Handle__{..} c = do
buf <- readIORef haCharBuffer
if c == '\n'
then do buf1 <- if haOutputNL == CRLF
putc buf1 '\n'
else do
putc buf '\n'
- if is_line
- then do
- flushed_buf <- flushWriteBuffer_ handle_ buf1
- writeIORef haCharBuffer flushed_buf
- else
- writeIORef haCharBuffer buf1
+ writeCharBuffer handle_ buf1
+ when is_line $ flushByteWriteBuffer handle_
else do
buf1 <- putc buf c
- writeIORef haCharBuffer buf1
+ writeCharBuffer handle_ buf1
+ return ()
where
+ is_line = case haBufferMode of
+ LineBuffering -> True
+ _ -> False
+
putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
debugIO ("putc: " ++ summaryBuffer buf)
w' <- writeCharBuf raw w c
- let buf' = buf{ bufR = w' }
- if isFullCharBuffer buf'
- then flushWriteBuffer_ handle_ buf'
- else return buf'
+ return buf{ bufR = w' }
-- ---------------------------------------------------------------------------
-- hPutStr
-- * 'isPermissionError' if another system resource limit would be exceeded.
hPutStr :: Handle -> String -> IO ()
-hPutStr handle str = do
- (buffer_mode, nl) <-
+hPutStr handle str = hPutStr' handle str False
+
+-- | The same as 'hPutStr', but adds a newline character.
+hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn handle str = hPutStr' handle str True
+ -- An optimisation: we treat hPutStrLn specially, to avoid the
+ -- overhead of a single putChar '\n', which is quite high now that we
+ -- have to encode eagerly.
+
+hPutStr' :: Handle -> String -> Bool -> IO ()
+hPutStr' handle str add_nl =
+ do
+ (buffer_mode, nl) <-
wantWritableHandle "hPutStr" handle $ \h_ -> do
bmode <- getSpareBuffer h_
return (bmode, haOutputNL h_)
case buffer_mode of
(NoBuffering, _) -> do
hPutChars handle str -- v. slow, but we don't care
+ when add_nl $ hPutChar handle '\n'
(LineBuffering, buf) -> do
- writeBlocks handle True nl buf str
+ writeBlocks handle True add_nl nl buf str
(BlockBuffering _, buf) -> do
- writeBlocks handle False nl buf str
+ writeBlocks handle False add_nl nl buf str
hPutChars :: Handle -> [Char] -> IO ()
hPutChars _ [] = return ()
-- NB. performance-critical code: eyeball the Core.
-writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
-writeBlocks hdl line_buffered nl
+writeBlocks :: Handle -> Bool -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
+writeBlocks hdl line_buffered add_nl nl
buf@Buffer{ bufRaw=raw, bufSize=len } s =
let
- shoveString :: Int -> [Char] -> IO ()
- shoveString !n [] = do
- _ <- commitBuffer hdl raw len n False{-no flush-} True{-release-}
- return ()
- shoveString !n (c:cs)
+ shoveString :: Int -> [Char] -> [Char] -> IO ()
+ shoveString !n [] [] = do
+ commitBuffer hdl raw len n False{-no flush-} True{-release-}
+ shoveString !n [] rest = do
+ shoveString n rest []
+ shoveString !n (c:cs) rest
-- n+1 so we have enough room to write '\r\n' if necessary
| n + 1 >= len = do
- new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
- writeBlocks hdl line_buffered nl new_buf (c:cs)
+ commitBuffer hdl raw len n False{-flush-} False
+ shoveString 0 (c:cs) rest
| c == '\n' = do
n' <- if nl == CRLF
then do
writeCharBuf raw n c
if line_buffered
then do
- new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
- writeBlocks hdl line_buffered nl new_buf cs
+ -- end of line, so write and flush
+ commitBuffer hdl raw len n' True{-flush-} False
+ shoveString 0 cs rest
else do
- shoveString n' cs
+ shoveString n' cs rest
| otherwise = do
n' <- writeCharBuf raw n c
- shoveString n' cs
+ shoveString n' cs rest
in
- shoveString 0 s
+ shoveString 0 s (if add_nl then "\n" else "")
-- -----------------------------------------------------------------------------
-- 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
-> Int -- number of bytes of data in buffer
-> Bool -- True <=> flush the handle afterward
-> Bool -- release the buffer?
- -> IO CharBuffer
+ -> IO ()
commitBuffer hdl !raw !sz !count flush release =
- wantWritableHandle "commitAndReleaseBuffer" hdl $
- commitBuffer' raw sz count flush release
-{-# NOINLINE commitBuffer #-}
-
--- 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
---
+ wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do
+ debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
+ ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
+
+ writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer,
+ bufL=0, bufR=count, bufSize=sz }
+
+ when flush $ flushByteWriteBuffer h_
+
+ -- release the buffer if necessary
+ when release $ do
+ -- find size of current buffer
+ old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
+ when (sz == size) $ do
+ spare_bufs <- readIORef haBuffers
+ writeIORef haBuffers (BufferListCons raw spare_bufs)
+
+ return ()
+
+-- backwards compatibility; the text package uses this
commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
-> IO CharBuffer
-commitBuffer' raw sz@(I# _) count@(I# _) flush release
- handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
-
+commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..}
+ = do
debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
++ ", flush=" ++ show flush ++ ", release=" ++ show release)
- old_buf@Buffer{ bufRaw=old_raw, bufR=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 bufR.
- then do withRawBuffer raw $ \praw ->
- copyToRawBuffer old_raw (w*charSize)
- praw (count*charSize)
- writeIORef ref old_buf{ bufR = w + count }
- return (emptyBuffer raw sz WriteBuffer)
-
- -- else, we have to flush
- else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
-
- let this_buf =
- Buffer{ bufRaw=raw, bufState=WriteBuffer,
- bufL=0, bufR=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
- -- We're aren't going to use this buffer again
- -- so we ignore the result of flushWriteBuffer_
- _ <- flushWriteBuffer_ 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 (emptyBuffer raw sz WriteBuffer)
- else newCharBuffer size WriteBuffer
+ let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer,
+ bufL=0, bufR=count, bufSize=sz }
+
+ writeCharBuffer h_ this_buf
+
+ when flush $ flushByteWriteBuffer h_
-- release the buffer if necessary
- case buf_ret of
- Buffer{ bufSize=buf_ret_sz, bufRaw=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
+ when release $ do
+ -- find size of current buffer
+ old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
+ when (sz == size) $ do
+ spare_bufs <- readIORef haBuffers
+ writeIORef haBuffers (BufferListCons raw spare_bufs)
+
+ return this_buf
-- ---------------------------------------------------------------------------
-- Reading/writing sequences of bytes.
wantWritableHandle "hPutBuf" handle $
\ h_@Handle__{..} -> do
debugIO ("hPutBuf count=" ++ show count)
- -- first flush the Char buffer if it is non-empty, then we
- -- can work directly with the byte buffer
- cbuf <- readIORef haCharBuffer
- when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
r <- bufWrite h_ (castPtr ptr) count can_block
import GHC.Word
import GHC.IO.Device
import Data.Typeable
+#ifdef DEBUG
+import Control.Monad
+#endif
-- ---------------------------------------------------------------------------
-- Handle type
checkBuffer bbuf
cbuf <- readIORef (haCharBuffer h_)
checkBuffer cbuf
+ when (isWriteBuffer cbuf && not (isEmptyBuffer cbuf)) $
+ error ("checkHandleInvariants: char write buffer non-empty: " ++
+ summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf)
+ when (isWriteBuffer bbuf /= isWriteBuffer cbuf) $
+ error ("checkHandleInvariants: buffer modes differ: " ++
+ summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf)
+
#else
checkHandleInvariants _ = return ()
#endif
[note Buffered Writing]
-Characters are written into the Char buffer by e.g. hPutStr. When the
-buffer is full, we call writeTextDevice, which encodes the Char buffer
-into the byte buffer, and then immediately writes it all out to the
-underlying device. The Char buffer will always be empty afterward.
-This might require multiple decoding/writing cycles.
+Characters are written into the Char buffer by e.g. hPutStr. At the
+end of the operation, or when the char buffer is full, the buffer is
+decoded to the byte buffer (see writeCharBuffer). This is so that we
+can detect encoding errors at the right point.
+
+Hence, the Char buffer is always empty between Handle operations.
[note Buffer Sizing]
-Since the buffer mode makes no difference when reading, we can just
-use the default buffer size for both the byte and the Char buffer.
-Ineed, we must have room for at least one Char in the Char buffer,
-because we have to implement hLookAhead, which requires caching a Char
-in the Handle. Furthermore, when doing newline translation, we need
-room for at least two Chars in the read buffer, so we can spot the
-\r\n sequence.
+The char buffer is always a default size (dEFAULT_CHAR_BUFFER_SIZE).
+The byte buffer size is chosen by the underlying device (via its
+IODevice.newBuffer). Hence the size of these buffers is not under
+user control.
+
+There are certain minimum sizes for these buffers imposed by the
+library (but not checked):
+
+ - we must be able to buffer at least one character, so that
+ hLookAhead can work
+
+ - the byte buffer must be able to store at least one encoded
+ character in the current encoding (6 bytes?)
+
+ - when reading, the char buffer must have room for two characters, so
+ that we can spot the \r\n sequence.
+
+How do we implement hSetBuffering?
+
+For reading, we have never used the user-supplied buffer size, because
+there's no point: we always pass all available data to the reader
+immediately. Buffering would imply waiting until a certain amount of
+data is available, which has no advantages. So hSetBuffering is
+essentially a no-op for read handles, except that it turns on/off raw
+mode for the underlying device if necessary.
-For writing, however, when the buffer mode is NoBuffering, we use a
-1-element Char buffer to force flushing of the buffer after each Char
-is read.
+For writing, the buffering mode is handled by the write operations
+themselves (hPutChar and hPutStr). Every write ends with
+writeCharBuffer, which checks whether the buffer should be flushed
+according to the current buffering mode. Additionally, we look for
+newlines and flush if the mode is LineBuffering.
[note Buffer Flushing]
We must be able to flush the Char buffer, in order to implement
hSetEncoding, and things like hGetBuf which want to read raw bytes.
-Flushing the Char buffer on a write Handle is easy: just call
-writeTextDevice to encode and write the date.
+Flushing the Char buffer on a write Handle is easy: it is always empty.
Flushing the Char buffer on a read Handle involves rewinding the byte
buffer to the point representing the next Char in the Char buffer.
import GHC.IO.Handle.FD
import qualified GHC.IO.FD as FD
import GHC.IO.Handle
-import GHC.IO.Handle.Text ( hGetBufSome )
+import GHC.IO.Handle.Text ( hGetBufSome, hPutStrLn )
import GHC.IORef
import GHC.IO.Exception ( userError )
import GHC.IO.Encoding
-- | The same as 'putStr', but adds a newline character.
putStrLn :: String -> IO ()
-putStrLn s = do putStr s
- putChar '\n'
+putStrLn s = hPutStrLn stdout s
-- | The 'print' function outputs a value of any printable type to the
-- standard output device.
hReady :: Handle -> IO Bool
hReady h = hWaitForInput h 0
--- | The same as 'hPutStr', but adds a newline character.
-
-hPutStrLn :: Handle -> String -> IO ()
-hPutStrLn hndl str = do
- hPutStr hndl str
- hPutChar hndl '\n'
-
-- | Computation 'hPrint' @hdl t@ writes the string representation of @t@
-- given by the 'shows' function to the file or channel managed by @hdl@
-- and appends a newline.
projects / ghc-base.git / commitdiff