-{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
+{-# LANGUAGE NoImplicitPrelude
+ , RecordWildCards
+ , BangPatterns
+ , PatternGuards
+ , NondecreasingIndentation
+ , Rank2Types
+ #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
-{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-{-# OPTIONS_GHC -XRecordWildCards #-}
{-# OPTIONS_HADDOCK hide #-}
-#undef DEBUG_DUMP
-
-----------------------------------------------------------------------------
-- |
-- Module : GHC.IO.Handle.Internals
wantSeekableHandle,
mkHandle, mkFileHandle, mkDuplexHandle,
- openTextEncoding, initBufferState,
+ 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,
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
import GHC.IO
import GHC.IO.IOMode
-import GHC.IO.Encoding
+import GHC.IO.Encoding as Encoding
import GHC.IO.Handle.Types
import GHC.IO.Buffer
import GHC.IO.BufferedIO (BufferedIO)
import qualified GHC.IO.Device as IODevice
import qualified GHC.IO.BufferedIO as Buffered
+import GHC.Conc.Sync
import GHC.Real
import GHC.Base
-import GHC.List
import GHC.Exception
import GHC.Num ( Num(..) )
import GHC.Show
import Data.Typeable
import Control.Monad
import Data.Maybe
-import Foreign
-import System.IO.Error
+import Foreign hiding (unsafePerformIO)
+-- import System.IO.Error
import System.Posix.Internals hiding (FD)
-import qualified System.Posix.Internals as Posix
-#ifdef DEBUG_DUMP
import Foreign.C
-#endif
+
+c_DEBUG_DUMP :: Bool
+c_DEBUG_DUMP = False
-- ---------------------------------------------------------------------------
-- Creating a new handle
withHandle' :: String -> Handle -> MVar Handle__
-> (Handle__ -> IO (Handle__,a)) -> IO a
withHandle' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkHandleInvariants h_
- (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
- `catchException` \ex -> ioError (augmentIOError ex fun h)
+ mask_ $ do
+ (h',v) <- do_operation fun h act m
checkHandleInvariants h'
putMVar m h'
return v
withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
-withHandle_' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkHandleInvariants h_
- v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
- `catchException` \ex -> ioError (augmentIOError ex fun h)
- checkHandleInvariants h_
- putMVar m h_
- return v
+withHandle_' fun h m act = withHandle' fun h m $ \h_ -> do
+ a <- act h_
+ return (h_,a)
withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
-> IO ()
withHandle__' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkHandleInvariants h_
- h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
- `catchException` \ex -> ioError (augmentIOError ex fun h)
+ mask_ $ do
+ h' <- do_operation fun h act m
checkHandleInvariants h'
putMVar m h'
return ()
+do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a
+do_operation fun h act m = do
+ h_ <- takeMVar m
+ checkHandleInvariants h_
+ act h_ `catchException` handler h_
+ where
+ handler h_ e = do
+ putMVar m h_
+ case () of
+ _ | Just ioe <- fromException e ->
+ ioError (augmentIOError ioe fun h)
+ _ | Just async_ex <- fromException e -> do -- see Note [async]
+ let _ = async_ex :: AsyncException
+ t <- myThreadId
+ throwTo t e
+ do_operation fun h act m
+ _otherwise ->
+ throwIO e
+
+-- Note [async]
+--
+-- If an asynchronous exception is raised during an I/O operation,
+-- normally it is fine to just re-throw the exception synchronously.
+-- However, if we are inside an unsafePerformIO or an
+-- unsafeInterleaveIO, this would replace the enclosing thunk with the
+-- exception raised, which is wrong (#3997). We have to release the
+-- lock on the Handle, but what do we replace the thunk with? What
+-- should happen when the thunk is subsequently demanded again?
+--
+-- The only sensible choice we have is to re-do the IO operation on
+-- resumption, but then we have to be careful in the IO library that
+-- this is always safe to do. In particular we should
+--
+-- never perform any side-effects before an interruptible operation
+--
+-- because the interruptible operation may raise an asynchronous
+-- exception, which may cause the operation and its side effects to be
+-- subsequently performed again.
+--
+-- Re-doing the IO operation is achieved by:
+-- - using throwTo to re-throw the asynchronous exception asynchronously
+-- in the current thread
+-- - on resumption, it will be as if throwTo returns. In that case, we
+-- recursively invoke the original operation (see do_operation above).
+--
+-- Interruptible operations in the I/O library are:
+-- - threadWaitRead/threadWaitWrite
+-- - fillReadBuffer/flushWriteBuffer
+-- - readTextDevice/writeTextDevice
+
augmentIOError :: IOException -> String -> Handle -> IOException
augmentIOError ioe@IOError{ ioe_filename = fp } fun h
= ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath }
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__
buf <- readIORef haCharBuffer
writeIORef haCharBuffer buf{ bufState = WriteBuffer }
buf <- readIORef haByteBuffer
- writeIORef haByteBuffer buf{ bufState = WriteBuffer }
+ buf' <- Buffered.emptyWriteBuffer haDevice buf
+ writeIORef haByteBuffer buf'
act h_
_other -> act h_
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__
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 }
-- Handy IOErrors
ioe_closedHandle, ioe_EOF,
- ioe_notReadable, ioe_notWritable, ioe_cannotFlushTextRead,
- ioe_notSeekable, ioe_notSeekable_notBin, ioe_invalidCharacter :: IO a
+ ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable,
+ ioe_notSeekable, ioe_invalidCharacter :: IO a
ioe_closedHandle = ioException
(IOError Nothing IllegalOperation ""
ioe_notSeekable = ioException
(IOError Nothing IllegalOperation ""
"handle is not seekable" Nothing Nothing)
-ioe_notSeekable_notBin = ioException
+ioe_cannotFlushNotSeekable = ioException
(IOError Nothing IllegalOperation ""
- "seek operations on text-mode handles are not allowed on this platform"
- Nothing Nothing)
-ioe_cannotFlushTextRead = ioException
- (IOError Nothing IllegalOperation ""
- "cannot flush the read buffer of a text-mode handle"
+ "cannot flush the read buffer: underlying device is not seekable"
Nothing Nothing)
ioe_invalidCharacter = ioException
(IOError Nothing InvalidArgument ""
("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)
-- 9 => should be parens'ified.
+-- ---------------------------------------------------------------------------
+-- Wrapper for Handle encoding/decoding.
+
+-- The interface for TextEncoding changed so that a TextEncoding doesn't raise
+-- an exception if it encounters an invalid sequnce. Furthermore, encoding
+-- returns a reason as to why encoding stopped, letting us know if it was due
+-- to input/output underflow or an invalid sequence.
+--
+-- This code adapts this elaborated interface back to the original TextEncoding
+-- interface.
+--
+-- FIXME: it is possible that Handle code using the haDecoder/haEncoder fields
+-- could be made clearer by using the 'encode' interface directly. I have not
+-- looked into this.
+--
+-- FIXME: we should use recover to deal with EOF, rather than always throwing an
+-- IOException (ioe_invalidCharacter).
+
+streamEncode :: BufferCodec from to state
+ -> Buffer from -> Buffer to
+ -> IO (Buffer from, Buffer to)
+streamEncode codec from to = go (from, to)
+ where
+ go (from, to) = do
+ (why, from', to') <- encode codec from to
+ -- When we are dealing with Handles, we don't care about input/output
+ -- underflow particularly, and we want to delay errors about invalid
+ -- sequences as far as possible.
+ case why of
+ Encoding.InvalidSequence | bufL from == bufL from' -> recover codec from' to' >>= go
+ _ -> return (from', to')
+
-- -----------------------------------------------------------------------------
-- Handle Finalizers
-- 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 "<<loop>>".
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
-- 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)
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
- if not (isEmptyBuffer cbuf) || not (isEmptyBuffer bbuf)
- then do writeTextDevice h_ cbuf
- return cbuf{ bufL=0, bufR=0 }
- else return cbuf
+ 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
+
+ debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++
+ " bbuf=" ++ summaryBuffer bbuf)
+
+ (cbuf',bbuf') <- case haEncoder of
+ Nothing -> latin1_encode cbuf bbuf
+ Just encoder -> (streamEncode 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
-- restore the codec state
setState decoder codec_state
- (bbuf1,cbuf1) <- (encode decoder) bbuf0
+ (bbuf1,cbuf1) <- (streamEncode decoder) bbuf0
cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }
debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
if isEmptyBuffer bbuf then return () else do
seekable <- IODevice.isSeekable haDevice
- when (not seekable) $ ioe_cannotFlushTextRead
+ when (not seekable) $ ioe_cannotFlushNotSeekable
let seek = negate (bufR bbuf - bufL bbuf)
haBuffers = spares,
haEncoder = mb_encoder,
haDecoder = mb_decoder,
+ haCodec = mb_codec,
haInputNL = inputNL nl,
haOutputNL = outputNL nl,
haOtherSide = other_side
-- | like 'mkFileHandle', except that a 'Handle' is created with two
-- independent buffers, one for reading and one for writing. Used for
--- full-dupliex streams, such as network sockets.
+-- full-duplex streams, such as network sockets.
mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
-> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
mkDuplexHandle dev filepath mb_codec tr_newlines = do
return Nothing
cont mb_encoder mb_decoder
+closeTextCodecs :: Handle__ -> IO ()
+closeTextCodecs Handle__{..} = do
+ case haDecoder of Nothing -> return (); Just d -> Encoding.close d
+ case haEncoder of Nothing -> return (); Just d -> Encoding.close d
+
-- ---------------------------------------------------------------------------
-- closing Handles
trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
-hClose_handle_ Handle__{..} = do
+hClose_handle_ h_@Handle__{..} = do
-- close the file descriptor, but not when this is the read
-- side of a duplex handle.
writeIORef haByteBuffer noByteBuffer
-- release our encoder/decoder
- case haDecoder of Nothing -> return (); Just d -> close d
- case haEncoder of Nothing -> return (); Just d -> close d
+ closeTextCodecs h_
-- we must set the fd to -1, because the finalizer is going
-- to run eventually and try to close/unlock it.
-- debugging
debugIO :: String -> IO ()
-#if defined(DEBUG_DUMP)
-debugIO s = do
- withCStringLen (s++"\n") $ \(p,len) -> c_write 1 p (fromIntegral len)
- return ()
-#else
-debugIO s = return ()
-#endif
+debugIO s
+ | c_DEBUG_DUMP
+ = do _ <- withCStringLen (s ++ "\n") $
+ \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
+ return ()
+ | otherwise = return ()
-- ----------------------------------------------------------------------------
-- 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')
-
- Buffered.flushWriteBuffer haDevice bbuf'
- writeIORef haByteBuffer bbuf{bufL=0,bufR=0}
- 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.
Just decoder -> do
state <- getState decoder
writeIORef haLastDecode (state, bbuf1)
- (encode decoder) bbuf1 cbuf
+ (streamEncode decoder) bbuf1 cbuf
debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
" bbuf=" ++ summaryBuffer bbuf2)
then ioe_invalidCharacter
else return bbuf2
- debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2)
+ debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)
(bbuf3,cbuf') <-
case haDecoder of
Just decoder -> do
state <- getState decoder
writeIORef haLastDecode (state, bbuf2)
- (encode decoder) bbuf2 cbuf
+ (streamEncode decoder) bbuf2 cbuf
- debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
+ debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf' ++
" bbuf=" ++ summaryBuffer bbuf3)
writeIORef haByteBuffer bbuf3
readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
--
bbuf0 <- readIORef haByteBuffer
- bbuf1 <- if not (isEmptyBuffer bbuf0)
- then return bbuf0
- else do
- (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
- if r == 0 then ioe_EOF else do -- raise EOF
- return bbuf1
+ when (isEmptyBuffer bbuf0) $ do
+ (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0
+ if isNothing r then ioe_EOF else do -- raise EOF
+ writeIORef haByteBuffer bbuf1
+
+ decodeByteBuf h_ cbuf
+
+-- Decode bytes from the byte buffer into the supplied CharBuffer.
+decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer
+decodeByteBuf h_@Handle__{..} cbuf = do
+ --
+ bbuf0 <- readIORef haByteBuffer
- (bbuf2,cbuf') <- case haDecoder of
- Nothing -> latin1_decode bbuf1 cbuf
- Just decoder -> (encode decoder) bbuf1 cbuf
+ (bbuf2,cbuf') <-
+ case haDecoder of
+ Nothing -> do
+ writeIORef haLastDecode (error "codec_state", bbuf0)
+ latin1_decode bbuf0 cbuf
+ Just decoder -> do
+ state <- getState decoder
+ writeIORef haLastDecode (state, bbuf0)
+ (streamEncode decoder) bbuf0 cbuf
writeIORef haByteBuffer bbuf2
return cbuf'
projects / ghc-base.git / blobdiff