{-# OPTIONS_GHC -XRecordWildCards #-}
{-# OPTIONS_HADDOCK hide #-}
-#undef DEBUG_DUMP
-
-----------------------------------------------------------------------------
-- |
-- Module : GHC.IO.Handle.Internals
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.Exception
-- import System.IO.Error
import System.Posix.Internals hiding (FD)
-#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 }
-- debugging
debugIO :: String -> IO ()
-#if defined(DEBUG_DUMP)
-debugIO s = do
- withCStringLen (s++"\n") $ \(p,len) -> c_write 1 (castPtr 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 ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
- (bbuf2,cbuf2) <-
+ (bbuf2,cbuf') <-
case haDecoder of
Nothing -> do
writeIORef haLastDecode (error "codec_state", bbuf1)
writeIORef haLastDecode (state, bbuf1)
(encode decoder) bbuf1 cbuf
- debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf2 ++
+ debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
" bbuf=" ++ summaryBuffer bbuf2)
- cbuf3 <- stripByteOrderMark cbuf2
-
writeIORef haByteBuffer bbuf2
- if bufR cbuf3 == bufR cbuf -- no new characters
+ if bufR cbuf' == bufR cbuf -- no new characters
then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char
- else return cbuf3
-
+ else return cbuf'
-- we have an incomplete byte sequence at the end of the buffer: try to
-- read more bytes.
readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
--
bbuf0 <- readIORef haByteBuffer
- bbuf1 <- if not (isEmptyBuffer bbuf0)
- then return bbuf0
- else do
- (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0
- if isNothing r 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
- (bbuf2,cbuf2) <-
+-- 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 -> do
- writeIORef haLastDecode (error "codec_state", bbuf1)
- latin1_decode bbuf1 cbuf
+ writeIORef haLastDecode (error "codec_state", bbuf0)
+ latin1_decode bbuf0 cbuf
Just decoder -> do
state <- getState decoder
- writeIORef haLastDecode (state, bbuf1)
- (encode decoder) bbuf1 cbuf
-
- cbuf3 <- stripByteOrderMark cbuf2
+ writeIORef haLastDecode (state, bbuf0)
+ (encode decoder) bbuf0 cbuf
writeIORef haByteBuffer bbuf2
- return cbuf3
-
-
--- | When converting from UTF-8 to UCS-4, Solaris iconv adds a Byte Order Mark (BOM)
--- of value 0xfeff to the start of the stream. We don't want to return this to
--- the caller, so strip it here. This is a safe operation for other platforms,
--- so always do it.
-stripByteOrderMark :: CharBuffer -> IO CharBuffer
-stripByteOrderMark cbuf
- | isEmptyBuffer cbuf
- = return cbuf
-
- | otherwise
- = do firstChar <- peekCharBuf (bufRaw cbuf) 0
- if firstChar == chr 0xfeff
- then return (bufferRemove 1 cbuf)
- else return cbuf
+ return cbuf'