Manager.hs 18 KB
Newer Older
1
2
3
4
5
6
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
dterei's avatar
dterei committed
7
{-# LANGUAGE Trustworthy #-}
8
9
10
11
12
13
14
15
16
17
18

-- |
-- 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.

Ian Lynagh's avatar
Ian Lynagh committed
19
module GHC.Event.Manager
Simon Marlow's avatar
Simon Marlow committed
20
21
22
23
24
25
26
27
28
29
30
31
32
    ( -- * Types
      EventManager

      -- * Creation
    , new
    , newWith
    , newDefaultBackend

      -- * Running
    , finished
    , loop
    , step
    , shutdown
33
    , release
34
    , cleanup
Simon Marlow's avatar
Simon Marlow committed
35
36
    , wakeManager

AndreasVoellmy's avatar
AndreasVoellmy committed
37
38
      -- * State
    , callbackTableVar
39
    , emControl
AndreasVoellmy's avatar
AndreasVoellmy committed
40

Simon Marlow's avatar
Simon Marlow committed
41
      -- * Registering interest in I/O events
42
    , Lifetime (..)
Simon Marlow's avatar
Simon Marlow committed
43
44
45
46
47
    , Event
    , evtRead
    , evtWrite
    , IOCallback
    , FdKey(keyFd)
AndreasVoellmy's avatar
AndreasVoellmy committed
48
    , FdData
Simon Marlow's avatar
Simon Marlow committed
49
50
51
    , registerFd
    , unregisterFd_
    , unregisterFd
bos's avatar
bos committed
52
    , closeFd
AndreasVoellmy's avatar
AndreasVoellmy committed
53
    , closeFd_
Simon Marlow's avatar
Simon Marlow committed
54
55
56
57
58
59
60
    ) where

#include "EventConfig.h"

------------------------------------------------------------------------
-- Imports

61
import Control.Concurrent.MVar (MVar, newMVar, putMVar,
bos's avatar
bos committed
62
                                tryPutMVar, takeMVar, withMVar)
63
import Control.Exception (onException)
64
import Data.Bits ((.&.))
65
66
import Data.Foldable (forM_)
import Data.Functor (void)
67
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
Simon Marlow's avatar
Simon Marlow committed
68
                   writeIORef)
69
import Data.Maybe (maybe)
70
import Data.OldList (partition)
71
import GHC.Arr (Array, (!), listArray)
Simon Marlow's avatar
Simon Marlow committed
72
import GHC.Base
73
import GHC.Conc.Sync (yield)
74
import GHC.List (filter, replicate)
Simon Marlow's avatar
Simon Marlow committed
75
import GHC.Num (Num(..))
76
import GHC.Real (fromIntegral)
Simon Marlow's avatar
Simon Marlow committed
77
import GHC.Show (Show(..))
Ian Lynagh's avatar
Ian Lynagh committed
78
import GHC.Event.Control
bos's avatar
bos committed
79
import GHC.Event.IntTable (IntTable)
Ian Lynagh's avatar
Ian Lynagh committed
80
import GHC.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite,
81
                           Lifetime(..), EventLifetime, Timeout(..))
Ian Lynagh's avatar
Ian Lynagh committed
82
import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
Simon Marlow's avatar
Simon Marlow committed
83
84
import System.Posix.Types (Fd)

bos's avatar
bos committed
85
import qualified GHC.Event.IntTable as IT
Ian Lynagh's avatar
Ian Lynagh committed
86
import qualified GHC.Event.Internal as I
Simon Marlow's avatar
Simon Marlow committed
87
88

#if defined(HAVE_KQUEUE)
Ian Lynagh's avatar
Ian Lynagh committed
89
import qualified GHC.Event.KQueue as KQueue
Simon Marlow's avatar
Simon Marlow committed
90
#elif defined(HAVE_EPOLL)
Ian Lynagh's avatar
Ian Lynagh committed
91
import qualified GHC.Event.EPoll  as EPoll
Simon Marlow's avatar
Simon Marlow committed
92
#elif defined(HAVE_POLL)
Ian Lynagh's avatar
Ian Lynagh committed
93
import qualified GHC.Event.Poll   as Poll
Simon Marlow's avatar
Simon Marlow committed
94
95
96
97
98
99
100
101
102
#else
# error not implemented for this operating system
#endif

------------------------------------------------------------------------
-- Types

data FdData = FdData {
      fdKey       :: {-# UNPACK #-} !FdKey
103
    , fdEvents    :: {-# UNPACK #-} !EventLifetime
Simon Marlow's avatar
Simon Marlow committed
104
    , _fdCallback :: !IOCallback
105
    }
Simon Marlow's avatar
Simon Marlow committed
106
107
108
109
110

-- | A file descriptor registration cookie.
data FdKey = FdKey {
      keyFd     :: {-# UNPACK #-} !Fd
    , keyUnique :: {-# UNPACK #-} !Unique
111
112
113
    } deriving ( Eq   -- ^ @since 4.4.0.0
               , Show -- ^ @since 4.4.0.0
               )
Simon Marlow's avatar
Simon Marlow committed
114
115
116
117
118
119
120

-- | Callback invoked on I/O events.
type IOCallback = FdKey -> Event -> IO ()

data State = Created
           | Running
           | Dying
121
           | Releasing
Simon Marlow's avatar
Simon Marlow committed
122
           | Finished
123
124
125
             deriving ( Eq   -- ^ @since 4.4.0.0
                      , Show -- ^ @since 4.4.0.0
                      )
Simon Marlow's avatar
Simon Marlow committed
126
127
128
129

-- | The event manager state.
data EventManager = EventManager
    { emBackend      :: !Backend
bos's avatar
bos committed
130
    , emFds          :: {-# UNPACK #-} !(Array Int (MVar (IntTable [FdData])))
Simon Marlow's avatar
Simon Marlow committed
131
132
133
    , emState        :: {-# UNPACK #-} !(IORef State)
    , emUniqueSource :: {-# UNPACK #-} !UniqueSource
    , emControl      :: {-# UNPACK #-} !Control
134
    , emLock         :: {-# UNPACK #-} !(MVar ())
Simon Marlow's avatar
Simon Marlow committed
135
136
    }

137
-- must be power of 2
138
139
140
141
callbackArraySize :: Int
callbackArraySize = 32

hashFd :: Fd -> Int
142
hashFd fd = fromIntegral fd .&. (callbackArraySize - 1)
143
144
{-# INLINE hashFd #-}

bos's avatar
bos committed
145
callbackTableVar :: EventManager -> Fd -> MVar (IntTable [FdData])
146
147
callbackTableVar mgr fd = emFds mgr ! hashFd fd
{-# INLINE callbackTableVar #-}
148
149
150

haveOneShot :: Bool
{-# INLINE haveOneShot #-}
151
152
153
#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
haveOneShot = False
#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)
154
155
156
157
haveOneShot = True
#else
haveOneShot = False
#endif
Simon Marlow's avatar
Simon Marlow committed
158
159
160
------------------------------------------------------------------------
-- Creation

161
162
163
handleControlEvent :: EventManager -> Fd -> Event -> IO ()
handleControlEvent mgr fd _evt = do
  msg <- readControlMessage (emControl mgr) fd
Simon Marlow's avatar
Simon Marlow committed
164
165
166
  case msg of
    CMsgWakeup      -> return ()
    CMsgDie         -> writeIORef (emState mgr) Finished
AndreasVoellmy's avatar
AndreasVoellmy committed
167
    _               -> return ()
Simon Marlow's avatar
Simon Marlow committed
168
169
170
171
172
173
174
175
176

newDefaultBackend :: IO Backend
#if defined(HAVE_KQUEUE)
newDefaultBackend = KQueue.new
#elif defined(HAVE_EPOLL)
newDefaultBackend = EPoll.new
#elif defined(HAVE_POLL)
newDefaultBackend = Poll.new
#else
Eric Seidel's avatar
Eric Seidel committed
177
newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
Simon Marlow's avatar
Simon Marlow committed
178
179
180
#endif

-- | Create a new event manager.
181
182
new :: IO EventManager
new = newWith =<< newDefaultBackend
Simon Marlow's avatar
Simon Marlow committed
183

184
185
186
-- | Create a new 'EventManager' with the given polling backend.
newWith :: Backend -> IO EventManager
newWith be = do
187
  iofds <- fmap (listArray (0, callbackArraySize-1)) $
bos's avatar
bos committed
188
           replicateM callbackArraySize (newMVar =<< IT.new 8)
189
  ctrl <- newControl False
Simon Marlow's avatar
Simon Marlow committed
190
191
192
  state <- newIORef Created
  us <- newSource
  _ <- mkWeakIORef state $ do
193
               st <- atomicModifyIORef' state $ \s -> (Finished, s)
Simon Marlow's avatar
Simon Marlow committed
194
195
196
               when (st /= Finished) $ do
                 I.delete be
                 closeControl ctrl
197
  lockVar <- newMVar ()
Simon Marlow's avatar
Simon Marlow committed
198
199
200
201
202
  let mgr = EventManager { emBackend = be
                         , emFds = iofds
                         , emState = state
                         , emUniqueSource = us
                         , emControl = ctrl
203
                         , emLock = lockVar
Simon Marlow's avatar
Simon Marlow committed
204
                         }
205
206
  registerControlFd mgr (controlReadFd ctrl) evtRead
  registerControlFd mgr (wakeupReadFd ctrl) evtRead
Simon Marlow's avatar
Simon Marlow committed
207
  return mgr
208
209
  where
    replicateM n x = sequence (replicate n x)
Simon Marlow's avatar
Simon Marlow committed
210

211
212
213
214
215
216
failOnInvalidFile :: String -> Fd -> IO Bool -> IO ()
failOnInvalidFile loc fd m = do
  ok <- m
  when (not ok) $
    let msg = "Failed while attempting to modify registration of file " ++
              show fd ++ " at location " ++ loc
Eric Seidel's avatar
Eric Seidel committed
217
    in errorWithoutStackTrace msg
218

219
registerControlFd :: EventManager -> Fd -> Event -> IO ()
220
221
222
registerControlFd mgr fd evs =
  failOnInvalidFile "registerControlFd" fd $
  I.modifyFd (emBackend mgr) fd mempty evs
223

Simon Marlow's avatar
Simon Marlow committed
224
225
226
-- | Asynchronously shuts down the event manager, if running.
shutdown :: EventManager -> IO ()
shutdown mgr = do
227
  state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s)
Simon Marlow's avatar
Simon Marlow committed
228
229
  when (state == Running) $ sendDie (emControl mgr)

230
231
232
233
-- | Asynchronously tell the thread executing the event
-- manager loop to exit.
release :: EventManager -> IO ()
release EventManager{..} = do
234
  state <- atomicModifyIORef' emState $ \s -> (Releasing, s)
235
236
  when (state == Running) $ sendWakeup emControl

Simon Marlow's avatar
Simon Marlow committed
237
238
239
240
241
242
finished :: EventManager -> IO Bool
finished mgr = (== Finished) `liftM` readIORef (emState mgr)

cleanup :: EventManager -> IO ()
cleanup EventManager{..} = do
  writeIORef emState Finished
243
  void $ tryPutMVar emLock ()
Simon Marlow's avatar
Simon Marlow committed
244
245
246
247
248
249
  I.delete emBackend
  closeControl emControl

------------------------------------------------------------------------
-- Event loop

tibbe's avatar
tibbe committed
250
251
-- | Start handling events.  This function loops until told to stop,
-- using 'shutdown'.
Simon Marlow's avatar
Simon Marlow committed
252
253
254
255
256
--
-- /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 mgr@EventManager{..} = do
257
  void $ takeMVar emLock
258
  state <- atomicModifyIORef' emState $ \s -> case s of
Simon Marlow's avatar
Simon Marlow committed
259
    Created -> (Running, s)
260
    Releasing -> (Running, s)
Simon Marlow's avatar
Simon Marlow committed
261
262
    _       -> (s, s)
  case state of
263
264
265
    Created   -> go `onException` cleanup mgr
    Releasing -> go `onException` cleanup mgr
    Dying     -> cleanup mgr
266
267
268
269
270
    -- 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 #8235
    Finished  -> return ()
271
    _         -> do cleanup mgr
Eric Seidel's avatar
Eric Seidel committed
272
                    errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++
273
                            show state
Simon Marlow's avatar
Simon Marlow committed
274
 where
275
276
277
278
279
  go = do state <- step mgr
          case state of
            Running   -> yield >> go
            Releasing -> putMVar emLock ()
            _         -> cleanup mgr
Simon Marlow's avatar
Simon Marlow committed
280

281
282
283
284
285
286
287
288
-- | 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.
289
step :: EventManager -> IO State
290
step mgr@EventManager{..} = do
291
  waitForIO
Simon Marlow's avatar
Simon Marlow committed
292
  state <- readIORef emState
293
  state `seq` return state
294
295
296
297
298
299
300
301
302
  where
    waitForIO = do
      n1 <- I.poll emBackend Nothing (onFdEvent mgr)
      when (n1 <= 0) $ do
        yield
        n2 <- I.poll emBackend Nothing (onFdEvent mgr)
        when (n2 <= 0) $ do
          _ <- I.poll emBackend (Just Forever) (onFdEvent mgr)
          return ()
Simon Marlow's avatar
Simon Marlow committed
303
304
305
306
307
308
309

------------------------------------------------------------------------
-- 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.
310
311
--
-- Note that the event manager is generally implemented in terms of the
312
-- platform's @select@ or @epoll@ system call, which tend to vary in
313
314
-- what sort of fds are permitted. For instance, waiting on regular files
-- is not allowed on many platforms.
315
registerFd_ :: EventManager -> IOCallback -> Fd -> Event -> Lifetime
Simon Marlow's avatar
Simon Marlow committed
316
            -> IO (FdKey, Bool)
317
registerFd_ mgr@(EventManager{..}) cb fd evs lt = do
Simon Marlow's avatar
Simon Marlow committed
318
  u <- newUnique emUniqueSource
319
320
  let fd'  = fromIntegral fd
      reg  = FdKey fd u
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
      el = I.eventLifetime evs lt
      !fdd = FdData reg el cb
  (modify,ok) <- withMVar (callbackTableVar mgr fd) $ \tbl -> do
    oldFdd <- IT.insertWith (++) fd' [fdd] tbl
    let prevEvs :: EventLifetime
        prevEvs = maybe mempty eventsOf oldFdd

        el' :: EventLifetime
        el' = prevEvs `mappend` el
    case I.elLifetime el' of
      -- All registrations want one-shot semantics and this is supported
      OneShot | haveOneShot -> do
        ok <- I.modifyFdOnce emBackend fd (I.elEvent el')
        if ok
          then return (False, True)
          else IT.reset fd' oldFdd tbl >> return (False, False)

      -- We don't want or don't support one-shot semantics
      _ -> do
        let modify = prevEvs /= el'
        ok <- if modify
              then let newEvs = I.elEvent el'
                       oldEvs = I.elEvent prevEvs
                   in I.modifyFd emBackend fd oldEvs newEvs
              else return True
        if ok
          then return (modify, True)
          else IT.reset fd' oldFdd tbl >> return (False, False)
349
350
351
352
  -- this simulates behavior of old IO manager:
  -- i.e. just call the callback if the registration fails.
  when (not ok) (cb reg evs)
  return (reg,modify)
Simon Marlow's avatar
Simon Marlow committed
353
354
{-# INLINE registerFd_ #-}

355
356
357
358
359
360
361
-- | @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 mgr cb fd evs lt = do
  (r, wake) <- registerFd_ mgr cb fd evs lt
Simon Marlow's avatar
Simon Marlow committed
362
363
364
365
  when wake $ wakeManager mgr
  return r
{-# INLINE registerFd #-}

366
367
368
369
370
371
372
373
374
{-
    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
-}
Simon Marlow's avatar
Simon Marlow committed
375
376
-- | Wake up the event manager.
wakeManager :: EventManager -> IO ()
377
378
379
#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
wakeManager mgr = sendWakeup (emControl mgr)
#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)
kazu-yamamoto's avatar
kazu-yamamoto committed
380
wakeManager _ = return ()
381
#else
kazu-yamamoto's avatar
kazu-yamamoto committed
382
wakeManager mgr = sendWakeup (emControl mgr)
383
#endif
Simon Marlow's avatar
Simon Marlow committed
384

385
386
387
eventsOf :: [FdData] -> EventLifetime
eventsOf [fdd] = fdEvents fdd
eventsOf fdds  = mconcat $ map fdEvents fdds
Simon Marlow's avatar
Simon Marlow committed
388
389
390
391
392

-- | 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
393
unregisterFd_ mgr@(EventManager{..}) (FdKey fd u) =
bos's avatar
bos committed
394
  withMVar (callbackTableVar mgr fd) $ \tbl -> do
395
    let dropReg = nullToNothing . filter ((/= u) . keyUnique . fdKey)
Simon Marlow's avatar
Simon Marlow committed
396
        fd' = fromIntegral fd
397
        pairEvents :: [FdData] -> IO (EventLifetime, EventLifetime)
bos's avatar
bos committed
398
399
400
        pairEvents prev = do
          r <- maybe mempty eventsOf `fmap` IT.lookup fd' tbl
          return (eventsOf prev, r)
401
    (oldEls, newEls) <- IT.updateWith dropReg fd' tbl >>=
bos's avatar
bos committed
402
                        maybe (return (mempty, mempty)) pairEvents
403
    let modify = oldEls /= newEls
404
    when modify $ failOnInvalidFile "unregisterFd_" fd $
405
406
407
408
409
      case I.elLifetime newEls of
        OneShot | I.elEvent newEls /= mempty, haveOneShot ->
          I.modifyFdOnce emBackend fd (I.elEvent newEls)
        _ ->
          I.modifyFd emBackend fd (I.elEvent oldEls) (I.elEvent newEls)
bos's avatar
bos committed
410
    return modify
Simon Marlow's avatar
Simon Marlow committed
411
412
413
414
415
416
417

-- | Drop a previous file descriptor registration.
unregisterFd :: EventManager -> FdKey -> IO ()
unregisterFd mgr reg = do
  wake <- unregisterFd_ mgr reg
  when wake $ wakeManager mgr

418
419
-- | 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.
bos's avatar
bos committed
420
421
closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO ()
closeFd mgr close fd = do
bos's avatar
bos committed
422
423
424
425
426
  fds <- withMVar (callbackTableVar mgr fd) $ \tbl -> do
    prev <- IT.delete (fromIntegral fd) tbl
    case prev of
      Nothing  -> close fd >> return []
      Just fds -> do
427
428
429
        let oldEls = eventsOf fds
        when (I.elEvent oldEls /= mempty) $ do
          _ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty
430
431
          wakeManager mgr
        close fd
bos's avatar
bos committed
432
        return fds
433
  forM_ fds $ \(FdData reg el cb) -> cb reg (I.elEvent el `mappend` evtClose)
Simon Marlow's avatar
Simon Marlow committed
434

435
-- | Close a file descriptor in a race-safe way.
AndreasVoellmy's avatar
AndreasVoellmy committed
436
-- It assumes the caller will update the callback tables and that the caller
437
438
439
-- 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
440
441
442
         -> IntTable [FdData]
         -> Fd
         -> IO (IO ())
bos's avatar
bos committed
443
444
445
446
447
closeFd_ mgr tbl fd = do
  prev <- IT.delete (fromIntegral fd) tbl
  case prev of
    Nothing  -> return (return ())
    Just fds -> do
448
449
450
      let oldEls = eventsOf fds
      when (oldEls /= mempty) $ do
        _ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty
451
        wakeManager mgr
bos's avatar
bos committed
452
      return $
453
454
        forM_ fds $ \(FdData reg el cb) ->
          cb reg (I.elEvent el `mappend` evtClose)
bos's avatar
bos committed
455

Simon Marlow's avatar
Simon Marlow committed
456
457
458
459
460
------------------------------------------------------------------------
-- Utilities

-- | Call the callbacks corresponding to the given file descriptor.
onFdEvent :: EventManager -> Fd -> Event -> IO ()
461
462
463
464
465
466
onFdEvent mgr fd evs
  | fd == controlReadFd (emControl mgr) || fd == wakeupReadFd (emControl mgr) =
    handleControlEvent mgr fd evs

  | otherwise = do
    fdds <- withMVar (callbackTableVar mgr fd) $ \tbl ->
Ben Gamari's avatar
Ben Gamari committed
467
        IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl)
468
    forM_ fdds $ \(FdData reg _ cb) -> cb reg evs
469
  where
470
    -- | Here we look through the list of registrations for the fd of interest
Ben Gamari's avatar
Ben Gamari committed
471
472
473
474
475
476
477
478
479
480
    -- 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 tbl fdds = do
        let -- figure out which registrations have been triggered
            matches :: FdData -> Bool
481
            matches fd' = evs `I.eventIs` I.elEvent (fdEvents fd')
Ben Gamari's avatar
Ben Gamari committed
482
483
484
485
486
487
488
            (triggered, notTriggered) = partition matches fdds

            -- sort out which registrations we need to retain
            isMultishot :: FdData -> Bool
            isMultishot fd' = I.elLifetime (fdEvents fd') == MultiShot
            saved = notTriggered ++ filter isMultishot triggered

489
490
491
            savedEls = eventsOf saved
            allEls = eventsOf fdds

Ben Gamari's avatar
Ben Gamari committed
492
493
494
495
        -- Reinsert multishot registrations.
        -- We deleted the table entry for this fd above so we there isn't a preexisting entry
        _ <- IT.insertWith (\_ _ -> saved) (fromIntegral fd) saved tbl

496
497
498
499
500
501
502
        case I.elLifetime allEls of
          -- we previously armed the fd for multiple shots, no need to rearm
          MultiShot | allEls == savedEls ->
            return ()

          -- either we previously registered for one shot or the
          -- events of interest have changed, we must re-arm
Ben Gamari's avatar
Ben Gamari committed
503
          _ ->
504
505
            case I.elLifetime savedEls of
              OneShot | haveOneShot ->
Ben Gamari's avatar
Ben Gamari committed
506
507
508
                -- if there are no saved events and we registered with one-shot
                -- semantics then there is no need to re-arm
                unless (OneShot == I.elLifetime allEls
509
510
                  && mempty == I.elEvent savedEls) $
                    void $ I.modifyFdOnce (emBackend mgr) fd (I.elEvent savedEls)
511
              _ ->
Ben Gamari's avatar
Ben Gamari committed
512
                -- we need to re-arm with multi-shot semantics
513
514
515
516
                void $ I.modifyFd (emBackend mgr) fd
                                  (I.elEvent allEls) (I.elEvent savedEls)

        return triggered
517
518
519
520

nullToNothing :: [a] -> Maybe [a]
nullToNothing []       = Nothing
nullToNothing xs@(_:_) = Just xs
521
522
523

unless :: Monad m => Bool -> m () -> m ()
unless p = when (not p)