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