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