X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO%2FHandle%2FInternals.hs;h=2c0523f9019e5c7b49d1b5e119e28fea4171046d;hb=b5c54282dc54cc861277ae532224775076a4818e;hp=6fb66c740de275a9f26f46e8be0613ee24b0cead;hpb=82b61ac8e14df43f84afc20c6f6691f433f07951;p=ghc-base.git diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs index 6fb66c7..2c0523f 100644 --- a/GHC/IO/Handle/Internals.hs +++ b/GHC/IO/Handle/Internals.hs @@ -1,12 +1,9 @@ {-# 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 @@ -31,13 +28,14 @@ module GHC.IO.Handle.Internals ( wantSeekableHandle, mkHandle, mkFileHandle, mkDuplexHandle, - openTextEncoding, initBufferState, + openTextEncoding, closeTextCodecs, initBufferState, dEFAULT_CHAR_BUFFER_SIZE, flushBuffer, flushWriteBuffer, flushWriteBuffer_, flushCharReadBuffer, flushCharBuffer, flushByteReadBuffer, readTextDevice, writeTextDevice, readTextDeviceNonBlocking, + decodeByteBuf, augmentIOError, ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, @@ -52,7 +50,7 @@ module GHC.IO.Handle.Internals ( 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) @@ -61,6 +59,7 @@ import GHC.IO.Device (IODevice, SeekMode(..)) 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 @@ -75,9 +74,10 @@ import Foreign -- 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 @@ -124,11 +124,8 @@ withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act 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 @@ -139,15 +136,9 @@ withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act 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 @@ -158,15 +149,62 @@ withAllHandles__ fun h@(DuplexHandle _ r w) act = do 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 } @@ -205,7 +243,8 @@ checkWritableHandle act h_@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_ @@ -270,8 +309,8 @@ checkSeekableHandle act handle_@Handle__{haDevice=dev} = -- 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 "" @@ -287,13 +326,9 @@ ioe_notWritable = ioException 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 "" @@ -476,7 +511,7 @@ flushByteReadBuffer h_@Handle__{..} = do 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) @@ -521,6 +556,7 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do haBuffers = spares, haEncoder = mb_encoder, haDecoder = mb_decoder, + haCodec = mb_codec, haInputNL = inputNL nl, haOutputNL = outputNL nl, haOtherSide = other_side @@ -596,6 +632,11 @@ openTextEncoding (Just TextEncoding{..}) ha_type cont = 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 @@ -621,7 +662,7 @@ 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 +hClose_handle_ h_@Handle__{..} = do -- close the file descriptor, but not when this is the read -- side of a duplex handle. @@ -640,8 +681,7 @@ hClose_handle_ Handle__{..} = do 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. @@ -676,13 +716,12 @@ hLookAhead_ handle_@Handle__{..} = do -- 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 @@ -704,8 +743,8 @@ writeTextDevice h_@Handle__{..} cbuf = do 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 () @@ -788,16 +827,28 @@ readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer 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 - (bbuf2,cbuf') <- case haDecoder of - Nothing -> latin1_decode bbuf1 cbuf - Just decoder -> (encode decoder) bbuf1 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 -> 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'