{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
{-# 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,
- getEncoding, initBufferState,
+ openTextEncoding, initBufferState,
dEFAULT_CHAR_BUFFER_SIZE,
flushBuffer, flushWriteBuffer, flushWriteBuffer_, flushCharReadBuffer,
flushCharBuffer, flushByteReadBuffer,
readTextDevice, writeTextDevice, readTextDeviceNonBlocking,
+ decodeByteBuf,
augmentIOError,
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
import qualified GHC.IO.Device as IODevice
import qualified GHC.IO.BufferedIO as Buffered
+import GHC.Conc
import GHC.Real
import GHC.Base
-import GHC.List
import GHC.Exception
import GHC.Num ( Num(..) )
import GHC.Show
import Control.Monad
import Data.Maybe
import Foreign
-import System.IO.Error
+-- 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)
+ block $ 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)
+ block $ 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 }
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_
-- 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
- (IOError Nothing IllegalOperation ""
- "seek operations on text-mode handles are not allowed on this platform"
- Nothing Nothing)
-ioe_cannotFlushTextRead = ioException
+ioe_cannotFlushNotSeekable = 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 ""
_ -> do flushWriteBuffer handle_ `catchAny` \_ -> return ()
-- ignore errors and async exceptions, and close the
-- descriptor anyway...
- hClose_handle_ handle_
+ _ <- hClose_handle_ handle_
return ()
putMVar m (ioe_finalizedHandle fp)
-- haLastDecode is the byte buffer just before we did our last batch of
-- decoding. We're going to re-decode the bytes up to the current char,
-- to find out where we should revert the byte buffer to.
- bbuf0 <- readIORef haLastDecode
+ (codec_state, bbuf0) <- readIORef haLastDecode
cbuf0 <- readIORef haCharBuffer
writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }
Just decoder -> do
debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++
" cbuf=" ++ summaryBuffer cbuf0)
+
+ -- restore the codec state
+ setState decoder codec_state
(bbuf1,cbuf1) <- (encode decoder) bbuf0
cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }
- -- tricky case: if the decoded string starts with e BOM, then it was
- -- probably ignored last time we decoded these bytes, and we should
- -- therefore decode another char.
- (c,_) <- readCharBuf (bufRaw cbuf1) (bufL cbuf1)
- (bbuf2,_) <- if (c == '\xfeff')
- then do debugIO "found BOM, decoding another char"
- (encode decoder) bbuf1
- cbuf0{ bufL=0, bufR=0, bufSize = 1 }
- else return (bbuf1,cbuf1)
-
debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
" cbuf=" ++ summaryBuffer cbuf1)
- writeIORef haByteBuffer bbuf2
+ writeIORef haByteBuffer bbuf1
-- When flushing the byte read buffer, we seek backwards by the number
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)
-> Bool -- buffered?
-> Maybe TextEncoding
-> NewlineMode
- -> (Maybe HandleFinalizer)
+ -> Maybe HandleFinalizer
-> Maybe (MVar Handle__)
-> IO Handle
mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
+ openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
+
let buf_state = initBufferState ha_type
bbuf <- Buffered.newBuffer dev buf_state
bbufref <- newIORef bbuf
- last_decode <- newIORef bbuf
-
- (mb_encoder, mb_decoder) <- getEncoding mb_codec ha_type
+ last_decode <- newIORef (error "codec_state", bbuf)
(cbufref,bmode) <-
if buffered then getCharBuffer dev buf_state
haBuffers = spares,
haEncoder = mb_encoder,
haDecoder = mb_decoder,
+ haCodec = mb_codec,
haInputNL = inputNL nl,
haOutputNL = outputNL nl,
haOtherSide = other_side
initBufferState ReadHandle = ReadBuffer
initBufferState _ = WriteBuffer
-getEncoding :: Maybe TextEncoding -> HandleType
- -> IO (Maybe TextEncoder,
- Maybe TextDecoder)
+openTextEncoding
+ :: Maybe TextEncoding
+ -> HandleType
+ -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)
+ -> IO a
-getEncoding Nothing ha_type = return (Nothing, Nothing)
-getEncoding (Just te) ha_type = do
+openTextEncoding Nothing ha_type cont = cont Nothing Nothing
+openTextEncoding (Just TextEncoding{..}) ha_type cont = do
mb_decoder <- if isReadableHandleType ha_type then do
- decoder <- mkTextDecoder te
+ decoder <- mkTextDecoder
return (Just decoder)
else
return Nothing
mb_encoder <- if isWritableHandleType ha_type then do
- encoder <- mkTextEncoder te
+ encoder <- mkTextEncoder
return (Just encoder)
else
return Nothing
- return (mb_encoder, mb_decoder)
+ cont mb_encoder mb_decoder
-- ---------------------------------------------------------------------------
-- closing Handles
--- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
--- or an IO error occurs on a lazy stream. The semi-closed Handle is
--- then closed immediately. We have to be careful with DuplexHandles
--- though: we have to leave the closing to the finalizer in that case,
--- because the write side may still be in use.
+-- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when
+-- EOF is read or an IO error occurs on a lazy stream. The
+-- semi-closed Handle is then closed immediately. We have to be
+-- careful with DuplexHandles though: we have to leave the closing to
+-- the finalizer in that case, because the write side may still be in
+-- use.
hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return (handle_,Nothing)
- _ -> do flushWriteBuffer handle_ -- interruptible
- hClose_handle_ handle_
+ _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible
+ -- it is important that hClose doesn't fail and
+ -- leave the Handle open (#3128), so we catch
+ -- exceptions when flushing the buffer.
+ (h_, mb_exc2) <- hClose_handle_ handle_
+ return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)
+
+
+trymaybe :: IO () -> IO (Maybe SomeException)
+trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_handle_ Handle__{..} = do
-- raise it if necessary.
maybe_exception <-
case haOtherSide of
- Nothing -> (do IODevice.close haDevice; return Nothing)
- `catchException` \e -> return (Just e)
-
+ Nothing -> trymaybe $ IODevice.close haDevice
Just _ -> return Nothing
-- free the spare buffers
-- 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
debugIO ("writeTextDevice after encoding: cbuf=" ++ summaryBuffer cbuf' ++
" bbuf=" ++ summaryBuffer bbuf')
- Buffered.flushWriteBuffer haDevice bbuf'
- writeIORef haByteBuffer bbuf{bufL=0,bufR=0}
+ bbuf' <- Buffered.flushWriteBuffer haDevice bbuf'
+ writeIORef haByteBuffer bbuf'
if not (isEmptyBuffer cbuf')
then writeTextDevice h_ cbuf'
else return ()
debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
- writeIORef haLastDecode bbuf1
- (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", bbuf1)
+ latin1_decode bbuf1 cbuf
+ Just decoder -> do
+ state <- getState decoder
+ writeIORef haLastDecode (state, bbuf1)
+ (encode decoder) bbuf1 cbuf
debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
" bbuf=" ++ summaryBuffer bbuf2)
debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2)
- writeIORef haLastDecode bbuf2
- (bbuf3,cbuf') <- case haDecoder of
- Nothing -> latin1_decode bbuf2 cbuf
- Just decoder -> (encode decoder) bbuf2 cbuf
+ (bbuf3,cbuf') <-
+ case haDecoder of
+ Nothing -> do
+ writeIORef haLastDecode (error "codec_state", bbuf2)
+ latin1_decode bbuf2 cbuf
+ Just decoder -> do
+ state <- getState decoder
+ writeIORef haLastDecode (state, bbuf2)
+ (encode decoder) bbuf2 cbuf
debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
" bbuf=" ++ summaryBuffer 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)
+ (encode decoder) bbuf0 cbuf
writeIORef haByteBuffer bbuf2
return cbuf'
projects / ghc-base.git / blobdiff