b5818919e0173ae89943e21d3798010462905e0f
[packages/base.git] / GHC / Event / TimerManager.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE BangPatterns
3 , CPP
4 , ExistentialQuantification
5 , NoImplicitPrelude
6 , TypeSynonymInstances
7 , FlexibleInstances
8 #-}
9
10 module GHC.Event.TimerManager
11 ( -- * Types
12 TimerManager
13
14 -- * Creation
15 , new
16 , newWith
17 , newDefaultBackend
18
19 -- * Running
20 , finished
21 , loop
22 , step
23 , shutdown
24 , cleanup
25 , wakeManager
26
27 -- * Registering interest in timeout events
28 , TimeoutCallback
29 , TimeoutKey
30 , registerTimeout
31 , updateTimeout
32 , unregisterTimeout
33 ) where
34
35 #include "EventConfig.h"
36
37 ------------------------------------------------------------------------
38 -- Imports
39
40 import Control.Exception (finally)
41 import Control.Monad ((=<<), liftM, sequence_, when)
42 import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef,
43 writeIORef)
44 import Data.Maybe (Maybe(..))
45 import Data.Monoid (mempty)
46 import GHC.Base
47 import GHC.Conc.Signal (runHandlers)
48 import GHC.Num (Num(..))
49 import GHC.Real ((/), fromIntegral )
50 import GHC.Show (Show(..))
51 import GHC.Event.Clock (getMonotonicTime)
52 import GHC.Event.Control
53 import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
54 import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
55 import System.Posix.Types (Fd)
56
57 import qualified GHC.Event.Internal as I
58 import qualified GHC.Event.PSQ as Q
59
60 #if defined(HAVE_POLL)
61 import qualified GHC.Event.Poll as Poll
62 #else
63 # error not implemented for this operating system
64 #endif
65
66 ------------------------------------------------------------------------
67 -- Types
68
69 -- | A timeout registration cookie.
70 newtype TimeoutKey = TK Unique
71 deriving (Eq)
72
73 -- | Callback invoked on timeout events.
74 type TimeoutCallback = IO ()
75
76 data State = Created
77 | Running
78 | Dying
79 | Finished
80 deriving (Eq, Show)
81
82 -- | A priority search queue, with timeouts as priorities.
83 type TimeoutQueue = Q.PSQ TimeoutCallback
84
85 {-
86 Instead of directly modifying the 'TimeoutQueue' in
87 e.g. 'registerTimeout' we keep a list of edits to perform, in the form
88 of a chain of function closures, and have the I/O manager thread
89 perform the edits later. This exist to address the following GC
90 problem:
91
92 Since e.g. 'registerTimeout' doesn't force the evaluation of the
93 thunks inside the 'emTimeouts' IORef a number of thunks build up
94 inside the IORef. If the I/O manager thread doesn't evaluate these
95 thunks soon enough they'll get promoted to the old generation and
96 become roots for all subsequent minor GCs.
97
98 When the thunks eventually get evaluated they will each create a new
99 intermediate 'TimeoutQueue' that immediately becomes garbage. Since
100 the thunks serve as roots until the next major GC these intermediate
101 'TimeoutQueue's will get copied unnecesarily in the next minor GC,
102 increasing GC time. This problem is known as "floating garbage".
103
104 Keeping a list of edits doesn't stop this from happening but makes the
105 amount of data that gets copied smaller.
106
107 TODO: Evaluate the content of the IORef to WHNF on each insert once
108 this bug is resolved: http://hackage.haskell.org/trac/ghc/ticket/3838
109 -}
110
111 -- | An edit to apply to a 'TimeoutQueue'.
112 type TimeoutEdit = TimeoutQueue -> TimeoutQueue
113
114 -- | The event manager state.
115 data TimerManager = TimerManager
116 { emBackend :: !Backend
117 , emTimeouts :: {-# UNPACK #-} !(IORef TimeoutEdit)
118 , emState :: {-# UNPACK #-} !(IORef State)
119 , emUniqueSource :: {-# UNPACK #-} !UniqueSource
120 , emControl :: {-# UNPACK #-} !Control
121 }
122
123 ------------------------------------------------------------------------
124 -- Creation
125
126 handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
127 handleControlEvent mgr fd _evt = do
128 msg <- readControlMessage (emControl mgr) fd
129 case msg of
130 CMsgWakeup -> return ()
131 CMsgDie -> writeIORef (emState mgr) Finished
132 CMsgSignal fp s -> runHandlers fp s
133
134 newDefaultBackend :: IO Backend
135 #if defined(HAVE_POLL)
136 newDefaultBackend = Poll.new
137 #else
138 newDefaultBackend = error "no back end for this platform"
139 #endif
140
141 -- | Create a new event manager.
142 new :: IO TimerManager
143 new = newWith =<< newDefaultBackend
144
145 newWith :: Backend -> IO TimerManager
146 newWith be = do
147 timeouts <- newIORef id
148 ctrl <- newControl True
149 state <- newIORef Created
150 us <- newSource
151 _ <- mkWeakIORef state $ do
152 st <- atomicModifyIORef state $ \s -> (Finished, s)
153 when (st /= Finished) $ do
154 I.delete be
155 closeControl ctrl
156 let mgr = TimerManager { emBackend = be
157 , emTimeouts = timeouts
158 , emState = state
159 , emUniqueSource = us
160 , emControl = ctrl
161 }
162 _ <- I.modifyFd be (controlReadFd ctrl) mempty evtRead
163 _ <- I.modifyFd be (wakeupReadFd ctrl) mempty evtRead
164 return mgr
165
166 -- | Asynchronously shuts down the event manager, if running.
167 shutdown :: TimerManager -> IO ()
168 shutdown mgr = do
169 state <- atomicModifyIORef (emState mgr) $ \s -> (Dying, s)
170 when (state == Running) $ sendDie (emControl mgr)
171
172 finished :: TimerManager -> IO Bool
173 finished mgr = (== Finished) `liftM` readIORef (emState mgr)
174
175 cleanup :: TimerManager -> IO ()
176 cleanup mgr = do
177 writeIORef (emState mgr) Finished
178 I.delete (emBackend mgr)
179 closeControl (emControl mgr)
180
181 ------------------------------------------------------------------------
182 -- Event loop
183
184 -- | Start handling events. This function loops until told to stop,
185 -- using 'shutdown'.
186 --
187 -- /Note/: This loop can only be run once per 'TimerManager', as it
188 -- closes all of its control resources when it finishes.
189 loop :: TimerManager -> IO ()
190 loop mgr = do
191 state <- atomicModifyIORef (emState mgr) $ \s -> case s of
192 Created -> (Running, s)
193 _ -> (s, s)
194 case state of
195 Created -> go Q.empty `finally` cleanup mgr
196 Dying -> cleanup mgr
197 _ -> do cleanup mgr
198 error $ "GHC.Event.Manager.loop: state is already " ++
199 show state
200 where
201 go q = do (running, q') <- step mgr q
202 when running $ go q'
203
204 step :: TimerManager -> TimeoutQueue -> IO (Bool, TimeoutQueue)
205 step mgr tq = do
206 (timeout, q') <- mkTimeout tq
207 _ <- I.poll (emBackend mgr) (Just timeout) (handleControlEvent mgr)
208 state <- readIORef (emState mgr)
209 state `seq` return (state == Running, q')
210 where
211
212 -- | Call all expired timer callbacks and return the time to the
213 -- next timeout.
214 mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue)
215 mkTimeout q = do
216 now <- getMonotonicTime
217 applyEdits <- atomicModifyIORef (emTimeouts mgr) $ \f -> (id, f)
218 let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q'
219 sequence_ $ map Q.value expired
220 let timeout = case Q.minView q'' of
221 Nothing -> Forever
222 Just (Q.E _ t _, _) ->
223 -- This value will always be positive since the call
224 -- to 'atMost' above removed any timeouts <= 'now'
225 let t' = t - now in t' `seq` Timeout t'
226 return (timeout, q'')
227
228 -- | Wake up the event manager.
229 wakeManager :: TimerManager -> IO ()
230 wakeManager mgr = sendWakeup (emControl mgr)
231
232 ------------------------------------------------------------------------
233 -- Registering interest in timeout events
234
235 -- | Register a timeout in the given number of microseconds. The
236 -- returned 'TimeoutKey' can be used to later unregister or update the
237 -- timeout. The timeout is automatically unregistered after the given
238 -- time has passed.
239 registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
240 registerTimeout mgr us cb = do
241 !key <- newUnique (emUniqueSource mgr)
242 if us <= 0 then cb
243 else do
244 now <- getMonotonicTime
245 let expTime = fromIntegral us / 1000000.0 + now
246
247 -- We intentionally do not evaluate the modified map to WHNF here.
248 -- Instead, we leave a thunk inside the IORef and defer its
249 -- evaluation until mkTimeout in the event loop. This is a
250 -- workaround for a nasty IORef contention problem that causes the
251 -- thread-delay benchmark to take 20 seconds instead of 0.2.
252 atomicModifyIORef (emTimeouts mgr) $ \f ->
253 let f' = (Q.insert key expTime cb) . f in (f', ())
254 wakeManager mgr
255 return $ TK key
256
257 -- | Unregister an active timeout.
258 unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
259 unregisterTimeout mgr (TK key) = do
260 atomicModifyIORef (emTimeouts mgr) $ \f ->
261 let f' = (Q.delete key) . f in (f', ())
262 wakeManager mgr
263
264 -- | Update an active timeout to fire in the given number of
265 -- microseconds.
266 updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
267 updateTimeout mgr (TK key) us = do
268 now <- getMonotonicTime
269 let expTime = fromIntegral us / 1000000.0 + now
270
271 atomicModifyIORef (emTimeouts mgr) $ \f ->
272 let f' = (Q.adjust (const expTime) key) . f in (f', ())
273 wakeManager mgr