[commit: base] : Manager takes a flag that indicates whether it should de-register a file registration once it has received a callback. (ba2555e)

[Johan Tibell]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/ba2555ef51990e8fc08d7adbda7021e19fc43bda

>---------------------------------------------------------------

commit ba2555ef51990e8fc08d7adbda7021e19fc43bda
Author: Andreas Voellmy <andreas.voellmy at gmail.com>
Date:   Fri Dec 21 14:27:10 2012 -0500

    Manager takes a flag that indicates whether it should de-register a file registration once it has received a callback.
    
    Previously, GHC.Event.Thread.threadWait calls unregister on the file in the callback. With this flag on, the manager now performs the deregistration so that GHC.Event.Thread.threadWait does not have to. The motivation for the change is that for the common case that we deregister after receiving the callback, we can provide a more efficient implementation which reduces the number of times the callback table lock is taken in half and also reduces the number of sysystem calls we make to the backend. This commit does not implement that optimization; it just paves the way for this change in future.

>---------------------------------------------------------------

 GHC/Event.hs         |    1 +
 GHC/Event/Manager.hs |   17 ++++++++++-------
 GHC/Event/Thread.hs  |    6 +++---
 3 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/GHC/Event.hs b/GHC/Event.hs
index 8cf9b46..b49645e 100644
--- a/GHC/Event.hs
+++ b/GHC/Event.hs
@@ -14,6 +14,7 @@ module GHC.Event
 
       -- * Creation
     , getSystemEventManager
+    , new
     , getSystemTimerManager
 
       -- * Registering interest in I/O events
diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs
index 0dfc18a..8dea518 100644
--- a/GHC/Event/Manager.hs
+++ b/GHC/Event/Manager.hs
@@ -50,7 +50,7 @@ module GHC.Event.Manager
 
 import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar)
 import Control.Exception (finally)
-import Control.Monad ((=<<), forM_, liftM, sequence_, when, replicateM)
+import Control.Monad ((=<<), forM_, liftM, sequence_, when, replicateM, void)
 import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef,
                    writeIORef)
 import Data.Maybe (Maybe(..))
@@ -113,6 +113,7 @@ data EventManager = EventManager
     , emState        :: {-# UNPACK #-} !(IORef State)
     , emUniqueSource :: {-# UNPACK #-} !UniqueSource
     , emControl      :: {-# UNPACK #-} !Control
+    , emOneShot      :: {-# UNPACK #-} !Bool
     }
 
 callbackArraySize :: Int
@@ -148,11 +149,11 @@ newDefaultBackend = error "no back end for this platform"
 #endif
 
 -- | Create a new event manager.
-new :: IO EventManager
-new = newWith =<< newDefaultBackend
+new :: Bool -> IO EventManager
+new oneShot = newWith oneShot =<< newDefaultBackend
 
-newWith :: Backend -> IO EventManager
-newWith be = do
+newWith :: Bool -> Backend -> IO EventManager
+newWith oneShot be = do
   iofds <- fmap (listArray (0, callbackArraySize-1)) $
            replicateM callbackArraySize (newMVar IM.empty)
   ctrl <- newControl False
@@ -168,6 +169,7 @@ newWith be = do
                          , emState = state
                          , emUniqueSource = us
                          , emControl = ctrl
+                         , emOneShot = oneShot
                          }
   registerControlFd mgr (controlReadFd ctrl) evtRead
   registerControlFd mgr (wakeupReadFd ctrl) evtRead
@@ -332,8 +334,9 @@ onFdEvent mgr fd evs =
   then handleControlEvent mgr fd evs
   else do fds <- readMVar (callbackTableVar mgr fd)
           case IM.lookup (fromIntegral fd) fds of
-            Just cbs -> forM_ cbs $ \(FdData reg ev cb) ->
-                        when (evs `I.eventIs` ev) $ cb reg evs
+            Just cbs -> forM_ cbs $ \(FdData reg ev cb) -> do
+              when (emOneShot mgr) $ void $ unregisterFd_ mgr reg
+              when (evs `I.eventIs` ev) $ cb reg evs
             Nothing  -> return ()
 
 nullToNothing :: [a] -> Maybe [a]
diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs
index e68ab2f..9b19213 100644
--- a/GHC/Event/Thread.hs
+++ b/GHC/Event/Thread.hs
@@ -112,7 +112,7 @@ threadWait :: Event -> Fd -> IO ()
 threadWait evt fd = mask_ $ do
   m <- newEmptyMVar
   mgr <- getSystemEventManager
-  reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
+  reg <- registerFd mgr (\_ e -> putMVar m e) fd evt
   evt' <- takeMVar m `onException` unregisterFd_ mgr reg
   if evt' `eventIs` evtClose
     then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
@@ -123,7 +123,7 @@ threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
 threadWaitSTM evt fd = mask_ $ do
   m <- newTVarIO Nothing
   mgr <- getSystemEventManager 
-  reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> atomically (writeTVar m (Just e))) fd evt
+  reg <- registerFd mgr (\_ e -> atomically (writeTVar m (Just e))) fd evt
   let waitAction =
         do mevt <- readTVar m
            case mevt of
@@ -226,7 +226,7 @@ startIOManagerThreads =
 startIOManagerThread :: Int -> IO ()
 startIOManagerThread i = do
   let create = do
-        !mgr <- new
+        !mgr <- new True
         !t <- forkOn i $ loop mgr
         labelThread t "IOManager"
         writeIOArray eventManager i (Just (t,mgr))