Refactor Event Manager Backend to allow for arbitrty asynchronous IO

5 files changed, 70 insertions, 27 deletions

diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc
index 14324bc43d..cabc2775f5 100644
--- a/libraries/base/GHC/Event/EPoll.hsc
+++ b/libraries/base/GHC/Event/EPoll.hsc
@@ -71,7 +71,13 @@ new :: IO E.Backend
 new = do
   epfd <- epollCreate
   evts <- A.new 64
-  let !be = E.backend poll modifyFd modifyFdOnce delete (EPoll epfd evts)
+  let !be = E.backend
+                poll
+                modifyFd
+                modifyFdOnce
+                (\_ _ _ -> Nothing)
+                delete
+                (EPoll epfd evts)
   return be
 
 delete :: EPoll -> IO ()
@@ -109,7 +115,7 @@ modifyFdOnce ep fd evt =
 -- events that are ready.
 poll :: EPoll                     -- ^ state
      -> Maybe Timeout             -- ^ timeout in milliseconds
-     -> (Fd -> E.Event -> IO ())  -- ^ I/O callback
+     -> (E.IOResult -> IO ())     -- ^ I/O callback
      -> IO Int
 poll ep mtimeout f = do
   let events = epollEvents ep
@@ -122,7 +128,7 @@ poll ep mtimeout f = do
     Nothing      -> epollWaitNonBlock fd es cap
 
   when (n > 0) $ do
-    A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e))
+    A.forM_ events $ \e -> f (E.IOResult_Event (eventFd e) (toEvent (eventTypes e)))
     cap <- A.capacity events
     when (cap == n) $ A.ensureCapacity events (2 * cap)
   return n
diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs
index 5778c6f3fe..35d485587d 100644
--- a/libraries/base/GHC/Event/Internal.hs
+++ b/libraries/base/GHC/Event/Internal.hs
@@ -6,6 +6,8 @@ module GHC.Event.Internal
     -- * Event back end
       Backend
     , backend
+    , IOOperation
+    , IOResult(..)
     , delete
     , poll
     , modifyFd
@@ -33,11 +35,26 @@ import Data.OldList (foldl', filter, intercalate, null)
 import Foreign.C.Error (eINTR, getErrno, throwErrno)
 import System.Posix.Types (Fd)
 import GHC.Base
+import GHC.Event.Unique (Unique)
 import GHC.Word (Word64)
 import GHC.Num (Num(..))
 import GHC.Show (Show(..))
 import Data.Semigroup.Internal (stimesMonoid)
 
+
+data IOOperation -- TODO add actions
+    -- IOOperation_Read IOOperationID ...
+    -- IOOperation_Write IOOperationID ...
+    -- ...
+
+data IOResult
+    -- | An event has occurred for a file handle. See IOOperation_SetFdEvents and
+    = IOResult_Event Fd Event
+    -- IOResult_Read IOOperationID ...
+    -- IOResult_Write IOOperationID ...
+    -- ...
+
+
 -- | An I\/O event.
 newtype Event = Event Int
     deriving Eq -- ^ @since 4.4.0.0
@@ -161,10 +178,11 @@ data Backend = forall a. Backend {
 
     -- | Poll backend for new events.  The provided callback is called
     -- once per file descriptor with new events.
-    , _bePoll :: a                          -- backend state
-              -> Maybe Timeout              -- timeout in milliseconds ('Nothing' for non-blocking poll)
-              -> (Fd -> Event -> IO ())     -- I/O callback
-              -> IO Int
+    , _bePoll
+        :: a                    -- backend state
+        -> Maybe Timeout        -- timeout in milliseconds ('Nothing' for non-blocking poll)
+        -> (IOResult -> IO ())  -- I/O callback
+        -> IO Int               -- ???? negative is error, 0 is success but no IOResults found, positive is success with IO Results. ???
 
     -- | Register, modify, or unregister interest in the given events
     -- on the given file descriptor.
@@ -172,48 +190,61 @@ data Backend = forall a. Backend {
                   -> Fd       -- file descriptor
                   -> Event    -- old events to watch for ('mempty' for new)
                   -> Event    -- new events to watch for ('mempty' to delete)
-                  -> IO Bool
+                  -> IO Bool  -- The Bool indicates True for success,
+                              -- False for a known failure, else this may throw
+                              -- with `throwErrno`.
 
     -- | Register interest in new events on a given file descriptor, set
     -- to be deactivated after the first event.
     , _beModifyFdOnce :: a
                          -> Fd    -- file descriptor
                          -> Event -- new events to watch
-                         -> IO Bool
+                         -> IO Bool -- Bool indicates success (see _beModifyFd)
+
+    -- | Perform some IO action (non-blocking).
+    , _beDoIOOperation
+        :: a
+        -> Unique            -- Operation id.
+        -> IOOperation       -- action to perform
+        -> Maybe (IO Bool)   -- Nothing if the io action is not supported, and
+                             -- the caller should use Fd Events instead. Else
+                             -- Just the action to do the (non-blocking) IO
+                             -- action. Bool indicates success (see _beModifyFd).
 
     , _beDelete :: a -> IO ()
     }
 
-backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
+backend :: (a -> Maybe Timeout -> (IOResult -> IO ()) -> IO Int)
         -> (a -> Fd -> Event -> Event -> IO Bool)
         -> (a -> Fd -> Event -> IO Bool)
+        -> (a -> Unique -> IOOperation -> Maybe (IO Bool))
         -> (a -> IO ())
         -> a
         -> Backend
-backend bPoll bModifyFd bModifyFdOnce bDelete state =
-  Backend state bPoll bModifyFd bModifyFdOnce bDelete
+backend bPoll bModifyFd bModifyFdOnce bDoIOOperation bDelete state =
+  Backend state bPoll bModifyFd bModifyFdOnce bDoIOOperation bDelete
 {-# INLINE backend #-}
 
-poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
-poll (Backend bState bPoll _ _ _) = bPoll bState
+poll :: Backend -> Maybe Timeout -> (IOResult -> IO ()) -> IO Int
+poll (Backend bState bPoll _ _ _ _) = bPoll bState
 {-# INLINE poll #-}
 
 -- | Returns 'True' if the modification succeeded.
 -- Returns 'False' if this backend does not support
 -- event notifications on this type of file.
 modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
-modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
+modifyFd (Backend bState _ bModifyFd _ _ _) = bModifyFd bState
 {-# INLINE modifyFd #-}
 
 -- | Returns 'True' if the modification succeeded.
 -- Returns 'False' if this backend does not support
 -- event notifications on this type of file.
 modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
-modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
+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 'Prelude.IOError' corresponding to the current value of
diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs
index 51306795fe..53dd9ede32 100644
--- a/libraries/base/GHC/Event/Manager.hs
+++ b/libraries/base/GHC/Event/Manager.hs
@@ -293,12 +293,12 @@ step mgr@EventManager{..} = do
   state `seq` return state
   where
     waitForIO = do
-      n1 <- I.poll emBackend Nothing (onFdEvent mgr)
+      n1 <- I.poll emBackend Nothing (onIOResult mgr)
       when (n1 <= 0) $ do
         yield
-        n2 <- I.poll emBackend Nothing (onFdEvent mgr)
+        n2 <- I.poll emBackend Nothing (onIOResult mgr)
         when (n2 <= 0) $ do
-          _ <- I.poll emBackend (Just Forever) (onFdEvent mgr)
+          _ <- I.poll emBackend (Just Forever) (onIOResult mgr)
           return ()
 
 ------------------------------------------------------------------------
@@ -444,6 +444,11 @@ closeFd_ mgr tbl fd = do
 ------------------------------------------------------------------------
 -- Utilities
 
+-- | Call the callbacks corresponding ot the given IOResult.
+onIOResult :: EventManager -> I.IOResult -> IO ()
+onIOResult em ioResult = case ioResult of
+  I.IOResult_Event fd events -> onFdEvent em fd events
+
 -- | Call the callbacks corresponding to the given file descriptor.
 onFdEvent :: EventManager -> Fd -> Event -> IO ()
 onFdEvent mgr fd evs
diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc
index 370dd4a365..610434019e 100644
--- a/libraries/base/GHC/Event/Poll.hsc
+++ b/libraries/base/GHC/Event/Poll.hsc
@@ -51,7 +51,7 @@ data Poll = Poll {
     }
 
 new :: IO E.Backend
-new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) `liftM`
+new = E.backend poll modifyFd modifyFdOnce (\_ _ _ -> Nothing) (\_ -> return ()) `liftM`
       liftM2 Poll (newMVar =<< A.empty) A.empty
 
 modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO Bool
@@ -78,7 +78,7 @@ reworkFd p (PollFd fd npevt opevt) = do
 
 poll :: Poll
      -> Maybe E.Timeout
-     -> (Fd -> E.Event -> IO ())
+     -> (E.IOResult -> IO ())
      -> IO Int
 poll p mtout f = do
   let a = pollFd p
@@ -95,7 +95,7 @@ poll p mtout f = do
     A.loop a 0 $ \i e -> do
       let r = pfdRevents e
       if r /= 0
-        then do f (pfdFd e) (toEvent r)
+        then do f (E.IOResult_Event (pfdFd e) (toEvent r))
                 let i' = i + 1
                 return (i', i' == n)
         else return (i, True)
diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs
index 946f2333bf..774ac9345a 100644
--- a/libraries/base/GHC/Event/TimerManager.hs
+++ b/libraries/base/GHC/Event/TimerManager.hs
@@ -50,9 +50,8 @@ import GHC.Num (Num(..))
 import GHC.Real (quot, fromIntegral)
 import GHC.Show (Show(..))
 import GHC.Event.Control
-import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
+import GHC.Event.Internal (Backend, evtRead, Timeout(..))
 import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
-import System.Posix.Types (Fd)
 
 import qualified GHC.Event.Internal as I
 import qualified GHC.Event.PSQ as Q
@@ -99,13 +98,15 @@ data TimerManager = TimerManager
 ------------------------------------------------------------------------
 -- Creation
 
-handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
-handleControlEvent mgr fd _evt = do
+handleControlEvent :: TimerManager -> I.IOResult -> IO ()
+handleControlEvent mgr (I.IOResult_Event fd _evt) = do
   msg <- readControlMessage (emControl mgr) fd
   case msg of
     CMsgWakeup      -> return ()
     CMsgDie         -> writeIORef (emState mgr) Finished
     CMsgSignal fp s -> runHandlers fp s
+-- TimerManager should only use the event api of the backend to wait on timers.
+-- handleControlEvent _ _ = errorWithoutStackTrace "unexpected non-event IO result"
 
 newDefaultBackend :: IO Backend
 #if defined(HAVE_POLL)