{-# LANGUAGE BangPatterns #-}{-# LANGUAGE CPP #-}{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE NoImplicitPrelude #-}{-# LANGUAGE RecordWildCards #-}{-# LANGUAGE Trustworthy #-}-- |-- The event manager supports event notification on fds. Each fd may-- have multiple callbacks registered, each listening for a different-- set of events. Registrations may be automatically deactivated after-- the occurrence of an event ("one-shot mode") or active until-- explicitly unregistered.---- If an fd has only one-shot registrations then we use one-shot-- polling if available. Otherwise we use multi-shot polling.moduleGHC.Event.Manager(-- * TypesEventManager -- * Creation,new ,newWith ,newDefaultBackend -- * Running,finished ,loop ,step ,shutdown ,release ,cleanup ,wakeManager -- * State,callbackTableVar ,emControl -- * Registering interest in I/O events,Lifetime (..),Event ,evtRead ,evtWrite ,IOCallback ,FdKey (keyFd ),FdData ,registerFd ,unregisterFd_ ,unregisterFd ,closeFd ,closeFd_ )where
#include "EventConfig.h"
-------------------------------------------------------------------------- ImportsimportControl.Concurrent.MVar (MVar ,newMVar ,putMVar ,tryPutMVar ,takeMVar ,withMVar )importControl.Exception (onException )importData.Bits ((.&.) )importData.Foldable (forM_ )importData.Functor (void )importData.IORef (IORef ,atomicModifyIORef' ,mkWeakIORef ,newIORef ,readIORef ,writeIORef )importData.Maybe (maybe )importData.OldList (partition )importGHC.Arr (Array ,(!) ,listArray )importGHC.Base importGHC.Conc.Sync (yield )importGHC.List (filter ,replicate )importGHC.Num (Num (..))importGHC.Real (fromIntegral )importGHC.Show (Show (..))importGHC.Event.Control importGHC.Event.IntTable (IntTable )importGHC.Event.Internal (Backend ,Event ,evtClose ,evtRead ,evtWrite ,Lifetime (..),EventLifetime ,Timeout (..))importGHC.Event.Unique (Unique ,UniqueSource ,newSource ,newUnique )importSystem.Posix.Types (Fd )importqualifiedGHC.Event.IntTable asITimportqualifiedGHC.Event.Internal asI
#if defined(HAVE_KQUEUE)
importqualifiedGHC.Event.KQueueasKQueue
#elif defined(HAVE_EPOLL)
importqualifiedGHC.Event.EPoll asEPoll
#elif defined(HAVE_POLL)
importqualifiedGHC.Event.PollasPoll
#else
# error not implemented for this operating system
#endif
-------------------------------------------------------------------------- TypesdataFdData =FdData {FdData -> FdKey
fdKey ::{-# UNPACK#-}!FdKey ,FdData -> EventLifetime
fdEvents ::{-# UNPACK#-}!EventLifetime ,FdData -> IOCallback
_fdCallback ::!IOCallback }-- | A file descriptor registration cookie.dataFdKey =FdKey {FdKey -> Fd
keyFd ::{-# UNPACK#-}!Fd ,FdKey -> Unique
keyUnique ::{-# UNPACK#-}!Unique }deriving(FdKey -> FdKey -> Bool
(FdKey -> FdKey -> Bool) -> (FdKey -> FdKey -> Bool) -> Eq FdKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FdKey -> FdKey -> Bool
== :: FdKey -> FdKey -> Bool
$c/= :: FdKey -> FdKey -> Bool
/= :: FdKey -> FdKey -> Bool
Eq -- ^ @since 4.4.0.0,Int -> FdKey -> ShowS
[FdKey] -> ShowS
FdKey -> String
(Int -> FdKey -> ShowS)
-> (FdKey -> String) -> ([FdKey] -> ShowS) -> Show FdKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FdKey -> ShowS
showsPrec :: Int -> FdKey -> ShowS
$cshow :: FdKey -> String
show :: FdKey -> String
$cshowList :: [FdKey] -> ShowS
showList :: [FdKey] -> ShowS
Show -- ^ @since 4.4.0.0)-- | Callback invoked on I/O events.typeIOCallback =FdKey ->Event ->IO ()dataState =Created |Running |Dying |Releasing |Finished deriving(State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: State -> State -> Bool
Eq -- ^ @since 4.4.0.0,Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> State -> ShowS
showsPrec :: Int -> State -> ShowS
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> ShowS
showList :: [State] -> ShowS
Show -- ^ @since 4.4.0.0)-- | The event manager state.dataEventManager =EventManager {EventManager -> Backend
emBackend ::!Backend ,EventManager -> Array Int (MVar (IntTable [FdData]))
emFds ::{-# UNPACK#-}!(Array Int (MVar (IntTable [FdData ]))),EventManager -> IORef State
emState ::{-# UNPACK#-}!(IORef State ),EventManager -> UniqueSource
emUniqueSource ::{-# UNPACK#-}!UniqueSource ,EventManager -> Control
emControl ::{-# UNPACK#-}!Control ,EventManager -> MVar ()
emLock ::{-# UNPACK#-}!(MVar ())}-- must be power of 2callbackArraySize ::Int callbackArraySize :: Int
callbackArraySize =Int
32hashFd ::Fd ->Int hashFd :: Fd -> Int
hashFd Fd
fd =Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. (Int
callbackArraySize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1){-# INLINEhashFd #-}callbackTableVar ::EventManager ->Fd ->MVar (IntTable [FdData ])callbackTableVar :: EventManager -> Fd -> MVar (IntTable [FdData])
callbackTableVar EventManager
mgr Fd
fd =EventManager -> Array Int (MVar (IntTable [FdData]))
emFds EventManager
mgr Array Int (MVar (IntTable [FdData]))
-> Int -> MVar (IntTable [FdData])
forall i e. Ix i => Array i e -> i -> e
! Fd -> Int
hashFd Fd
fd {-# INLINEcallbackTableVar #-}haveOneShot ::Bool {-# INLINEhaveOneShot #-}
#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
haveOneShot=False
#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)
haveOneShot :: Bool
haveOneShot =Bool
True 
#else
haveOneShot=False
#endif
-------------------------------------------------------------------------- CreationhandleControlEvent ::EventManager ->Fd ->Event ->IO ()handleControlEvent :: EventManager -> Fd -> Event -> IO ()
handleControlEvent EventManager
mgr Fd
fd Event
_evt =doControlMessage
msg <-Control -> Fd -> IO ControlMessage
readControlMessage (EventManager -> Control
emControl EventManager
mgr )Fd
fd caseControlMessage
msg ofControlMessage
CMsgWakeup ->() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()ControlMessage
CMsgDie ->IORef State -> State -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (EventManager -> IORef State
emState EventManager
mgr )State
Finished ControlMessage
_->() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()newDefaultBackend ::IO Backend 
#if defined(HAVE_KQUEUE)
newDefaultBackend=KQueue.new
#elif defined(HAVE_EPOLL)
newDefaultBackend :: IO Backend
newDefaultBackend =IO Backend
EPoll.new 
#elif defined(HAVE_POLL)
newDefaultBackend=Poll.new
#else
newDefaultBackend=errorWithoutStackTrace"no back end for this platform"
#endif
-- | Create a new event manager.new ::IO EventManager new :: IO EventManager
new =Backend -> IO EventManager
newWith (Backend -> IO EventManager) -> IO Backend -> IO EventManager
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Backend
newDefaultBackend -- | Create a new 'EventManager' with the given polling backend.newWith ::Backend ->IO EventManager newWith :: Backend -> IO EventManager
newWith Backend
be =doArray Int (MVar (IntTable [FdData]))
iofds <-([MVar (IntTable [FdData])]
 -> Array Int (MVar (IntTable [FdData])))
-> IO [MVar (IntTable [FdData])]
-> IO (Array Int (MVar (IntTable [FdData])))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int, Int)
-> [MVar (IntTable [FdData])]
-> Array Int (MVar (IntTable [FdData]))
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
callbackArraySize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))(IO [MVar (IntTable [FdData])]
 -> IO (Array Int (MVar (IntTable [FdData]))))
-> IO [MVar (IntTable [FdData])]
-> IO (Array Int (MVar (IntTable [FdData])))
forall a b. (a -> b) -> a -> b
$ Int
-> IO (MVar (IntTable [FdData])) -> IO [MVar (IntTable [FdData])]
forall {m :: * -> *} {a}. Monad m => Int -> m a -> m [a]
replicateM Int
callbackArraySize (IntTable [FdData] -> IO (MVar (IntTable [FdData]))
forall a. a -> IO (MVar a)
newMVar (IntTable [FdData] -> IO (MVar (IntTable [FdData])))
-> IO (IntTable [FdData]) -> IO (MVar (IntTable [FdData]))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO (IntTable [FdData])
forall a. Int -> IO (IntTable a)
IT.new Int
8)Control
ctrl <-Bool -> IO Control
newControl Bool
False IORef State
state <-State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef State
Created UniqueSource
us <-IO UniqueSource
newSource Weak (IORef State)
_<-IORef State -> IO () -> IO (Weak (IORef State))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef State
state (IO () -> IO (Weak (IORef State)))
-> IO () -> IO (Weak (IORef State))
forall a b. (a -> b) -> a -> b
$ doState
st <-IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef State
state ((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \State
s ->(State
Finished ,State
s )Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State
st State -> State -> Bool
forall a. Eq a => a -> a -> Bool
/= State
Finished )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ doBackend -> IO ()
I.delete Backend
be Control -> IO ()
closeControl Control
ctrl MVar ()
lockVar <-() -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()letmgr :: EventManager
mgr =EventManager {emBackend :: Backend
emBackend =Backend
be ,emFds :: Array Int (MVar (IntTable [FdData]))
emFds =Array Int (MVar (IntTable [FdData]))
iofds ,emState :: IORef State
emState =IORef State
state ,emUniqueSource :: UniqueSource
emUniqueSource =UniqueSource
us ,emControl :: Control
emControl =Control
ctrl ,emLock :: MVar ()
emLock =MVar ()
lockVar }EventManager -> Fd -> Event -> IO ()
registerControlFd EventManager
mgr (Control -> Fd
controlReadFd Control
ctrl )Event
evtRead EventManager -> Fd -> Event -> IO ()
registerControlFd EventManager
mgr (Control -> Fd
wakeupReadFd Control
ctrl )Event
evtRead EventManager -> IO EventManager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EventManager
mgr wherereplicateM :: Int -> m a -> m [a]
replicateM Int
n m a
x =[m a] -> m [a]
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (Int -> m a -> [m a]
forall a. Int -> a -> [a]
replicate Int
n m a
x )failOnInvalidFile ::String ->Fd ->IO Bool ->IO ()failOnInvalidFile :: String -> Fd -> IO Bool -> IO ()
failOnInvalidFile String
loc Fd
fd IO Bool
m =doBool
ok <-IO Bool
m Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
ok )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ letmsg :: String
msg =String
"Failed while attempting to modify registration of file "String -> ShowS
forall a. [a] -> [a] -> [a]
++ Fd -> String
forall a. Show a => a -> String
show Fd
fd String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at location "String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
loc inString -> IO ()
forall a. String -> a
errorWithoutStackTrace String
msg registerControlFd ::EventManager ->Fd ->Event ->IO ()registerControlFd :: EventManager -> Fd -> Event -> IO ()
registerControlFd EventManager
mgr Fd
fd Event
evs =String -> Fd -> IO Bool -> IO ()
failOnInvalidFile String
"registerControlFd"Fd
fd (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd (EventManager -> Backend
emBackend EventManager
mgr )Fd
fd Event
forall a. Monoid a => a
mempty Event
evs -- | Asynchronously shuts down the event manager, if running.shutdown ::EventManager ->IO ()shutdown :: EventManager -> IO ()
shutdown EventManager
mgr =doState
state <-IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (EventManager -> IORef State
emState EventManager
mgr )((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \State
s ->(State
Dying ,State
s )Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State
state State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
Running )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Control -> IO ()
sendDie (EventManager -> Control
emControl EventManager
mgr )-- | Asynchronously tell the thread executing the event-- manager loop to exit.release ::EventManager ->IO ()release :: EventManager -> IO ()
release EventManager {Array Int (MVar (IntTable [FdData]))
MVar ()
UniqueSource
IORef State
Backend
Control
emControl :: EventManager -> Control
emBackend :: EventManager -> Backend
emFds :: EventManager -> Array Int (MVar (IntTable [FdData]))
emState :: EventManager -> IORef State
emUniqueSource :: EventManager -> UniqueSource
emLock :: EventManager -> MVar ()
emBackend :: Backend
emFds :: Array Int (MVar (IntTable [FdData]))
emState :: IORef State
emUniqueSource :: UniqueSource
emControl :: Control
emLock :: MVar ()
.. }=doState
state <-IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef State
emState ((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \State
s ->(State
Releasing ,State
s )Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State
state State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
Running )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Control -> IO ()
sendWakeup Control
emControl finished ::EventManager ->IO Bool finished :: EventManager -> IO Bool
finished EventManager
mgr =(State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
Finished )(State -> Bool) -> IO State -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IORef State -> IO State
forall a. IORef a -> IO a
readIORef (EventManager -> IORef State
emState EventManager
mgr )cleanup ::EventManager ->IO ()cleanup :: EventManager -> IO ()
cleanup EventManager {Array Int (MVar (IntTable [FdData]))
MVar ()
UniqueSource
IORef State
Backend
Control
emControl :: EventManager -> Control
emBackend :: EventManager -> Backend
emFds :: EventManager -> Array Int (MVar (IntTable [FdData]))
emState :: EventManager -> IORef State
emUniqueSource :: EventManager -> UniqueSource
emLock :: EventManager -> MVar ()
emBackend :: Backend
emFds :: Array Int (MVar (IntTable [FdData]))
emState :: IORef State
emUniqueSource :: UniqueSource
emControl :: Control
emLock :: MVar ()
.. }=doIORef State -> State -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef State
emState State
Finished IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
emLock ()Backend -> IO ()
I.delete Backend
emBackend Control -> IO ()
closeControl Control
emControl -------------------------------------------------------------------------- Event loop-- | Start handling events. This function loops until told to stop,-- using 'shutdown'.---- /Note/: This loop can only be run once per 'EventManager', as it-- closes all of its control resources when it finishes.loop ::EventManager ->IO ()loop :: EventManager -> IO ()
loop mgr :: EventManager
mgr @EventManager {Array Int (MVar (IntTable [FdData]))
MVar ()
UniqueSource
IORef State
Backend
Control
emControl :: EventManager -> Control
emBackend :: EventManager -> Backend
emFds :: EventManager -> Array Int (MVar (IntTable [FdData]))
emState :: EventManager -> IORef State
emUniqueSource :: EventManager -> UniqueSource
emLock :: EventManager -> MVar ()
emBackend :: Backend
emFds :: Array Int (MVar (IntTable [FdData]))
emState :: IORef State
emUniqueSource :: UniqueSource
emControl :: Control
emLock :: MVar ()
.. }=doIO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
emLock State
state <-IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef State
emState ((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \State
s ->caseState
s ofState
Created ->(State
Running ,State
s )State
Releasing ->(State
Running ,State
s )State
_->(State
s ,State
s )caseState
state ofState
Created ->IO ()
go IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` EventManager -> IO ()
cleanup EventManager
mgr State
Releasing ->IO ()
go IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` EventManager -> IO ()
cleanup EventManager
mgr State
Dying ->EventManager -> IO ()
cleanup EventManager
mgr -- While a poll loop is never forked when the event manager is in the-- 'Finished' state, its state could read 'Finished' once the new thread-- actually runs. This is not an error, just an unfortunate race condition-- in Thread.restartPollLoop. See #8235State
Finished ->() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()State
_->doEventManager -> IO ()
cleanup EventManager
mgr String -> IO ()
forall a. String -> a
errorWithoutStackTrace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"GHC.Event.Manager.loop: state is already "String -> ShowS
forall a. [a] -> [a] -> [a]
++ State -> String
forall a. Show a => a -> String
show State
state wherego :: IO ()
go =doState
state <-EventManager -> IO State
step EventManager
mgr caseState
state ofState
Running ->IO ()
yield IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
go State
Releasing ->MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
emLock ()State
_->EventManager -> IO ()
cleanup EventManager
mgr -- | To make a step, we first do a non-blocking poll, in case-- there are already events ready to handle. This improves performance-- because we can make an unsafe foreign C call, thereby avoiding-- forcing the current Task to release the Capability and forcing a context switch.-- If the poll fails to find events, we yield, putting the poll loop thread at-- end of the Haskell run queue. When it comes back around, we do one more-- non-blocking poll, in case we get lucky and have ready events.-- If that also returns no events, then we do a blocking poll.step ::EventManager ->IO State step :: EventManager -> IO State
step mgr :: EventManager
mgr @EventManager {Array Int (MVar (IntTable [FdData]))
MVar ()
UniqueSource
IORef State
Backend
Control
emControl :: EventManager -> Control
emBackend :: EventManager -> Backend
emFds :: EventManager -> Array Int (MVar (IntTable [FdData]))
emState :: EventManager -> IORef State
emUniqueSource :: EventManager -> UniqueSource
emLock :: EventManager -> MVar ()
emBackend :: Backend
emFds :: Array Int (MVar (IntTable [FdData]))
emState :: IORef State
emUniqueSource :: UniqueSource
emControl :: Control
emLock :: MVar ()
.. }=doIO ()
waitForIO State
state <-IORef State -> IO State
forall a. IORef a -> IO a
readIORef IORef State
emState State
state State -> IO State -> IO State
forall a b. a -> b -> b
`seq` State -> IO State
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return State
state wherewaitForIO :: IO ()
waitForIO =doInt
n1 <-Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
I.poll Backend
emBackend Maybe Timeout
forall a. Maybe a
Nothing (EventManager -> Fd -> Event -> IO ()
onFdEvent EventManager
mgr )Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0)(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ doIO ()
yield Int
n2 <-Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
I.poll Backend
emBackend Maybe Timeout
forall a. Maybe a
Nothing (EventManager -> Fd -> Event -> IO ()
onFdEvent EventManager
mgr )Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0)(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ doInt
_<-Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
I.poll Backend
emBackend (Timeout -> Maybe Timeout
forall a. a -> Maybe a
Just Timeout
Forever )(EventManager -> Fd -> Event -> IO ()
onFdEvent EventManager
mgr )() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()-------------------------------------------------------------------------- Registering interest in I/O events-- | Register interest in the given events, without waking the event-- manager thread. The 'Bool' return value indicates whether the-- event manager ought to be woken.---- Note that the event manager is generally implemented in terms of the-- platform's @select@ or @epoll@ system call, which tend to vary in-- what sort of fds are permitted. For instance, waiting on regular files-- is not allowed on many platforms.registerFd_ ::EventManager ->IOCallback ->Fd ->Event ->Lifetime ->IO (FdKey ,Bool )registerFd_ :: EventManager
-> IOCallback -> Fd -> Event -> Lifetime -> IO (FdKey, Bool)
registerFd_ mgr :: EventManager
mgr @(EventManager {Array Int (MVar (IntTable [FdData]))
MVar ()
UniqueSource
IORef State
Backend
Control
emControl :: EventManager -> Control
emBackend :: EventManager -> Backend
emFds :: EventManager -> Array Int (MVar (IntTable [FdData]))
emState :: EventManager -> IORef State
emUniqueSource :: EventManager -> UniqueSource
emLock :: EventManager -> MVar ()
emBackend :: Backend
emFds :: Array Int (MVar (IntTable [FdData]))
emState :: IORef State
emUniqueSource :: UniqueSource
emControl :: Control
emLock :: MVar ()
.. })IOCallback
cb Fd
fd Event
evs Lifetime
lt =doUnique
u <-UniqueSource -> IO Unique
newUnique UniqueSource
emUniqueSource letfd' :: Int
fd' =Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd reg :: FdKey
reg =Fd -> Unique -> FdKey
FdKey Fd
fd Unique
u el :: EventLifetime
el =Event -> Lifetime -> EventLifetime
I.eventLifetime Event
evs Lifetime
lt !fdd :: FdData
fdd =FdKey -> EventLifetime -> IOCallback -> FdData
FdData FdKey
reg EventLifetime
el IOCallback
cb (Bool
modify ,Bool
ok )<-MVar (IntTable [FdData])
-> (IntTable [FdData] -> IO (Bool, Bool)) -> IO (Bool, Bool)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (EventManager -> Fd -> MVar (IntTable [FdData])
callbackTableVar EventManager
mgr Fd
fd )((IntTable [FdData] -> IO (Bool, Bool)) -> IO (Bool, Bool))
-> (IntTable [FdData] -> IO (Bool, Bool)) -> IO (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ \IntTable [FdData]
tbl ->doMaybe [FdData]
oldFdd <-([FdData] -> [FdData] -> [FdData])
-> Int -> [FdData] -> IntTable [FdData] -> IO (Maybe [FdData])
forall a. (a -> a -> a) -> Int -> a -> IntTable a -> IO (Maybe a)
IT.insertWith [FdData] -> [FdData] -> [FdData]
forall a. [a] -> [a] -> [a]
(++) Int
fd' [FdData
fdd ]IntTable [FdData]
tbl letprevEvs ::EventLifetime prevEvs :: EventLifetime
prevEvs =EventLifetime
-> ([FdData] -> EventLifetime) -> Maybe [FdData] -> EventLifetime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EventLifetime
forall a. Monoid a => a
mempty [FdData] -> EventLifetime
eventsOf Maybe [FdData]
oldFdd el' ::EventLifetime el' :: EventLifetime
el' =EventLifetime
prevEvs EventLifetime -> EventLifetime -> EventLifetime
forall a. Monoid a => a -> a -> a
`mappend` EventLifetime
el caseEventLifetime -> Lifetime
I.elLifetime EventLifetime
el' of-- All registrations want one-shot semantics and this is supportedLifetime
OneShot |Bool
haveOneShot ->doBool
ok <-Backend -> Fd -> Event -> IO Bool
I.modifyFdOnce Backend
emBackend Fd
fd (EventLifetime -> Event
I.elEvent EventLifetime
el' )ifBool
ok then(Bool, Bool) -> IO (Bool, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False ,Bool
True )elseInt -> Maybe [FdData] -> IntTable [FdData] -> IO ()
forall a. Int -> Maybe a -> IntTable a -> IO ()
IT.reset Int
fd' Maybe [FdData]
oldFdd IntTable [FdData]
tbl IO () -> IO (Bool, Bool) -> IO (Bool, Bool)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool, Bool) -> IO (Bool, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False ,Bool
False )-- We don't want or don't support one-shot semanticsLifetime
_->doletmodify :: Bool
modify =EventLifetime
prevEvs EventLifetime -> EventLifetime -> Bool
forall a. Eq a => a -> a -> Bool
/= EventLifetime
el' Bool
ok <-ifBool
modify thenletnewEvs :: Event
newEvs =EventLifetime -> Event
I.elEvent EventLifetime
el' oldEvs :: Event
oldEvs =EventLifetime -> Event
I.elEvent EventLifetime
prevEvs inBackend -> Fd -> Event -> Event -> IO Bool
I.modifyFd Backend
emBackend Fd
fd Event
oldEvs Event
newEvs elseBool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True ifBool
ok then(Bool, Bool) -> IO (Bool, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
modify ,Bool
True )elseInt -> Maybe [FdData] -> IntTable [FdData] -> IO ()
forall a. Int -> Maybe a -> IntTable a -> IO ()
IT.reset Int
fd' Maybe [FdData]
oldFdd IntTable [FdData]
tbl IO () -> IO (Bool, Bool) -> IO (Bool, Bool)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool, Bool) -> IO (Bool, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False ,Bool
False )-- this simulates behavior of old IO manager:-- i.e. just call the callback if the registration fails.Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
ok )(IOCallback
cb FdKey
reg Event
evs )(FdKey, Bool) -> IO (FdKey, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FdKey
reg ,Bool
modify ){-# INLINEregisterFd_ #-}-- | @registerFd mgr cb fd evs lt@ registers interest in the events @evs@-- on the file descriptor @fd@ for lifetime @lt@. @cb@ is called for-- each event that occurs. Returns a cookie that can be handed to-- 'unregisterFd'.registerFd ::EventManager ->IOCallback ->Fd ->Event ->Lifetime ->IO FdKey registerFd :: EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey
registerFd EventManager
mgr IOCallback
cb Fd
fd Event
evs Lifetime
lt =do(FdKey
r ,Bool
wake )<-EventManager
-> IOCallback -> Fd -> Event -> Lifetime -> IO (FdKey, Bool)
registerFd_ EventManager
mgr IOCallback
cb Fd
fd Event
evs Lifetime
lt Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wake (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EventManager -> IO ()
wakeManager EventManager
mgr FdKey -> IO FdKey
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FdKey
r {-# INLINEregisterFd #-}{-
 Building GHC with parallel IO manager on Mac freezes when
 compiling the dph libraries in the phase 2. As workaround, we
 don't use oneshot and we wake up an IO manager on Mac every time
 when we register an event.
 For more information, please read:
 https://gitlab.haskell.org/ghc/ghc/issues/7651
-}-- | Wake up the event manager.wakeManager ::EventManager ->IO ()
#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
wakeManagermgr=sendWakeup(emControlmgr)
#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)
wakeManager :: EventManager -> IO ()
wakeManager EventManager
_=() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
wakeManagermgr=sendWakeup(emControlmgr)
#endif
eventsOf ::[FdData ]->EventLifetime eventsOf :: [FdData] -> EventLifetime
eventsOf [FdData
fdd ]=FdData -> EventLifetime
fdEvents FdData
fdd eventsOf [FdData]
fdds =[EventLifetime] -> EventLifetime
forall a. Monoid a => [a] -> a
mconcat ([EventLifetime] -> EventLifetime)
-> [EventLifetime] -> EventLifetime
forall a b. (a -> b) -> a -> b
$ (FdData -> EventLifetime) -> [FdData] -> [EventLifetime]
forall a b. (a -> b) -> [a] -> [b]
map FdData -> EventLifetime
fdEvents [FdData]
fdds -- | Drop a previous file descriptor registration, without waking the-- event manager thread. The return value indicates whether the event-- manager ought to be woken.unregisterFd_ ::EventManager ->FdKey ->IO Bool unregisterFd_ :: EventManager -> FdKey -> IO Bool
unregisterFd_ mgr :: EventManager
mgr @(EventManager {Array Int (MVar (IntTable [FdData]))
MVar ()
UniqueSource
IORef State
Backend
Control
emControl :: EventManager -> Control
emBackend :: EventManager -> Backend
emFds :: EventManager -> Array Int (MVar (IntTable [FdData]))
emState :: EventManager -> IORef State
emUniqueSource :: EventManager -> UniqueSource
emLock :: EventManager -> MVar ()
emBackend :: Backend
emFds :: Array Int (MVar (IntTable [FdData]))
emState :: IORef State
emUniqueSource :: UniqueSource
emControl :: Control
emLock :: MVar ()
.. })(FdKey Fd
fd Unique
u )=MVar (IntTable [FdData])
-> (IntTable [FdData] -> IO Bool) -> IO Bool
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (EventManager -> Fd -> MVar (IntTable [FdData])
callbackTableVar EventManager
mgr Fd
fd )((IntTable [FdData] -> IO Bool) -> IO Bool)
-> (IntTable [FdData] -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \IntTable [FdData]
tbl ->doletdropReg :: [FdData] -> Maybe [FdData]
dropReg =[FdData] -> Maybe [FdData]
forall a. [a] -> Maybe [a]
nullToNothing ([FdData] -> Maybe [FdData])
-> ([FdData] -> [FdData]) -> [FdData] -> Maybe [FdData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FdData -> Bool) -> [FdData] -> [FdData]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
/= Unique
u )(Unique -> Bool) -> (FdData -> Unique) -> FdData -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FdKey -> Unique
keyUnique (FdKey -> Unique) -> (FdData -> FdKey) -> FdData -> Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FdData -> FdKey
fdKey )fd' :: Int
fd' =Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd pairEvents ::[FdData ]->IO (EventLifetime ,EventLifetime )pairEvents :: [FdData] -> IO (EventLifetime, EventLifetime)
pairEvents [FdData]
prev =doEventLifetime
r <-EventLifetime
-> ([FdData] -> EventLifetime) -> Maybe [FdData] -> EventLifetime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EventLifetime
forall a. Monoid a => a
mempty [FdData] -> EventLifetime
eventsOf (Maybe [FdData] -> EventLifetime)
-> IO (Maybe [FdData]) -> IO EventLifetime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> IntTable [FdData] -> IO (Maybe [FdData])
forall a. Int -> IntTable a -> IO (Maybe a)
IT.lookup Int
fd' IntTable [FdData]
tbl (EventLifetime, EventLifetime) -> IO (EventLifetime, EventLifetime)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FdData] -> EventLifetime
eventsOf [FdData]
prev ,EventLifetime
r )(EventLifetime
oldEls ,EventLifetime
newEls )<-([FdData] -> Maybe [FdData])
-> Int -> IntTable [FdData] -> IO (Maybe [FdData])
forall a. (a -> Maybe a) -> Int -> IntTable a -> IO (Maybe a)
IT.updateWith [FdData] -> Maybe [FdData]
dropReg Int
fd' IntTable [FdData]
tbl IO (Maybe [FdData])
-> (Maybe [FdData] -> IO (EventLifetime, EventLifetime))
-> IO (EventLifetime, EventLifetime)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (EventLifetime, EventLifetime)
-> ([FdData] -> IO (EventLifetime, EventLifetime))
-> Maybe [FdData]
-> IO (EventLifetime, EventLifetime)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((EventLifetime, EventLifetime) -> IO (EventLifetime, EventLifetime)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventLifetime
forall a. Monoid a => a
mempty ,EventLifetime
forall a. Monoid a => a
mempty ))[FdData] -> IO (EventLifetime, EventLifetime)
pairEvents letmodify :: Bool
modify =EventLifetime
oldEls EventLifetime -> EventLifetime -> Bool
forall a. Eq a => a -> a -> Bool
/= EventLifetime
newEls Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
modify (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Fd -> IO Bool -> IO ()
failOnInvalidFile String
"unregisterFd_"Fd
fd (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ caseEventLifetime -> Lifetime
I.elLifetime EventLifetime
newEls ofLifetime
OneShot |EventLifetime -> Event
I.elEvent EventLifetime
newEls Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
/= Event
forall a. Monoid a => a
mempty ,Bool
haveOneShot ->Backend -> Fd -> Event -> IO Bool
I.modifyFdOnce Backend
emBackend Fd
fd (EventLifetime -> Event
I.elEvent EventLifetime
newEls )Lifetime
_->Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd Backend
emBackend Fd
fd (EventLifetime -> Event
I.elEvent EventLifetime
oldEls )(EventLifetime -> Event
I.elEvent EventLifetime
newEls )Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
modify -- | Drop a previous file descriptor registration.unregisterFd ::EventManager ->FdKey ->IO ()unregisterFd :: EventManager -> FdKey -> IO ()
unregisterFd EventManager
mgr FdKey
reg =doBool
wake <-EventManager -> FdKey -> IO Bool
unregisterFd_ EventManager
mgr FdKey
reg Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wake (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EventManager -> IO ()
wakeManager EventManager
mgr -- | Close a file descriptor in a race-safe way. It might block, although for-- a very short time; and thus it is interruptible by asynchronous exceptions.closeFd ::EventManager ->(Fd ->IO ())->Fd ->IO ()closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO ()
closeFd EventManager
mgr Fd -> IO ()
close Fd
fd =do[FdData]
fds <-MVar (IntTable [FdData])
-> (IntTable [FdData] -> IO [FdData]) -> IO [FdData]
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (EventManager -> Fd -> MVar (IntTable [FdData])
callbackTableVar EventManager
mgr Fd
fd )((IntTable [FdData] -> IO [FdData]) -> IO [FdData])
-> (IntTable [FdData] -> IO [FdData]) -> IO [FdData]
forall a b. (a -> b) -> a -> b
$ \IntTable [FdData]
tbl ->doMaybe [FdData]
prev <-Int -> IntTable [FdData] -> IO (Maybe [FdData])
forall a. Int -> IntTable a -> IO (Maybe a)
IT.delete (Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd )IntTable [FdData]
tbl caseMaybe [FdData]
prev ofMaybe [FdData]
Nothing ->Fd -> IO ()
close Fd
fd IO () -> IO [FdData] -> IO [FdData]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [FdData] -> IO [FdData]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []Just [FdData]
fds ->doletoldEls :: EventLifetime
oldEls =[FdData] -> EventLifetime
eventsOf [FdData]
fds Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventLifetime -> Event
I.elEvent EventLifetime
oldEls Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
/= Event
forall a. Monoid a => a
mempty )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ doBool
_<-Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd (EventManager -> Backend
emBackend EventManager
mgr )Fd
fd (EventLifetime -> Event
I.elEvent EventLifetime
oldEls )Event
forall a. Monoid a => a
mempty EventManager -> IO ()
wakeManager EventManager
mgr Fd -> IO ()
close Fd
fd [FdData] -> IO [FdData]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FdData]
fds [FdData] -> (FdData -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FdData]
fds ((FdData -> IO ()) -> IO ()) -> (FdData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FdData FdKey
reg EventLifetime
el IOCallback
cb )->IOCallback
cb FdKey
reg (EventLifetime -> Event
I.elEvent EventLifetime
el Event -> Event -> Event
forall a. Monoid a => a -> a -> a
`mappend` Event
evtClose )-- | Close a file descriptor in a race-safe way.-- It assumes the caller will update the callback tables and that the caller-- holds the callback table lock for the fd. It must hold this lock because-- this command executes a backend command on the fd.closeFd_ ::EventManager ->IntTable [FdData ]->Fd ->IO (IO ())closeFd_ :: EventManager -> IntTable [FdData] -> Fd -> IO (IO ())
closeFd_ EventManager
mgr IntTable [FdData]
tbl Fd
fd =doMaybe [FdData]
prev <-Int -> IntTable [FdData] -> IO (Maybe [FdData])
forall a. Int -> IntTable a -> IO (Maybe a)
IT.delete (Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd )IntTable [FdData]
tbl caseMaybe [FdData]
prev ofMaybe [FdData]
Nothing ->IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())Just [FdData]
fds ->doletoldEls :: EventLifetime
oldEls =[FdData] -> EventLifetime
eventsOf [FdData]
fds Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventLifetime
oldEls EventLifetime -> EventLifetime -> Bool
forall a. Eq a => a -> a -> Bool
/= EventLifetime
forall a. Monoid a => a
mempty )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ doBool
_<-Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd (EventManager -> Backend
emBackend EventManager
mgr )Fd
fd (EventLifetime -> Event
I.elEvent EventLifetime
oldEls )Event
forall a. Monoid a => a
mempty EventManager -> IO ()
wakeManager EventManager
mgr IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ [FdData] -> (FdData -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FdData]
fds ((FdData -> IO ()) -> IO ()) -> (FdData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FdData FdKey
reg EventLifetime
el IOCallback
cb )->IOCallback
cb FdKey
reg (EventLifetime -> Event
I.elEvent EventLifetime
el Event -> Event -> Event
forall a. Monoid a => a -> a -> a
`mappend` Event
evtClose )-------------------------------------------------------------------------- Utilities-- | Call the callbacks corresponding to the given file descriptor.onFdEvent ::EventManager ->Fd ->Event ->IO ()onFdEvent :: EventManager -> Fd -> Event -> IO ()
onFdEvent EventManager
mgr Fd
fd Event
evs |Fd
fd Fd -> Fd -> Bool
forall a. Eq a => a -> a -> Bool
== Control -> Fd
controlReadFd (EventManager -> Control
emControl EventManager
mgr )Bool -> Bool -> Bool
|| Fd
fd Fd -> Fd -> Bool
forall a. Eq a => a -> a -> Bool
== Control -> Fd
wakeupReadFd (EventManager -> Control
emControl EventManager
mgr )=EventManager -> Fd -> Event -> IO ()
handleControlEvent EventManager
mgr Fd
fd Event
evs |Bool
otherwise =do[FdData]
fdds <-MVar (IntTable [FdData])
-> (IntTable [FdData] -> IO [FdData]) -> IO [FdData]
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (EventManager -> Fd -> MVar (IntTable [FdData])
callbackTableVar EventManager
mgr Fd
fd )((IntTable [FdData] -> IO [FdData]) -> IO [FdData])
-> (IntTable [FdData] -> IO [FdData]) -> IO [FdData]
forall a b. (a -> b) -> a -> b
$ \IntTable [FdData]
tbl ->Int -> IntTable [FdData] -> IO (Maybe [FdData])
forall a. Int -> IntTable a -> IO (Maybe a)
IT.delete (Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd )IntTable [FdData]
tbl IO (Maybe [FdData])
-> (Maybe [FdData] -> IO [FdData]) -> IO [FdData]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO [FdData]
-> ([FdData] -> IO [FdData]) -> Maybe [FdData] -> IO [FdData]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([FdData] -> IO [FdData]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])(IntTable [FdData] -> [FdData] -> IO [FdData]
selectCallbacks IntTable [FdData]
tbl )[FdData] -> (FdData -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FdData]
fdds ((FdData -> IO ()) -> IO ()) -> (FdData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FdData FdKey
reg EventLifetime
_IOCallback
cb )->IOCallback
cb FdKey
reg Event
evs where-- Here we look through the list of registrations for the fd of interest-- and sort out which match the events that were triggered. We,---- 1. re-arm the fd as appropriate-- 2. reinsert registrations that weren't triggered and multishot-- registrations-- 3. return a list containing the callbacks that should be invoked.selectCallbacks ::IntTable [FdData ]->[FdData ]->IO [FdData ]selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData]
selectCallbacks IntTable [FdData]
tbl [FdData]
fdds =dolet-- figure out which registrations have been triggeredmatches ::FdData ->Bool matches :: FdData -> Bool
matches FdData
fd' =Event
evs Event -> Event -> Bool
`I.eventIs` EventLifetime -> Event
I.elEvent (FdData -> EventLifetime
fdEvents FdData
fd' )([FdData]
triggered ,[FdData]
notTriggered )=(FdData -> Bool) -> [FdData] -> ([FdData], [FdData])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition FdData -> Bool
matches [FdData]
fdds -- sort out which registrations we need to retainisMultishot ::FdData ->Bool isMultishot :: FdData -> Bool
isMultishot FdData
fd' =EventLifetime -> Lifetime
I.elLifetime (FdData -> EventLifetime
fdEvents FdData
fd' )Lifetime -> Lifetime -> Bool
forall a. Eq a => a -> a -> Bool
== Lifetime
MultiShot saved :: [FdData]
saved =[FdData]
notTriggered [FdData] -> [FdData] -> [FdData]
forall a. [a] -> [a] -> [a]
++ (FdData -> Bool) -> [FdData] -> [FdData]
forall a. (a -> Bool) -> [a] -> [a]
filter FdData -> Bool
isMultishot [FdData]
triggered savedEls :: EventLifetime
savedEls =[FdData] -> EventLifetime
eventsOf [FdData]
saved allEls :: EventLifetime
allEls =[FdData] -> EventLifetime
eventsOf [FdData]
fdds -- Reinsert multishot registrations.-- We deleted the table entry for this fd above so we there isn't a preexisting entryMaybe [FdData]
_<-([FdData] -> [FdData] -> [FdData])
-> Int -> [FdData] -> IntTable [FdData] -> IO (Maybe [FdData])
forall a. (a -> a -> a) -> Int -> a -> IntTable a -> IO (Maybe a)
IT.insertWith (\[FdData]
_[FdData]
_->[FdData]
saved )(Fd -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd )[FdData]
saved IntTable [FdData]
tbl caseEventLifetime -> Lifetime
I.elLifetime EventLifetime
allEls of-- we previously armed the fd for multiple shots, no need to rearmLifetime
MultiShot |EventLifetime
allEls EventLifetime -> EventLifetime -> Bool
forall a. Eq a => a -> a -> Bool
== EventLifetime
savedEls ->() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()-- either we previously registered for one shot or the-- events of interest have changed, we must re-armLifetime
_->caseEventLifetime -> Lifetime
I.elLifetime EventLifetime
savedEls ofLifetime
OneShot |Bool
haveOneShot ->-- if there are no saved events and we registered with one-shot-- semantics then there is no need to re-armBool -> IO () -> IO ()
forall (m :: * -> *). Monad m => Bool -> m () -> m ()
unless (Lifetime
OneShot Lifetime -> Lifetime -> Bool
forall a. Eq a => a -> a -> Bool
== EventLifetime -> Lifetime
I.elLifetime EventLifetime
allEls Bool -> Bool -> Bool
&& Event
forall a. Monoid a => a
mempty Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== EventLifetime -> Event
I.elEvent EventLifetime
savedEls )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Backend -> Fd -> Event -> IO Bool
I.modifyFdOnce (EventManager -> Backend
emBackend EventManager
mgr )Fd
fd (EventLifetime -> Event
I.elEvent EventLifetime
savedEls )Lifetime
_->-- we need to re-arm with multi-shot semanticsIO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd (EventManager -> Backend
emBackend EventManager
mgr )Fd
fd (EventLifetime -> Event
I.elEvent EventLifetime
allEls )(EventLifetime -> Event
I.elEvent EventLifetime
savedEls )[FdData] -> IO [FdData]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FdData]
triggered nullToNothing ::[a ]->Maybe [a ]nullToNothing :: forall a. [a] -> Maybe [a]
nullToNothing []=Maybe [a]
forall a. Maybe a
Nothing nullToNothing xs :: [a]
xs @(a
_: [a]
_)=[a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
xs unless ::Monad m =>Bool ->m ()->m ()unless :: forall (m :: * -> *). Monad m => Bool -> m () -> m ()
unless Bool
p =Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
p )