[commit: base] : Allow backends to provide a command that register interest for an event source for exactly one event, and implement epoll implementation of this command. (11e074f)

[Johan Tibell]

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/11e074fde8f30a6953fcf8c237fa4699fef3b1d2

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

commit 11e074fde8f30a6953fcf8c237fa4699fef3b1d2
Author: Andreas Voellmy <andreas.voellmy at gmail.com>
Date:   Fri Dec 21 11:56:09 2012 -0500

    Allow backends to provide a command that register interest for an event source for exactly one event, and implement epoll implementation of this command.

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

 GHC/Event/EPoll.hsc   |   28 +++++++++++++++++++++++-----
 GHC/Event/Internal.hs |   20 ++++++++++++++++----
 GHC/Event/KQueue.hsc  |    5 ++++-
 GHC/Event/Poll.hsc    |    5 ++++-
 4 files changed, 47 insertions(+), 11 deletions(-)

diff --git a/GHC/Event/EPoll.hsc b/GHC/Event/EPoll.hsc
index 9a5084f..1f6e2e7 100644
--- a/GHC/Event/EPoll.hsc
+++ b/GHC/Event/EPoll.hsc
@@ -40,12 +40,13 @@ available = False
 
 #include <sys/epoll.h>
 
-import Control.Monad (when)
+import Control.Monad (unless, when)
 import Data.Bits (Bits, (.|.), (.&.))
 import Data.Maybe (Maybe(..))
 import Data.Monoid (Monoid(..))
 import Data.Word (Word32)
-import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_)
+import Foreign.C.Error (eNOENT, getErrno, throwErrno,
+                        throwErrnoIfMinus1, throwErrnoIfMinus1_)
 import Foreign.C.Types (CInt(..))
 import Foreign.Marshal.Utils (with)
 import Foreign.Ptr (Ptr)
@@ -76,7 +77,7 @@ new :: IO E.Backend
 new = do
   epfd <- epollCreate
   evts <- A.new 64
-  let !be = E.backend poll modifyFd delete (EPoll epfd evts)
+  let !be = E.backend poll modifyFd modifyFdOnce delete (EPoll epfd evts)
   return be
 
 delete :: EPoll -> IO ()
@@ -93,6 +94,18 @@ modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $
            | nevt == mempty = controlOpDelete
            | otherwise      = controlOpModify
 
+modifyFdOnce :: EPoll -> Fd -> E.Event -> IO ()
+modifyFdOnce ep fd evt =
+  do let !ev = fromEvent evt .|. epollOneShot
+     res <- with (Event ev fd) $
+            epollControl_ (epollFd ep) controlOpModify fd
+     unless (res == 0) $ do
+         err <- getErrno
+         if err == eNOENT then
+             with (Event ev fd) $ epollControl (epollFd ep) controlOpAdd fd
+           else
+             throwErrno "modifyFdOnce"
+
 -- | Select a set of file descriptors which are ready for I/O
 -- operations and call @f@ for all ready file descriptors, passing the
 -- events that are ready.
@@ -155,6 +168,7 @@ newtype EventType = EventType {
  , epollOut = EPOLLOUT
  , epollErr = EPOLLERR
  , epollHup = EPOLLHUP
+ , epollOneShot = EPOLLONESHOT              
  }
 
 -- | Create a new epoll context, returning a file descriptor associated with the context.
@@ -174,8 +188,12 @@ epollCreate = do
   return epollFd'
 
 epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
-epollControl (EPollFd epfd) (ControlOp op) (Fd fd) event =
-    throwErrnoIfMinus1_ "epollControl" $ c_epoll_ctl epfd op fd event
+epollControl epfd op fd event =
+    throwErrnoIfMinus1_ "epollControl" $ epollControl_ epfd op fd event
+
+epollControl_ :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt
+epollControl_ (EPollFd epfd) (ControlOp op) (Fd fd) event =
+    c_epoll_ctl epfd op fd event
 
 epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int
 epollWait (EPollFd epfd) events numEvents timeout =
diff --git a/GHC/Event/Internal.hs b/GHC/Event/Internal.hs
index 9636941..7b25c86 100644
--- a/GHC/Event/Internal.hs
+++ b/GHC/Event/Internal.hs
@@ -9,6 +9,7 @@ module GHC.Event.Internal
     , delete
     , poll
     , modifyFd
+    , modifyFdOnce
     -- * Event type
     , Event
     , evtRead
@@ -103,27 +104,38 @@ data Backend = forall a. Backend {
                   -> Event    -- new events to watch for ('mempty' to delete)
                   -> IO ()
 
+    , _beModifyFdOnce :: a
+                         -> Fd    -- file descriptor
+                         -> Event -- new events to watch
+                         -> IO ()
+
     , _beDelete :: a -> IO ()
     }
 
 backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
         -> (a -> Fd -> Event -> Event -> IO ())
+        -> (a -> Fd -> Event -> IO ())
         -> (a -> IO ())
         -> a
         -> Backend
-backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete
+backend bPoll bModifyFd bModifyFdOnce bDelete state =
+  Backend state bPoll bModifyFd bModifyFdOnce bDelete
 {-# INLINE backend #-}
 
 poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
-poll (Backend bState bPoll _ _) = bPoll bState
+poll (Backend bState bPoll _ _ _) = bPoll bState
 {-# INLINE poll #-}
 
 modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
-modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState
+modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
 {-# INLINE modifyFd #-}
 
+modifyFdOnce :: Backend -> Fd -> Event -> IO ()
+modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
+{-# INLINE modifyFdOnce #-}
+
 delete :: Backend -> IO ()
-delete (Backend bState _ _ bDelete) = bDelete bState
+delete (Backend bState _ _ _ bDelete) = bDelete bState
 {-# INLINE delete #-}
 
 -- | Throw an 'IOError' corresponding to the current value of
diff --git a/GHC/Event/KQueue.hsc b/GHC/Event/KQueue.hsc
index 2db7b19..9aa47a3 100644
--- a/GHC/Event/KQueue.hsc
+++ b/GHC/Event/KQueue.hsc
@@ -86,7 +86,7 @@ new = do
   changesArr <- A.empty
   changes <- newMVar changesArr 
   events <- A.new 64
-  let !be = E.backend poll modifyFd delete (EventQueue qfd changes events)
+  let !be = E.backend poll modifyFd modifyFdOnce delete (EventQueue qfd changes events)
   return be
 
 delete :: EventQueue -> IO ()
@@ -102,6 +102,9 @@ modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do
   when (nevt `E.eventIs` E.evtRead)  $ addChange filterRead flagAdd
   when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd
 
+modifyFdOnce :: EventQueue -> Fd -> E.Event -> IO ()
+modifyFdOnce = error "modifyFdOnce not supported in KQueue backend"
+
 poll :: EventQueue
      -> Maybe Timeout
      -> (Fd -> E.Event -> IO ())
diff --git a/GHC/Event/Poll.hsc b/GHC/Event/Poll.hsc
index a132bd4..d73d813 100644
--- a/GHC/Event/Poll.hsc
+++ b/GHC/Event/Poll.hsc
@@ -55,7 +55,7 @@ data Poll = Poll {
     }
 
 new :: IO E.Backend
-new = E.backend poll modifyFd (\_ -> return ()) `liftM`
+new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) `liftM`
       liftM2 Poll (newMVar =<< A.empty) A.empty
 
 modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO ()
@@ -63,6 +63,9 @@ modifyFd p fd oevt nevt =
   withMVar (pollChanges p) $ \ary ->
     A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)
 
+modifyFdOnce :: Poll -> Fd -> E.Event -> IO ()
+modifyFdOnce = error "modifyFdOnce not supported in Poll backend"
+
 reworkFd :: Poll -> PollFd -> IO ()
 reworkFd p (PollFd fd npevt opevt) = do
   let ary = pollFd p