X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO%2FHandle%2FInternals.hs;h=6409bbdb33bba389c2face905e8a812b38b993f0;hb=41e8fba828acbae1751628af50849f5352b27873;hp=844c8c6eeea281f39b5625ecf87b6f89a2f7e797;hpb=9520c5735e69668a33013c36f85152a1ef656b8d;p=ghc-base.git diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs index 844c8c6..6409bbd 100644 --- a/GHC/IO/Handle/Internals.hs +++ b/GHC/IO/Handle/Internals.hs @@ -1,7 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , BangPatterns + , PatternGuards + , NondecreasingIndentation + , Rank2Types + #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -XRecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -31,10 +36,10 @@ module GHC.IO.Handle.Internals ( 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, @@ -70,7 +75,7 @@ import GHC.MVar import Data.Typeable import Control.Monad import Data.Maybe -import Foreign +import Foreign hiding (unsafePerformIO) -- import System.IO.Error import System.Posix.Internals hiding (FD) @@ -221,7 +226,9 @@ wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantWritableHandle fun h@(FileHandle _ m) act = wantWritableHandle' fun h m act wantWritableHandle fun h@(DuplexHandle _ _ m) act - = withHandle_' fun h m act + = wantWritableHandle' fun h m act + -- we know it's not a ReadHandle or ReadWriteHandle, but we have to + -- check for ClosedHandle/SemiClosedHandle. (#4808) wantWritableHandle' :: String -> Handle -> MVar Handle__ @@ -258,7 +265,9 @@ wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a wantReadableHandle_ fun h@(FileHandle _ m) act = wantReadableHandle' fun h m act wantReadableHandle_ fun h@(DuplexHandle _ m _) act - = withHandle_' fun h m act + = wantReadableHandle' fun h m act + -- we know it's not a WriteHandle or ReadWriteHandle, but we have to + -- check for ClosedHandle/SemiClosedHandle. (#4808) wantReadableHandle' :: String -> Handle -> MVar Handle__ @@ -276,9 +285,10 @@ checkReadableHandle act h_@Handle__{..} = 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 } @@ -360,18 +370,25 @@ ioe_bufsiz n = ioException -- has become unreferenced and then resurrected (arguably in the -- latter case we shouldn't finalize the Handle...). Anyway, -- we try to emit a helpful message which is better than nothing. +-- +-- [later; 8/2010] However, a program like this can yield a strange +-- error message: +-- +-- main = writeFile "out" loop +-- loop = let x = x in x +-- +-- because the main thread and the Handle are both unreachable at the +-- same time, the Handle may get finalized before the main thread +-- receives the NonTermination exception, and the exception handler +-- will then report an error. We'd rather this was not an error and +-- the program just prints "<>". handleFinalizer :: FilePath -> MVar Handle__ -> IO () handleFinalizer fp m = do handle_ <- takeMVar m - case haType handle_ of - ClosedHandle -> return () - _ -> do flushWriteBuffer handle_ `catchAny` \_ -> return () - -- ignore errors and async exceptions, and close the - -- descriptor anyway... - _ <- hClose_handle_ handle_ - return () - putMVar m (ioe_finalizedHandle fp) + (handle_', _) <- hClose_help handle_ + putMVar m handle_' + return () -- --------------------------------------------------------------------------- -- Allocating buffers @@ -379,7 +396,7 @@ handleFinalizer fp m = do -- using an 8k char buffer instead of 32k improved performance for a -- basic "cat" program by ~30% for me. --SDM dEFAULT_CHAR_BUFFER_SIZE :: Int -dEFAULT_CHAR_BUFFER_SIZE = dEFAULT_BUFFER_SIZE `div` 4 +dEFAULT_CHAR_BUFFER_SIZE = 2048 -- 8k/sizeof(HsChar) getCharBuffer :: IODevice dev => dev -> BufferState -> IO (IORef CharBuffer, BufferMode) @@ -396,9 +413,8 @@ getCharBuffer dev state = do 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) @@ -416,20 +432,18 @@ flushBuffer h_@Handle__{..} = do 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) @@ -439,19 +453,52 @@ flushCharBuffer h_@Handle__{..} = do -- 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 @@ -726,29 +773,6 @@ debugIO s -- ---------------------------------------------------------------------------- -- 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.