1{-# LANGUAGE Trustworthy #-}
2{-# LANGUAGE BangPatterns
3           , CPP
4           , ExistentialQuantification
5           , NoImplicitPrelude
6           , TypeSynonymInstances
7           , FlexibleInstances
8  #-}
9
10module GHC.Event.TimerManager
11    ( -- * Types
12      TimerManager
13
14      -- * Creation
15    , new
16    , newWith
17    , newDefaultBackend
18    , emControl
19
20      -- * Running
21    , finished
22    , loop
23    , step
24    , shutdown
25    , cleanup
26    , wakeManager
27
28      -- * Registering interest in timeout events
29    , TimeoutCallback
30    , TimeoutKey
31    , registerTimeout
32    , updateTimeout
33    , unregisterTimeout
34    ) where
35
36#include "EventConfig.h"
37
38------------------------------------------------------------------------
39-- Imports
40
41import Control.Exception (finally)
42import Data.Foldable (sequence_)
43import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
44                   writeIORef)
45import GHC.Base
46import GHC.Clock (getMonotonicTimeNSec)
47import GHC.Conc.Signal (runHandlers)
48import GHC.Enum (maxBound)
49import GHC.Num (Num(..))
50import GHC.Real (quot, fromIntegral)
51import GHC.Show (Show(..))
52import GHC.Event.Control
53import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
54import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
55import System.Posix.Types (Fd)
56
57import qualified GHC.Event.Internal as I
58import qualified GHC.Event.PSQ as Q
59
60#if defined(HAVE_POLL)
61import 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.
70newtype TimeoutKey   = TK Unique
71    deriving Eq -- ^ @since 4.7.0.0
72
73-- | Callback invoked on timeout events.
74type TimeoutCallback = IO ()
75
76data State = Created
77           | Running
78           | Dying
79           | Finished
80             deriving ( Eq   -- ^ @since 4.7.0.0
81                      , Show -- ^ @since 4.7.0.0
82                      )
83
84-- | A priority search queue, with timeouts as priorities.
85type TimeoutQueue = Q.PSQ TimeoutCallback
86
87-- | An edit to apply to a 'TimeoutQueue'.
88type TimeoutEdit = TimeoutQueue -> TimeoutQueue
89
90-- | The event manager state.
91data TimerManager = TimerManager
92    { emBackend      :: !Backend
93    , emTimeouts     :: {-# UNPACK #-} !(IORef TimeoutQueue)
94    , emState        :: {-# UNPACK #-} !(IORef State)
95    , emUniqueSource :: {-# UNPACK #-} !UniqueSource
96    , emControl      :: {-# UNPACK #-} !Control
97    }
98
99------------------------------------------------------------------------
100-- Creation
101
102handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
103handleControlEvent mgr fd _evt = do
104  msg <- readControlMessage (emControl mgr) fd
105  case msg of
106    CMsgWakeup      -> return ()
107    CMsgDie         -> writeIORef (emState mgr) Finished
108    CMsgSignal fp s -> runHandlers fp s
109
110newDefaultBackend :: IO Backend
111#if defined(HAVE_POLL)
112newDefaultBackend = Poll.new
113#else
114newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
115#endif
116
117-- | Create a new event manager.
118new :: IO TimerManager
119new = newWith =<< newDefaultBackend
120
121newWith :: Backend -> IO TimerManager
122newWith be = do
123  timeouts <- newIORef Q.empty
124  ctrl <- newControl True
125  state <- newIORef Created
126  us <- newSource
127  _ <- mkWeakIORef state $ do
128               st <- atomicModifyIORef' state $ \s -> (Finished, s)
129               when (st /= Finished) $ do
130                 I.delete be
131                 closeControl ctrl
132  let mgr = TimerManager { emBackend = be
133                         , emTimeouts = timeouts
134                         , emState = state
135                         , emUniqueSource = us
136                         , emControl = ctrl
137                         }
138  _ <- I.modifyFd be (controlReadFd ctrl) mempty evtRead
139  _ <- I.modifyFd be (wakeupReadFd ctrl) mempty evtRead
140  return mgr
141
142-- | Asynchronously shuts down the event manager, if running.
143shutdown :: TimerManager -> IO ()
144shutdown mgr = do
145  state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s)
146  when (state == Running) $ sendDie (emControl mgr)
147
148finished :: TimerManager -> IO Bool
149finished mgr = (== Finished) `liftM` readIORef (emState mgr)
150
151cleanup :: TimerManager -> IO ()
152cleanup mgr = do
153  writeIORef (emState mgr) Finished
154  I.delete (emBackend mgr)
155  closeControl (emControl mgr)
156
157------------------------------------------------------------------------
158-- Event loop
159
160-- | Start handling events.  This function loops until told to stop,
161-- using 'shutdown'.
162--
163-- /Note/: This loop can only be run once per 'TimerManager', as it
164-- closes all of its control resources when it finishes.
165loop :: TimerManager -> IO ()
166loop mgr = do
167  state <- atomicModifyIORef' (emState mgr) $ \s -> case s of
168    Created -> (Running, s)
169    _       -> (s, s)
170  case state of
171    Created -> go `finally` cleanup mgr
172    Dying   -> cleanup mgr
173    _       -> do cleanup mgr
174                  errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++
175                      show state
176 where
177  go = do running <- step mgr
178          when running go
179
180step :: TimerManager -> IO Bool
181step mgr = do
182  timeout <- mkTimeout
183  _ <- I.poll (emBackend mgr) (Just timeout) (handleControlEvent mgr)
184  state <- readIORef (emState mgr)
185  state `seq` return (state == Running)
186 where
187
188  -- | Call all expired timer callbacks and return the time to the
189  -- next timeout.
190  mkTimeout :: IO Timeout
191  mkTimeout = do
192      now <- getMonotonicTimeNSec
193      (expired, timeout) <- atomicModifyIORef' (emTimeouts mgr) $ \tq ->
194           let (expired, tq') = Q.atMost now tq
195               timeout = case Q.minView tq' of
196                 Nothing             -> Forever
197                 Just (Q.E _ t _, _) ->
198                     -- This value will always be positive since the call
199                     -- to 'atMost' above removed any timeouts <= 'now'
200                     let t' = t - now in t' `seq` Timeout t'
201           in (tq', (expired, timeout))
202      sequence_ $ map Q.value expired
203      return timeout
204
205-- | Wake up the event manager.
206wakeManager :: TimerManager -> IO ()
207wakeManager mgr = sendWakeup (emControl mgr)
208
209------------------------------------------------------------------------
210-- Registering interest in timeout events
211
212expirationTime :: Int -> IO Q.Prio
213expirationTime us = do
214    now <- getMonotonicTimeNSec
215    let expTime
216          -- Currently we treat overflows by clamping to maxBound. If humanity
217          -- still exists in 2500 CE we will ned to be a bit more careful here.
218          -- See #15158.
219          | (maxBound - now) `quot` 1000 < fromIntegral us  = maxBound
220          | otherwise                                       = now + ns
221          where ns = 1000 * fromIntegral us
222    return expTime
223
224-- | Register a timeout in the given number of microseconds.  The
225-- returned 'TimeoutKey' can be used to later unregister or update the
226-- timeout.  The timeout is automatically unregistered after the given
227-- time has passed.
228registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
229registerTimeout mgr us cb = do
230  !key <- newUnique (emUniqueSource mgr)
231  if us <= 0 then cb
232    else do
233      expTime <- expirationTime us
234
235      -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It
236      -- doesn't because we just generated it from a unique supply.
237      editTimeouts mgr (Q.unsafeInsertNew key expTime cb)
238  return $ TK key
239
240-- | Unregister an active timeout.
241unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
242unregisterTimeout mgr (TK key) = do
243  editTimeouts mgr (Q.delete key)
244
245-- | Update an active timeout to fire in the given number of
246-- microseconds.
247updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
248updateTimeout mgr (TK key) us = do
249  expTime <- expirationTime us
250  editTimeouts mgr (Q.adjust (const expTime) key)
251
252editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
253editTimeouts mgr g = do
254  wake <- atomicModifyIORef' (emTimeouts mgr) f
255  when wake (wakeManager mgr)
256  where
257    f q = (q', wake)
258      where
259        q' = g q
260        wake = case Q.minView q of
261                Nothing -> True
262                Just (Q.E _ t0 _, _) ->
263                  case Q.minView q' of
264                    Just (Q.E _ t1 _, _) ->
265                      -- don't wake the manager if the
266                      -- minimum element didn't change.
267                      t0 /= t1
268                    _ -> True
269