Update Trac ticket URLs to point to GitLab
[ghc.git] / libraries / base / GHC / Event / Manager.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE BangPatterns
3 , CPP
4 , ExistentialQuantification
5 , NoImplicitPrelude
6 , RecordWildCards
7 , TypeSynonymInstances
8 , FlexibleInstances
9 #-}
10
11 -- |
12 -- The event manager supports event notification on fds. Each fd may
13 -- have multiple callbacks registered, each listening for a different
14 -- set of events. Registrations may be automatically deactivated after
15 -- the occurrence of an event ("one-shot mode") or active until
16 -- explicitly unregistered.
17 --
18 -- If an fd has only one-shot registrations then we use one-shot
19 -- polling if available. Otherwise we use multi-shot polling.
20
21 module GHC.Event.Manager
22 ( -- * Types
23 EventManager
24
25 -- * Creation
26 , new
27 , newWith
28 , newDefaultBackend
29
30 -- * Running
31 , finished
32 , loop
33 , step
34 , shutdown
35 , release
36 , cleanup
37 , wakeManager
38
39 -- * State
40 , callbackTableVar
41 , emControl
42
43 -- * Registering interest in I/O events
44 , Lifetime (..)
45 , Event
46 , evtRead
47 , evtWrite
48 , IOCallback
49 , FdKey(keyFd)
50 , FdData
51 , registerFd
52 , unregisterFd_
53 , unregisterFd
54 , closeFd
55 , closeFd_
56 ) where
57
58 #include "EventConfig.h"
59
60 ------------------------------------------------------------------------
61 -- Imports
62
63 import Control.Concurrent.MVar (MVar, newMVar, putMVar,
64 tryPutMVar, takeMVar, withMVar)
65 import Control.Exception (onException)
66 import Data.Bits ((.&.))
67 import Data.Foldable (forM_)
68 import Data.Functor (void)
69 import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
70 writeIORef)
71 import Data.Maybe (maybe)
72 import Data.OldList (partition)
73 import GHC.Arr (Array, (!), listArray)
74 import GHC.Base
75 import GHC.Conc.Sync (yield)
76 import GHC.List (filter, replicate)
77 import GHC.Num (Num(..))
78 import GHC.Real (fromIntegral)
79 import GHC.Show (Show(..))
80 import GHC.Event.Control
81 import GHC.Event.IntTable (IntTable)
82 import GHC.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite,
83 Lifetime(..), EventLifetime, Timeout(..))
84 import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
85 import System.Posix.Types (Fd)
86
87 import qualified GHC.Event.IntTable as IT
88 import qualified GHC.Event.Internal as I
89
90 #if defined(HAVE_KQUEUE)
91 import qualified GHC.Event.KQueue as KQueue
92 #elif defined(HAVE_EPOLL)
93 import qualified GHC.Event.EPoll as EPoll
94 #elif defined(HAVE_POLL)
95 import qualified GHC.Event.Poll as Poll
96 #else
97 # error not implemented for this operating system
98 #endif
99
100 ------------------------------------------------------------------------
101 -- Types
102
103 data FdData = FdData {
104 fdKey :: {-# UNPACK #-} !FdKey
105 , fdEvents :: {-# UNPACK #-} !EventLifetime
106 , _fdCallback :: !IOCallback
107 }
108
109 -- | A file descriptor registration cookie.
110 data FdKey = FdKey {
111 keyFd :: {-# UNPACK #-} !Fd
112 , keyUnique :: {-# UNPACK #-} !Unique
113 } deriving ( Eq -- ^ @since 4.4.0.0
114 , Show -- ^ @since 4.4.0.0
115 )
116
117 -- | Callback invoked on I/O events.
118 type IOCallback = FdKey -> Event -> IO ()
119
120 data State = Created
121 | Running
122 | Dying
123 | Releasing
124 | Finished
125 deriving ( Eq -- ^ @since 4.4.0.0
126 , Show -- ^ @since 4.4.0.0
127 )
128
129 -- | The event manager state.
130 data EventManager = EventManager
131 { emBackend :: !Backend
132 , emFds :: {-# UNPACK #-} !(Array Int (MVar (IntTable [FdData])))
133 , emState :: {-# UNPACK #-} !(IORef State)
134 , emUniqueSource :: {-# UNPACK #-} !UniqueSource
135 , emControl :: {-# UNPACK #-} !Control
136 , emLock :: {-# UNPACK #-} !(MVar ())
137 }
138
139 -- must be power of 2
140 callbackArraySize :: Int
141 callbackArraySize = 32
142
143 hashFd :: Fd -> Int
144 hashFd fd = fromIntegral fd .&. (callbackArraySize - 1)
145 {-# INLINE hashFd #-}
146
147 callbackTableVar :: EventManager -> Fd -> MVar (IntTable [FdData])
148 callbackTableVar mgr fd = emFds mgr ! hashFd fd
149 {-# INLINE callbackTableVar #-}
150
151 haveOneShot :: Bool
152 {-# INLINE haveOneShot #-}
153 #if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
154 haveOneShot = False
155 #elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)
156 haveOneShot = True
157 #else
158 haveOneShot = False
159 #endif
160 ------------------------------------------------------------------------
161 -- Creation
162
163 handleControlEvent :: EventManager -> Fd -> Event -> IO ()
164 handleControlEvent mgr fd _evt = do
165 msg <- readControlMessage (emControl mgr) fd
166 case msg of
167 CMsgWakeup -> return ()
168 CMsgDie -> writeIORef (emState mgr) Finished
169 _ -> return ()
170
171 newDefaultBackend :: IO Backend
172 #if defined(HAVE_KQUEUE)
173 newDefaultBackend = KQueue.new
174 #elif defined(HAVE_EPOLL)
175 newDefaultBackend = EPoll.new
176 #elif defined(HAVE_POLL)
177 newDefaultBackend = Poll.new
178 #else
179 newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
180 #endif
181
182 -- | Create a new event manager.
183 new :: IO EventManager
184 new = newWith =<< newDefaultBackend
185
186 -- | Create a new 'EventManager' with the given polling backend.
187 newWith :: Backend -> IO EventManager
188 newWith be = do
189 iofds <- fmap (listArray (0, callbackArraySize-1)) $
190 replicateM callbackArraySize (newMVar =<< IT.new 8)
191 ctrl <- newControl False
192 state <- newIORef Created
193 us <- newSource
194 _ <- mkWeakIORef state $ do
195 st <- atomicModifyIORef' state $ \s -> (Finished, s)
196 when (st /= Finished) $ do
197 I.delete be
198 closeControl ctrl
199 lockVar <- newMVar ()
200 let mgr = EventManager { emBackend = be
201 , emFds = iofds
202 , emState = state
203 , emUniqueSource = us
204 , emControl = ctrl
205 , emLock = lockVar
206 }
207 registerControlFd mgr (controlReadFd ctrl) evtRead
208 registerControlFd mgr (wakeupReadFd ctrl) evtRead
209 return mgr
210 where
211 replicateM n x = sequence (replicate n x)
212
213 failOnInvalidFile :: String -> Fd -> IO Bool -> IO ()
214 failOnInvalidFile loc fd m = do
215 ok <- m
216 when (not ok) $
217 let msg = "Failed while attempting to modify registration of file " ++
218 show fd ++ " at location " ++ loc
219 in errorWithoutStackTrace msg
220
221 registerControlFd :: EventManager -> Fd -> Event -> IO ()
222 registerControlFd mgr fd evs =
223 failOnInvalidFile "registerControlFd" fd $
224 I.modifyFd (emBackend mgr) fd mempty evs
225
226 -- | Asynchronously shuts down the event manager, if running.
227 shutdown :: EventManager -> IO ()
228 shutdown mgr = do
229 state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s)
230 when (state == Running) $ sendDie (emControl mgr)
231
232 -- | Asynchronously tell the thread executing the event
233 -- manager loop to exit.
234 release :: EventManager -> IO ()
235 release EventManager{..} = do
236 state <- atomicModifyIORef' emState $ \s -> (Releasing, s)
237 when (state == Running) $ sendWakeup emControl
238
239 finished :: EventManager -> IO Bool
240 finished mgr = (== Finished) `liftM` readIORef (emState mgr)
241
242 cleanup :: EventManager -> IO ()
243 cleanup EventManager{..} = do
244 writeIORef emState Finished
245 void $ tryPutMVar emLock ()
246 I.delete emBackend
247 closeControl emControl
248
249 ------------------------------------------------------------------------
250 -- Event loop
251
252 -- | Start handling events. This function loops until told to stop,
253 -- using 'shutdown'.
254 --
255 -- /Note/: This loop can only be run once per 'EventManager', as it
256 -- closes all of its control resources when it finishes.
257 loop :: EventManager -> IO ()
258 loop mgr@EventManager{..} = do
259 void $ takeMVar emLock
260 state <- atomicModifyIORef' emState $ \s -> case s of
261 Created -> (Running, s)
262 Releasing -> (Running, s)
263 _ -> (s, s)
264 case state of
265 Created -> go `onException` cleanup mgr
266 Releasing -> go `onException` cleanup mgr
267 Dying -> cleanup mgr
268 -- While a poll loop is never forked when the event manager is in the
269 -- 'Finished' state, its state could read 'Finished' once the new thread
270 -- actually runs. This is not an error, just an unfortunate race condition
271 -- in Thread.restartPollLoop. See #8235
272 Finished -> return ()
273 _ -> do cleanup mgr
274 errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++
275 show state
276 where
277 go = do state <- step mgr
278 case state of
279 Running -> yield >> go
280 Releasing -> putMVar emLock ()
281 _ -> cleanup mgr
282
283 -- | To make a step, we first do a non-blocking poll, in case
284 -- there are already events ready to handle. This improves performance
285 -- because we can make an unsafe foreign C call, thereby avoiding
286 -- forcing the current Task to release the Capability and forcing a context switch.
287 -- If the poll fails to find events, we yield, putting the poll loop thread at
288 -- end of the Haskell run queue. When it comes back around, we do one more
289 -- non-blocking poll, in case we get lucky and have ready events.
290 -- If that also returns no events, then we do a blocking poll.
291 step :: EventManager -> IO State
292 step mgr@EventManager{..} = do
293 waitForIO
294 state <- readIORef emState
295 state `seq` return state
296 where
297 waitForIO = do
298 n1 <- I.poll emBackend Nothing (onFdEvent mgr)
299 when (n1 <= 0) $ do
300 yield
301 n2 <- I.poll emBackend Nothing (onFdEvent mgr)
302 when (n2 <= 0) $ do
303 _ <- I.poll emBackend (Just Forever) (onFdEvent mgr)
304 return ()
305
306 ------------------------------------------------------------------------
307 -- Registering interest in I/O events
308
309 -- | Register interest in the given events, without waking the event
310 -- manager thread. The 'Bool' return value indicates whether the
311 -- event manager ought to be woken.
312 --
313 -- Note that the event manager is generally implemented in terms of the
314 -- platform's @select@ or @epoll@ system call, which tend to vary in
315 -- what sort of fds are permitted. For instance, waiting on regular files
316 -- is not allowed on many platforms.
317 registerFd_ :: EventManager -> IOCallback -> Fd -> Event -> Lifetime
318 -> IO (FdKey, Bool)
319 registerFd_ mgr@(EventManager{..}) cb fd evs lt = do
320 u <- newUnique emUniqueSource
321 let fd' = fromIntegral fd
322 reg = FdKey fd u
323 el = I.eventLifetime evs lt
324 !fdd = FdData reg el cb
325 (modify,ok) <- withMVar (callbackTableVar mgr fd) $ \tbl -> do
326 oldFdd <- IT.insertWith (++) fd' [fdd] tbl
327 let prevEvs :: EventLifetime
328 prevEvs = maybe mempty eventsOf oldFdd
329
330 el' :: EventLifetime
331 el' = prevEvs `mappend` el
332 case I.elLifetime el' of
333 -- All registrations want one-shot semantics and this is supported
334 OneShot | haveOneShot -> do
335 ok <- I.modifyFdOnce emBackend fd (I.elEvent el')
336 if ok
337 then return (False, True)
338 else IT.reset fd' oldFdd tbl >> return (False, False)
339
340 -- We don't want or don't support one-shot semantics
341 _ -> do
342 let modify = prevEvs /= el'
343 ok <- if modify
344 then let newEvs = I.elEvent el'
345 oldEvs = I.elEvent prevEvs
346 in I.modifyFd emBackend fd oldEvs newEvs
347 else return True
348 if ok
349 then return (modify, True)
350 else IT.reset fd' oldFdd tbl >> return (False, False)
351 -- this simulates behavior of old IO manager:
352 -- i.e. just call the callback if the registration fails.
353 when (not ok) (cb reg evs)
354 return (reg,modify)
355 {-# INLINE registerFd_ #-}
356
357 -- | @registerFd mgr cb fd evs lt@ registers interest in the events @evs@
358 -- on the file descriptor @fd@ for lifetime @lt@. @cb@ is called for
359 -- each event that occurs. Returns a cookie that can be handed to
360 -- 'unregisterFd'.
361 registerFd :: EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey
362 registerFd mgr cb fd evs lt = do
363 (r, wake) <- registerFd_ mgr cb fd evs lt
364 when wake $ wakeManager mgr
365 return r
366 {-# INLINE registerFd #-}
367
368 {-
369 Building GHC with parallel IO manager on Mac freezes when
370 compiling the dph libraries in the phase 2. As workaround, we
371 don't use oneshot and we wake up an IO manager on Mac every time
372 when we register an event.
373
374 For more information, please read:
375 https://gitlab.haskell.org/ghc/ghc/issues/7651
376 -}
377 -- | Wake up the event manager.
378 wakeManager :: EventManager -> IO ()
379 #if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
380 wakeManager mgr = sendWakeup (emControl mgr)
381 #elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)
382 wakeManager _ = return ()
383 #else
384 wakeManager mgr = sendWakeup (emControl mgr)
385 #endif
386
387 eventsOf :: [FdData] -> EventLifetime
388 eventsOf [fdd] = fdEvents fdd
389 eventsOf fdds = mconcat $ map fdEvents fdds
390
391 -- | Drop a previous file descriptor registration, without waking the
392 -- event manager thread. The return value indicates whether the event
393 -- manager ought to be woken.
394 unregisterFd_ :: EventManager -> FdKey -> IO Bool
395 unregisterFd_ mgr@(EventManager{..}) (FdKey fd u) =
396 withMVar (callbackTableVar mgr fd) $ \tbl -> do
397 let dropReg = nullToNothing . filter ((/= u) . keyUnique . fdKey)
398 fd' = fromIntegral fd
399 pairEvents :: [FdData] -> IO (EventLifetime, EventLifetime)
400 pairEvents prev = do
401 r <- maybe mempty eventsOf `fmap` IT.lookup fd' tbl
402 return (eventsOf prev, r)
403 (oldEls, newEls) <- IT.updateWith dropReg fd' tbl >>=
404 maybe (return (mempty, mempty)) pairEvents
405 let modify = oldEls /= newEls
406 when modify $ failOnInvalidFile "unregisterFd_" fd $
407 case I.elLifetime newEls of
408 OneShot | I.elEvent newEls /= mempty, haveOneShot ->
409 I.modifyFdOnce emBackend fd (I.elEvent newEls)
410 _ ->
411 I.modifyFd emBackend fd (I.elEvent oldEls) (I.elEvent newEls)
412 return modify
413
414 -- | Drop a previous file descriptor registration.
415 unregisterFd :: EventManager -> FdKey -> IO ()
416 unregisterFd mgr reg = do
417 wake <- unregisterFd_ mgr reg
418 when wake $ wakeManager mgr
419
420 -- | Close a file descriptor in a race-safe way.
421 closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO ()
422 closeFd mgr close fd = do
423 fds <- withMVar (callbackTableVar mgr fd) $ \tbl -> do
424 prev <- IT.delete (fromIntegral fd) tbl
425 case prev of
426 Nothing -> close fd >> return []
427 Just fds -> do
428 let oldEls = eventsOf fds
429 when (I.elEvent oldEls /= mempty) $ do
430 _ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty
431 wakeManager mgr
432 close fd
433 return fds
434 forM_ fds $ \(FdData reg el cb) -> cb reg (I.elEvent el `mappend` evtClose)
435
436 -- | Close a file descriptor in a race-safe way.
437 -- It assumes the caller will update the callback tables and that the caller
438 -- holds the callback table lock for the fd. It must hold this lock because
439 -- this command executes a backend command on the fd.
440 closeFd_ :: EventManager
441 -> IntTable [FdData]
442 -> Fd
443 -> IO (IO ())
444 closeFd_ mgr tbl fd = do
445 prev <- IT.delete (fromIntegral fd) tbl
446 case prev of
447 Nothing -> return (return ())
448 Just fds -> do
449 let oldEls = eventsOf fds
450 when (oldEls /= mempty) $ do
451 _ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty
452 wakeManager mgr
453 return $
454 forM_ fds $ \(FdData reg el cb) ->
455 cb reg (I.elEvent el `mappend` evtClose)
456
457 ------------------------------------------------------------------------
458 -- Utilities
459
460 -- | Call the callbacks corresponding to the given file descriptor.
461 onFdEvent :: EventManager -> Fd -> Event -> IO ()
462 onFdEvent mgr fd evs
463 | fd == controlReadFd (emControl mgr) || fd == wakeupReadFd (emControl mgr) =
464 handleControlEvent mgr fd evs
465
466 | otherwise = do
467 fdds <- withMVar (callbackTableVar mgr fd) $ \tbl ->
468 IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl)
469 forM_ fdds $ \(FdData reg _ cb) -> cb reg evs
470 where
471 -- | Here we look through the list of registrations for the fd of interest
472 -- and sort out which match the events that were triggered. We,
473 --
474 -- 1. re-arm the fd as appropriate
475 -- 2. reinsert registrations that weren't triggered and multishot
476 -- registrations
477 -- 3. return a list containing the callbacks that should be invoked.
478 selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData]
479 selectCallbacks tbl fdds = do
480 let -- figure out which registrations have been triggered
481 matches :: FdData -> Bool
482 matches fd' = evs `I.eventIs` I.elEvent (fdEvents fd')
483 (triggered, notTriggered) = partition matches fdds
484
485 -- sort out which registrations we need to retain
486 isMultishot :: FdData -> Bool
487 isMultishot fd' = I.elLifetime (fdEvents fd') == MultiShot
488 saved = notTriggered ++ filter isMultishot triggered
489
490 savedEls = eventsOf saved
491 allEls = eventsOf fdds
492
493 -- Reinsert multishot registrations.
494 -- We deleted the table entry for this fd above so we there isn't a preexisting entry
495 _ <- IT.insertWith (\_ _ -> saved) (fromIntegral fd) saved tbl
496
497 case I.elLifetime allEls of
498 -- we previously armed the fd for multiple shots, no need to rearm
499 MultiShot | allEls == savedEls ->
500 return ()
501
502 -- either we previously registered for one shot or the
503 -- events of interest have changed, we must re-arm
504 _ ->
505 case I.elLifetime savedEls of
506 OneShot | haveOneShot ->
507 -- if there are no saved events and we registered with one-shot
508 -- semantics then there is no need to re-arm
509 unless (OneShot == I.elLifetime allEls
510 && mempty == I.elEvent savedEls) $ do
511 void $ I.modifyFdOnce (emBackend mgr) fd (I.elEvent savedEls)
512 _ ->
513 -- we need to re-arm with multi-shot semantics
514 void $ I.modifyFd (emBackend mgr) fd
515 (I.elEvent allEls) (I.elEvent savedEls)
516
517 return triggered
518
519 nullToNothing :: [a] -> Maybe [a]
520 nullToNothing [] = Nothing
521 nullToNothing xs@(_:_) = Just xs
522
523 unless :: Monad m => Bool -> m () -> m ()
524 unless p = when (not p)