X-Git-Url: http://git.megacz.com/?p=ghc-base.git;a=blobdiff_plain;f=GHC%2FIO%2FHandle%2FText.hs;h=0d0e05b4d5fc93119730580e0f434ba9b1db505e;hp=745dc183be06dcc7b2ff2e00f3ffd99932cad1c9;hb=HEAD;hpb=bad25ed6cb9b939d786e53d3074f0cd4f869af28 diff --git a/GHC/IO/Handle/Text.hs b/GHC/IO/Handle/Text.hs index 745dc18..0d0e05b 100644 --- a/GHC/IO/Handle/Text.hs +++ b/GHC/IO/Handle/Text.hs @@ -1,5 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} -{-# OPTIONS_GHC -XRecordWildCards -XBangPatterns #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , RecordWildCards + , BangPatterns + , PatternGuards + , NondecreasingIndentation + , MagicHash + , ForeignFunctionInterface + #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_HADDOCK hide #-} @@ -23,7 +30,7 @@ module GHC.IO.Handle.Text ( hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, commitBuffer', -- hack, see below hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, - memcpy, + memcpy, hPutStrLn, ) where import GHC.IO @@ -31,6 +38,7 @@ import GHC.IO.FD import GHC.IO.Buffer import qualified GHC.IO.BufferedIO as Buffered import GHC.IO.Exception +import GHC.IO.Encoding.Failure (surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter) import GHC.Exception import GHC.IO.Handle.Types import GHC.IO.Handle.Internals @@ -40,6 +48,7 @@ import qualified GHC.IO.Device as RawIO import Foreign import Foreign.C +import qualified Control.Exception as Exception import Data.Typeable import System.IO.Error import Data.Maybe @@ -241,12 +250,12 @@ hGetLineBufferedLoop handle_@Handle__{..} maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = catch + = Exception.catch (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) - (\e -> do if isEOFError e - then return Nothing + (\e -> do if isEOFError e + then return Nothing else ioError e) -- See GHC.IO.Buffer @@ -271,10 +280,10 @@ unpack !buf !r !w acc0 else do c1 <- peekElemOff pbuf (i-1) let c = (fromIntegral c1 - 0xd800) * 0x400 + (fromIntegral c2 - 0xdc00) + 0x10000 - unpackRB (unsafeChr c : acc) (i-2) + unpackRB (desurrogatifyRoundtripCharacter (unsafeChr c) : acc) (i-2) #else c <- peekElemOff pbuf i - unpackRB (c:acc) (i-1) + unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1) #endif in unpackRB acc0 (w-1) @@ -297,7 +306,7 @@ unpack_nl !buf !r !w acc0 then unpackRB ('\n':acc) (i-2) else unpackRB ('\n':acc) (i-1) else do - unpackRB (c:acc) (i-1) + unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1) in do c <- peekElemOff pbuf (w-1) if (c == '\r') @@ -371,8 +380,8 @@ lazyRead handle = lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - catch - (do + Exception.catch + (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h (s,r) <- if haInputNL == CRLF @@ -440,12 +449,10 @@ hPutChar :: Handle -> Char -> 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 @@ -454,23 +461,21 @@ hPutcBuffered handle_@Handle__{..} is_line c = do 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 @@ -502,8 +507,19 @@ hPutcBuffered handle_@Handle__{..} is_line c = do -- * '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_) @@ -511,10 +527,11 @@ hPutStr handle str = do 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 () @@ -540,19 +557,20 @@ getSpareBuffer Handle__{haCharBuffer=ref, -- 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 @@ -562,36 +580,22 @@ writeBlocks hdl line_buffered nl 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 + n' <- writeCharBuf raw n (surrogatifyRoundtripCharacter c) + 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 @@ -599,93 +603,52 @@ commitBuffer -> 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 (fromIntegral (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. @@ -735,10 +698,6 @@ hPutBuf' handle ptr count can_block 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 @@ -761,7 +720,7 @@ bufWrite h_@Handle__{..} ptr count can_block = -- There's enough room in the buffer: -- just copy the data in and update bufR. then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w) - copyToRawBuffer old_raw w ptr (fromIntegral count) + copyToRawBuffer old_raw w ptr count writeIORef haByteBuffer old_buf{ bufR = w + count } return count @@ -836,7 +795,7 @@ bufReadNonEmpty h_@Handle__{..} return (so_far + count) else do - copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail) + copyFromRawBuffer ptr raw r avail let buf' = buf{ bufR=0, bufL=0 } writeIORef haByteBuffer buf' let remaining = count - avail @@ -861,9 +820,9 @@ bufReadEmpty h_@Handle__{..} bufReadNonEmpty h_ buf' ptr so_far count where loop :: FD -> Int -> Int -> IO Int - loop fd off bytes | bytes <= 0 = return off + loop fd off bytes | bytes <= 0 = return (so_far + off) loop fd off bytes = do - r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes) + r <- RawIO.read (fd::FD) (ptr `plusPtr` off) bytes if r == 0 then return (so_far + off) else loop fd (off + r) (bytes - r) @@ -891,9 +850,9 @@ bufReadEmpty h_@Handle__{..} hGetBufSome :: Handle -> Ptr a -> Int -> IO Int hGetBufSome h ptr count | count == 0 = return 0 - | count < 0 = illegalBufferSize h "hGetBuf" count + | count < 0 = illegalBufferSize h "hGetBufSome" count | otherwise = - wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do + wantReadableHandle_ "hGetBufSome" h $ \ h_@Handle__{..} -> do flushCharReadBuffer h_ buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer if isEmptyBuffer buf @@ -903,9 +862,12 @@ hGetBufSome h ptr count if r == 0 then return 0 else do writeIORef haByteBuffer buf' - bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 count + bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 (min r count) + -- new count is (min r count), so + -- that bufReadNBNonEmpty will not + -- issue another read. else - bufReadNBEmpty h_ buf (castPtr ptr) 0 count + bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count haFD :: Handle__ -> FD haFD h_@Handle__{..} = @@ -984,7 +946,7 @@ bufReadNBNonEmpty h_@Handle__{..} return (so_far + count) else do - copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail) + copyFromRawBuffer ptr raw r avail let buf' = buf{ bufR=0, bufL=0 } writeIORef haByteBuffer buf' let remaining = count - avail