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