[Git][ghc/ghc][wip/io_uring] Refactor Event Manager Backend to allow for arbitrty asynchronous IO
David Eichmann
gitlab at gitlab.haskell.org
Fri May 29 14:10:18 UTC 2020
David Eichmann pushed to branch wip/io_uring at Glasgow Haskell Compiler / GHC
Commits:
576e092b by David Eichmann at 2020-05-29T15:09:48+01:00
Refactor Event Manager Backend to allow for arbitrty asynchronous IO
- - - - -
5 changed files:
- libraries/base/GHC/Event/EPoll.hsc
- libraries/base/GHC/Event/Internal.hs
- libraries/base/GHC/Event/Manager.hs
- libraries/base/GHC/Event/Poll.hsc
- libraries/base/GHC/Event/TimerManager.hs
Changes:
=====================================
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
=====================================
libraries/base/GHC/Event/Internal.hs
=====================================
@@ -6,6 +6,8 @@ module GHC.Event.Internal
-- * Event back end
Backend
, backend
+ , IOAction
+ , IOResult(..)
, delete
, poll
, modifyFd
@@ -38,6 +40,22 @@ import GHC.Num (Num(..))
import GHC.Show (Show(..))
import Data.Semigroup.Internal (stimesMonoid)
+
+data IOAction -- TODO add actions
+ -- IOAction_Read IOActionID ...
+ -- IOAction_Write IOActionID ...
+ -- ...
+
+data IOResult
+ -- | An event has occurred for a file handle. See IOAction_SetFdEvents and
+ -- IOAction_SetFdEventsOnce.
+ = IOResult_Event Fd Event
+
+ -- IOResult_Read IOActionID ...
+ -- IOResult_Write IOActionID ...
+ -- ...
+
+
-- | An I\/O event.
newtype Event = Event Int
deriving Eq -- ^ @since 4.4.0.0
@@ -161,10 +179,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 +191,60 @@ 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).
+ , _beDoIOAction
+ :: a
+ -> IOAction -- 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 -> IOAction -> Maybe (IO Bool))
-> (a -> IO ())
-> a
-> Backend
-backend bPoll bModifyFd bModifyFdOnce bDelete state =
- Backend state bPoll bModifyFd bModifyFdOnce bDelete
+backend bPoll bModifyFd bModifyFdOnce bDoIOAction bDelete state =
+ Backend state bPoll bModifyFd bModifyFdOnce bDoIOAction 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
=====================================
libraries/base/GHC/Event/Manager.hs
=====================================
@@ -293,12 +293,12 @@ step mgr at 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
=====================================
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)
=====================================
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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/576e092b4a506a9b8bbc7702b03dbf80adb478fe
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/576e092b4a506a9b8bbc7702b03dbf80adb478fe
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200529/defcfdf2/attachment-0001.html>
More information about the ghc-commits
mailing list