X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO%2FHandle%2FInternals.hs;h=2c0523f9019e5c7b49d1b5e119e28fea4171046d;hb=b5c54282dc54cc861277ae532224775076a4818e;hp=cc9e3d3aa5dd3cb56099ed8a59153598a94e2ad2;hpb=03775face7c6cb722196461ef063bf7e2efc4252;p=ghc-base.git

diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs
index cc9e3d3..2c0523f 100644
--- a/GHC/IO/Handle/Internals.hs
+++ b/GHC/IO/Handle/Internals.hs
@@ -4,8 +4,6 @@
 {-# OPTIONS_GHC -XRecordWildCards #-}
 {-# OPTIONS_HADDOCK hide #-}
 
-#undef DEBUG_DUMP
-
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO.Handle.Internals
@@ -30,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,
@@ -51,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)
@@ -60,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
@@ -74,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
@@ -123,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
@@ -138,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
@@ -157,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 }
@@ -593,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
 
@@ -618,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.
@@ -637,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.
@@ -673,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 (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
@@ -785,22 +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.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
+
+-- 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
+               writeIORef haLastDecode (state, bbuf0)
+               (encode decoder) bbuf0 cbuf
 
   writeIORef haByteBuffer bbuf2
   return cbuf'