Ticket #4533: fix-4533.dpatch

5 patches for repository http://darcs.haskell.org/ghc-7.0/packages/base:

Fri Nov 26 12:08:41 PST 2010  Bryan O'Sullivan <bos@serpentine.com>
  * Fix typo

Fri Nov 26 15:27:56 PST 2010  Bryan O'Sullivan <bos@serpentine.com>
  * Bump the version of base

Fri Nov 26 15:28:10 PST 2010  Bryan O'Sullivan <bos@serpentine.com>
  * Fix #4514 - IO manager deadlock
  
  * The public APIs for threadWaitRead and threadWaitWrite remain unchanged,
    and now throw an IOError if a file descriptor is closed behind their
    backs.  This behaviour is documented.
  
  * The GHC.Conc API is extended to add a closeFd function, the behaviour
    of which is documented.
  
  * Behind the scenes, we add a new evtClose event, which is used only when
    one thread closes a file descriptor that other threads are blocking on.
  
  * Both base's IO code and network use the new closeFd function.
  

Fri Nov 26 22:04:25 PST 2010  Bryan O'Sullivan <bos@serpentine.com>
  * Drop System.Mem.Weak's dependency on Prelude

Sat Nov 27 10:18:26 PST 2010  Bryan O'Sullivan <bos@serpentine.com>
  * Fix #4533 - unregister callbacks on exception, fixing a memory leak
  
  Our problem here was that if a thread blocked in threadWait or
  threadDelay and was killed by an exception thrown from another thread,
  its registration with the IO manager would not be cleared.
  
  The fix is simply to install exception handlers that do the cleanup and
  propagate the exception.
  

New patches:

[Fix typo
Bryan O'Sullivan <bos@serpentine.com>**20101126200841
 Ignore-this: fc81cd0e820931df6dc87c52751594ef
] hunk ./System/Event/KQueue.hsc 281
 toEvent (Filter f)
     | f == (#const EVFILT_READ) = E.evtRead
     | f == (#const EVFILT_WRITE) = E.evtWrite
-    | otherwise = error $ "toEvent: unknonwn filter " ++ show f
+    | otherwise = error $ "toEvent: unknown filter " ++ show f
 
 foreign import ccall unsafe "kqueue"
     c_kqueue :: IO CInt
[Bump the version of base
Bryan O'Sullivan <bos@serpentine.com>**20101126232756
 Ignore-this: deae33d1f0411b39d2f04e3e3e4e3598
] hunk ./base.cabal 2
 name:           base
-version:        4.3.0.0
+version:        4.3.1.0
 license:        BSD3
 license-file:   LICENSE
 maintainer:     libraries@haskell.org
[Fix #4514 - IO manager deadlock
Bryan O'Sullivan <bos@serpentine.com>**20101126232810
 Ignore-this: 9deacf960c78c797ef6859b60ca9922
 
 * The public APIs for threadWaitRead and threadWaitWrite remain unchanged,
   and now throw an IOError if a file descriptor is closed behind their
   backs.  This behaviour is documented.
 
 * The GHC.Conc API is extended to add a closeFd function, the behaviour
   of which is documented.
 
 * Behind the scenes, we add a new evtClose event, which is used only when
   one thread closes a file descriptor that other threads are blocking on.
 
 * Both base's IO code and network use the new closeFd function.
 
] {
hunk ./Control/Concurrent.hs 50
         threadDelay,            -- :: Int -> IO ()
         threadWaitRead,         -- :: Int -> IO ()
         threadWaitWrite,        -- :: Int -> IO ()
+        closeFd,                -- :: (Int -> IO ()) -> Int -> IO ()
 #endif
 
         -- * Communication abstractions
hunk ./Control/Concurrent.hs 454
 
 -- | Block the current thread until data is available to read on the
 -- given file descriptor (GHC only).
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread was blocked.
 threadWaitRead :: Fd -> IO ()
 threadWaitRead fd
 #ifdef mingw32_HOST_OS
hunk ./Control/Concurrent.hs 477
 
 -- | Block the current thread until data can be written to the
 -- given file descriptor (GHC only).
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread was blocked.
 threadWaitWrite :: Fd -> IO ()
 threadWaitWrite fd
 #ifdef mingw32_HOST_OS
hunk ./Control/Concurrent.hs 489
   = GHC.Conc.threadWaitWrite fd
 #endif
 
+-- | Close a file descriptor in a concurrency-safe way (GHC only).  If
+-- you are using 'threadWaitRead' or 'threadWaitWrite' to perform
+-- blocking I\/O, you /must/ use this function to close file
+-- descriptors, or blocked threads may not be woken.
+--
+-- Any threads that are blocked on the file descriptor via
+-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
+-- IO exceptions thrown.
+closeFd :: (Fd -> IO ())        -- ^ Low-level action that performs the real close.
+        -> Fd                   -- ^ File descriptor to close.
+        -> IO ()
+closeFd close fd
+#ifdef mingw32_HOST_OS
+  = close fd
+#else
+  = GHC.Conc.closeFd close fd
+#endif
+
 #ifdef mingw32_HOST_OS
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 
hunk ./GHC/Conc.lhs 55
         , registerDelay         -- :: Int -> IO (TVar Bool)
         , threadWaitRead        -- :: Int -> IO ()
         , threadWaitWrite       -- :: Int -> IO ()
+        , closeFd               -- :: (Int -> IO ()) -> Int -> IO ()
 
         -- * TVars
         , STM(..)
hunk ./GHC/Conc/IO.hs 34
         , registerDelay         -- :: Int -> IO (TVar Bool)
         , threadWaitRead        -- :: Int -> IO ()
         , threadWaitWrite       -- :: Int -> IO ()
+        , closeFd               -- :: (Int -> IO ()) -> Int -> IO ()
 
 #ifdef mingw32_HOST_OS
         , asyncRead     -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
hunk ./GHC/Conc/IO.hs 86
 
 -- | Block the current thread until data can be written to the
 -- given file descriptor (GHC only).
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread was blocked.
 threadWaitWrite :: Fd -> IO ()
 threadWaitWrite fd
 #ifndef mingw32_HOST_OS
hunk ./GHC/Conc/IO.hs 99
         case waitWrite# fd# s of { s' -> (# s', () #)
         }}
 
+-- | Close a file descriptor in a concurrency-safe way (GHC only).  If
+-- you are using 'threadWaitRead' or 'threadWaitWrite' to perform
+-- blocking I\/O, you /must/ use this function to close file
+-- descriptors, or blocked threads may not be woken.
+--
+-- Any threads that are blocked on the file descriptor via
+-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
+-- IO exceptions thrown.
+closeFd :: (Fd -> IO ())        -- ^ Low-level action that performs the real close.
+        -> Fd                   -- ^ File descriptor to close.
+        -> IO ()
+closeFd close fd
+#ifndef mingw32_HOST_OS
+  | threaded  = Event.closeFd close fd
+#endif
+  | otherwise = close fd
+
 -- | Suspends the current thread for a given number of microseconds
 -- (GHC only).
 --
hunk ./GHC/IO/FD.hs 284
 #ifndef mingw32_HOST_OS
   (flip finally) (release fd) $ do
 #endif
-  throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
+  let closer realFd =
+        throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
 #ifdef mingw32_HOST_OS
hunk ./GHC/IO/FD.hs 287
-    if fdIsSocket fd then
-       c_closesocket (fdFD fd)
-    else
+        if fdIsSocket fd then
+          c_closesocket (fromIntegral realFd)
+        else
 #endif
hunk ./GHC/IO/FD.hs 291
-       c_close (fdFD fd)
+          c_close (fromIntegral realFd)
+  closeFd closer (fromIntegral (fdFD fd))
 
 release :: FD -> IO ()
 #ifdef mingw32_HOST_OS
hunk ./System/Event.hs 25
     , registerFd_
     , unregisterFd
     , unregisterFd_
-    , fdWasClosed
+    , closeFd
 
       -- * Registering interest in timeout events
     , TimeoutCallback
hunk ./System/Event/Internal.hs 15
     , Event
     , evtRead
     , evtWrite
+    , evtClose
     , eventIs
     -- * Timeout type
     , Timeout(..)
hunk ./System/Event/Internal.hs 33
 import GHC.Show (Show(..))
 import GHC.List (filter, null)
 
--- | An I/O event.
+-- | An I\/O event.
 newtype Event = Event Int
     deriving (Eq)
 
hunk ./System/Event/Internal.hs 41
 evtNothing = Event 0
 {-# INLINE evtNothing #-}
 
+-- | Data is available to be read.
 evtRead :: Event
 evtRead = Event 1
 {-# INLINE evtRead #-}
hunk ./System/Event/Internal.hs 46
 
+-- | The file descriptor is ready to accept a write.
 evtWrite :: Event
 evtWrite = Event 2
 {-# INLINE evtWrite #-}
hunk ./System/Event/Internal.hs 51
 
+-- | Another thread closed the file descriptor.
+evtClose :: Event
+evtClose = Event 4
+{-# INLINE evtClose #-}
+
 eventIs :: Event -> Event -> Bool
 eventIs (Event a) (Event b) = a .&. b /= 0
 
hunk ./System/Event/Internal.hs 61
 instance Show Event where
     show e = '[' : (intercalate "," . filter (not . null) $
-                    [evtRead `so` "evtRead", evtWrite `so` "evtWrite"]) ++ "]"
+                    [evtRead `so` "evtRead",
+                     evtWrite `so` "evtWrite",
+                     evtClose `so` "evtClose"]) ++ "]"
         where ev `so` disp | e `eventIs` ev = disp
                            | otherwise      = ""
 
hunk ./System/Event/Manager.hs 29
     , registerFd
     , unregisterFd_
     , unregisterFd
-    , fdWasClosed
+    , closeFd
 
       -- * Registering interest in timeout events
     , TimeoutCallback
hunk ./System/Event/Manager.hs 51
 import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef,
                    writeIORef)
 import Data.Maybe (Maybe(..))
-import Data.Monoid (mconcat, mempty)
+import Data.Monoid (mappend, mconcat, mempty)
 import GHC.Base
 import GHC.Conc.Signal (runHandlers)
 import GHC.List (filter)
hunk ./System/Event/Manager.hs 60
 import GHC.Show (Show(..))
 import System.Event.Clock (getCurrentTime)
 import System.Event.Control
-import System.Event.Internal (Backend, Event, evtRead, evtWrite, Timeout(..))
+import System.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite,
+                              Timeout(..))
 import System.Event.Unique (Unique, UniqueSource, newSource, newUnique)
 import System.Posix.Types (Fd)
 
hunk ./System/Event/Manager.hs 335
   wake <- unregisterFd_ mgr reg
   when wake $ wakeManager mgr
 
--- | Notify the event manager that a file descriptor has been closed.
-fdWasClosed :: EventManager -> Fd -> IO ()
-fdWasClosed mgr fd =
-  modifyMVar_ (emFds mgr) $ \oldMap ->
+-- | Close a file descriptor in a race-safe way.
+closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO ()
+closeFd mgr close fd = do
+  fds <- modifyMVar (emFds mgr) $ \oldMap -> do
+    close fd
     case IM.delete (fromIntegral fd) oldMap of
hunk ./System/Event/Manager.hs 341
-      (Nothing,  _)       -> return oldMap
+      (Nothing,  _)       -> return (oldMap, [])
       (Just fds, !newMap) -> do
         when (eventsOf fds /= mempty) $ wakeManager mgr
hunk ./System/Event/Manager.hs 344
-        return newMap
+        return (newMap, fds)
+  forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose)
 
 ------------------------------------------------------------------------
 -- Registering interest in timeout events
hunk ./System/Event/Thread.hs 8
       ensureIOManagerIsRunning
     , threadWaitRead
     , threadWaitWrite
+    , closeFd
     , threadDelay
     , registerDelay
     ) where
hunk ./System/Event/Thread.hs 15
 
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (Maybe(..))
+import Foreign.C.Error (eBADF, errnoToIOError)
 import Foreign.Ptr (Ptr)
 import GHC.Base
 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
hunk ./System/Event/Thread.hs 21
                       labelThread, modifyMVar_, newTVar, sharedCAF,
                       threadStatus, writeTVar)
+import GHC.IO.Exception (ioError)
 import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
hunk ./System/Event/Thread.hs 23
+import GHC.Real (fromIntegral)
+import System.Event.Internal (eventIs, evtClose)
 import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
                              new, registerFd, unregisterFd_, registerTimeout)
hunk ./System/Event/Thread.hs 27
+import qualified System.Event.Manager as M
 import System.IO.Unsafe (unsafePerformIO)
 import System.Posix.Types (Fd)
 
hunk ./System/Event/Thread.hs 56
 
 -- | Block the current thread until data is available to read from the
 -- given file descriptor.
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread is blocked.
 threadWaitRead :: Fd -> IO ()
 threadWaitRead = threadWait evtRead
 {-# INLINE threadWaitRead #-}
hunk ./System/Event/Thread.hs 65
 
 -- | Block the current thread until the given file descriptor can
 -- accept data to write.
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread is blocked.
 threadWaitWrite :: Fd -> IO ()
 threadWaitWrite = threadWait evtWrite
 {-# INLINE threadWaitWrite #-}
hunk ./System/Event/Thread.hs 72
 
+-- | Close a file descriptor in a concurrency-safe way.
+--
+-- Any threads that are blocked on the file descriptor via
+-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
+-- IO exceptions thrown.
+closeFd :: (Fd -> IO ())        -- ^ Action that performs the close.
+        -> Fd                   -- ^ File descriptor to close.
+        -> IO ()
+closeFd close fd = do
+  Just mgr <- readIORef eventManager
+  M.closeFd mgr close fd
+
 threadWait :: Event -> Fd -> IO ()
 threadWait evt fd = do
   m <- newEmptyMVar
hunk ./System/Event/Thread.hs 88
   Just mgr <- readIORef eventManager
-  _ <- registerFd mgr (\reg _ -> unregisterFd_ mgr reg >> putMVar m ()) fd evt
-  takeMVar m
+  _ <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
+  evt' <- takeMVar m
+  if evt' `eventIs` evtClose
+    then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
+    else return ()
 
 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
     getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
}
[Drop System.Mem.Weak's dependency on Prelude
Bryan O'Sullivan <bos@serpentine.com>**20101127060425
 Ignore-this: e33216175ae42fe438d8be153cef0fd9
] {
hunk ./System/Mem/Weak.hs 70
        -- $precise
    ) where
 
-import Prelude
+import Data.Maybe (Maybe(..))
 
 #ifdef __HUGS__
 import Hugs.Weak
hunk ./System/Mem/Weak.hs 74
+import Prelude
 #endif
 
 #ifdef __GLASGOW_HASKELL__
hunk ./System/Mem/Weak.hs 78
+import GHC.Base (return)
+import GHC.Types (IO)
 import GHC.Weak
 #endif
 
}
[Fix #4533 - unregister callbacks on exception, fixing a memory leak
Bryan O'Sullivan <bos@serpentine.com>**20101127181826
 Ignore-this: c37da82a058637c285a2b2fee4eee217
 
 Our problem here was that if a thread blocked in threadWait or
 threadDelay and was killed by an exception thrown from another thread,
 its registration with the IO manager would not be cleared.
 
 The fix is simply to install exception handlers that do the cleanup and
 propagate the exception.
 
] {
hunk ./System/Event/Thread.hs 13
     , registerDelay
     ) where
 
+import Control.Exception (SomeException, catch, throw)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (Maybe(..))
 import Foreign.C.Error (eBADF, errnoToIOError)
hunk ./System/Event/Thread.hs 42
 threadDelay usecs = do
   Just mgr <- readIORef eventManager
   m <- newEmptyMVar
-  _ <- registerTimeout mgr usecs (putMVar m ())
-  takeMVar m
+  reg <- registerTimeout mgr usecs (putMVar m ())
+  takeMVar m `catch` \(e::SomeException) ->
+    M.unregisterTimeout mgr reg >> throw e
 
 -- | Set the value of returned TVar to True after a given number of
 -- microseconds. The caveats associated with threadDelay also apply.
hunk ./System/Event/Thread.hs 90
 threadWait evt fd = do
   m <- newEmptyMVar
   Just mgr <- readIORef eventManager
-  _ <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
-  evt' <- takeMVar m
+  reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
+  evt' <- takeMVar m `catch` \(e::SomeException) ->
+            unregisterFd_ mgr reg >> throw e
   if evt' `eventIs` evtClose
     then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
     else return ()
}

Context:

[use LANGUAGE instead of OPTIONS_GHC
Simon Marlow <marlowsd@gmail.com>**20101124162530
 Ignore-this: b72019eeeb706f366706578a45b22d46
] 
[The 7.0 branch doesn't know about -fno-warn-identities
Ian Lynagh <igloo@earth.li>**20101125143652] 
[Fixing uses of fromIntegral for Windows
dimitris@microsoft.com**20101117183351] 
[Encode immediately in hPutStr and hPutChar
Simon Marlow <marlowsd@gmail.com>**20101125102520
 Ignore-this: 1503393cde63dd99a1e8c9d716bcbe10
 This means that decoding errors will be detected accurately, and can
 be caught and handled.  Overall the implementation is simpler this way
 too.
 
 It does impose a performance hit on small hPutStrs, although larger
 hPutStrs seem to be unaffected.  To compensate somewhat, I optimised
 hPutStrLn.
] 
[Remove unnecessary fromIntegral calls
simonpj@microsoft.com**20101116172451
 Ignore-this: 8c44dc2b381c050d4eaaf287bbc55b9
] 
[fix hTell behaviour with Unicode Handles
Simon Marlow <marlowsd@gmail.com>**20101125121831
 Ignore-this: bb6fefd609a30c106e877783e0f9e0a4
] 
[Don't throw an error if the output buffer had no room
Simon Marlow <marlowsd@gmail.com>**20101124164221
 Ignore-this: 45023b77b7d107daae552d36701a225a
 This is consistent with the other codecs, and will be relied on by
 some upcoming changes in the IO library.
] 
[doc fix: don't refer to unblock.
Simon Marlow <marlowsd@gmail.com>**20101108133212
 Ignore-this: 52da909a3d262dda2c5f8e616da8ace3
] 
[TAG base 4.3.0.0 release
Ian Lynagh <igloo@earth.li>**20101117140835] 
Patch bundle hash:
d88c3036c9aa2a122852ea940d368079363add4a