{-# LANGUAGE Trustworthy #-}{-# LANGUAGE BangPatterns
 , CPP
 , ExistentialQuantification
 , NoImplicitPrelude
 , TypeSynonymInstances
 , FlexibleInstances
 #-}moduleGHC.Event.TimerManager(-- * TypesTimerManager -- * Creation,new ,newWith ,newDefaultBackend ,emControl -- * Running,finished ,loop ,step ,shutdown ,cleanup ,wakeManager -- * Registering interest in timeout events,TimeoutCallback ,TimeoutKey ,registerTimeout ,updateTimeout ,unregisterTimeout )where
#include "EventConfig.h"
-------------------------------------------------------------------------- ImportsimportControl.Exception (finally )importData.Foldable (sequence_ )importData.IORef (IORef ,atomicModifyIORef' ,mkWeakIORef ,newIORef ,readIORef ,writeIORef )importGHC.Base importGHC.Clock (getMonotonicTimeNSec )importGHC.Conc.Signal (runHandlers )importGHC.Enum (maxBound )importGHC.Num (Num (..))importGHC.Real (quot ,fromIntegral )importGHC.Show (Show (..))importGHC.Event.Control importGHC.Event.Internal (Backend ,Event ,evtRead ,Timeout (..))importGHC.Event.Unique (Unique ,UniqueSource ,newSource ,newUnique )importSystem.Posix.Types (Fd )importqualifiedGHC.Event.Internal asIimportqualifiedGHC.Event.PSQ asQ
#if defined(HAVE_POLL)
importqualifiedGHC.Event.Poll asPoll
#else
# error not implemented for this operating system
#endif
-------------------------------------------------------------------------- Types-- | A timeout registration cookie.newtypeTimeoutKey =TK Unique derivingEq-- ^ @since 4.7.0.0-- | Callback invoked on timeout events.typeTimeoutCallback =IO()dataState =Created |Running |Dying |Finished deriving(Eq-- ^ @since 4.7.0.0,Show -- ^ @since 4.7.0.0)-- | A priority search queue, with timeouts as priorities.typeTimeoutQueue =Q.PSQ TimeoutCallback -- | An edit to apply to a 'TimeoutQueue'.typeTimeoutEdit =TimeoutQueue ->TimeoutQueue -- | The event manager state.dataTimerManager =TimerManager {TimerManager -> Backend
emBackend ::!Backend ,TimerManager -> IORef TimeoutQueue
emTimeouts ::{-# UNPACK#-}!(IORef TimeoutQueue ),TimerManager -> IORef State
emState ::{-# UNPACK#-}!(IORef State ),TimerManager -> UniqueSource
emUniqueSource ::{-# UNPACK#-}!UniqueSource ,TimerManager -> Control
emControl ::{-# UNPACK#-}!Control }-------------------------------------------------------------------------- CreationhandleControlEvent ::TimerManager ->Fd ->Event ->IO()handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
handleControlEvent mgr :: TimerManager
mgr fd :: Fd
fd _evt :: Event
_evt =doControlMessage
msg <-Control -> Fd -> IO ControlMessage
readControlMessage (TimerManager -> Control
emControl TimerManager
mgr )Fd
fd caseControlMessage
msg ofCMsgWakeup ->() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()CMsgDie ->IORef State -> State -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TimerManager -> IORef State
emState TimerManager
mgr )State
Finished CMsgSignal fp :: ForeignPtr Word8
fp s :: Signal
s ->ForeignPtr Word8 -> Signal -> IO ()
runHandlers ForeignPtr Word8
fp Signal
s newDefaultBackend ::IOBackend 
#if defined(HAVE_POLL)
newDefaultBackend :: IO Backend
newDefaultBackend =IO Backend
Poll.new 
#else
newDefaultBackend=errorWithoutStackTrace"no back end for this platform"
#endif
-- | Create a new event manager.new ::IOTimerManager new :: IO TimerManager
new =Backend -> IO TimerManager
newWith (Backend -> IO TimerManager) -> IO Backend -> IO TimerManager
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Backend
newDefaultBackend newWith ::Backend ->IOTimerManager newWith :: Backend -> IO TimerManager
newWith be :: Backend
be =doIORef TimeoutQueue
timeouts <-TimeoutQueue -> IO (IORef TimeoutQueue)
forall a. a -> IO (IORef a)
newIORef TimeoutQueue
forall v. IntPSQ v
Q.empty Control
ctrl <-Bool -> IO Control
newControl Bool
TrueIORef State
state <-State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef State
Created UniqueSource
us <-IO UniqueSource
newSource Weak (IORef State)
_<-IORef State -> IO () -> IO (Weak (IORef State))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef State
state (IO () -> IO (Weak (IORef State)))
-> IO () -> IO (Weak (IORef State))
forall a b. (a -> b) -> a -> b
$ doState
st <-IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef State
state ((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \s :: State
s ->(State
Finished ,State
s )Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State
st State -> State -> Bool
forall a. Eq a => a -> a -> Bool
/=State
Finished )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ doBackend -> IO ()
I.delete Backend
be Control -> IO ()
closeControl Control
ctrl letmgr :: TimerManager
mgr =$WTimerManager :: Backend
-> IORef TimeoutQueue
-> IORef State
-> UniqueSource
-> Control
-> TimerManager
TimerManager {emBackend :: Backend
emBackend =Backend
be ,emTimeouts :: IORef TimeoutQueue
emTimeouts =IORef TimeoutQueue
timeouts ,emState :: IORef State
emState =IORef State
state ,emUniqueSource :: UniqueSource
emUniqueSource =UniqueSource
us ,emControl :: Control
emControl =Control
ctrl }Bool
_<-Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd Backend
be (Control -> Fd
controlReadFd Control
ctrl )Event
forall a. Monoid a => a
mempty Event
evtRead Bool
_<-Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd Backend
be (Control -> Fd
wakeupReadFd Control
ctrl )Event
forall a. Monoid a => a
mempty Event
evtRead TimerManager -> IO TimerManager
forall (m :: * -> *) a. Monad m => a -> m a
return TimerManager
mgr -- | Asynchronously shuts down the event manager, if running.shutdown ::TimerManager ->IO()shutdown :: TimerManager -> IO ()
shutdown mgr :: TimerManager
mgr =doState
state <-IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef State
emState TimerManager
mgr )((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \s :: State
s ->(State
Dying ,State
s )Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State
state State -> State -> Bool
forall a. Eq a => a -> a -> Bool
==State
Running )(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Control -> IO ()
sendDie (TimerManager -> Control
emControl TimerManager
mgr )finished ::TimerManager ->IOBoolfinished :: TimerManager -> IO Bool
finished mgr :: TimerManager
mgr =(State -> State -> Bool
forall a. Eq a => a -> a -> Bool
==State
Finished )(State -> Bool) -> IO State -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IORef State -> IO State
forall a. IORef a -> IO a
readIORef (TimerManager -> IORef State
emState TimerManager
mgr )cleanup ::TimerManager ->IO()cleanup :: TimerManager -> IO ()
cleanup mgr :: TimerManager
mgr =doIORef State -> State -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TimerManager -> IORef State
emState TimerManager
mgr )State
Finished Backend -> IO ()
I.delete (TimerManager -> Backend
emBackend TimerManager
mgr )Control -> IO ()
closeControl (TimerManager -> Control
emControl TimerManager
mgr )-------------------------------------------------------------------------- Event loop-- | Start handling events. This function loops until told to stop,-- using 'shutdown'.---- /Note/: This loop can only be run once per 'TimerManager', as it-- closes all of its control resources when it finishes.loop ::TimerManager ->IO()loop :: TimerManager -> IO ()
loop mgr :: TimerManager
mgr =doState
state <-IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef State
emState TimerManager
mgr )((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \s :: State
s ->caseState
s ofCreated ->(State
Running ,State
s )_->(State
s ,State
s )caseState
state ofCreated ->IO ()
go IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` TimerManager -> IO ()
cleanup TimerManager
mgr Dying ->TimerManager -> IO ()
cleanup TimerManager
mgr _->doTimerManager -> IO ()
cleanup TimerManager
mgr String -> IO ()
forall a. String -> a
errorWithoutStackTrace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "GHC.Event.Manager.loop: state is already "String -> ShowS
forall a. [a] -> [a] -> [a]
++ State -> String
forall a. Show a => a -> String
show State
state wherego :: IO ()
go =doBool
running <-TimerManager -> IO Bool
step TimerManager
mgr Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
running IO ()
go step ::TimerManager ->IOBoolstep :: TimerManager -> IO Bool
step mgr :: TimerManager
mgr =doTimeout
timeout <-IO Timeout
mkTimeout Int
_<-Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
I.poll (TimerManager -> Backend
emBackend TimerManager
mgr )(Timeout -> Maybe Timeout
forall a. a -> Maybe a
Just Timeout
timeout )(TimerManager -> Fd -> Event -> IO ()
handleControlEvent TimerManager
mgr )State
state <-IORef State -> IO State
forall a. IORef a -> IO a
readIORef (TimerManager -> IORef State
emState TimerManager
mgr )State
state State -> IO Bool -> IO Bool
forall a b. a -> b -> b
`seq`Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (State
state State -> State -> Bool
forall a. Eq a => a -> a -> Bool
==State
Running )where-- | Call all expired timer callbacks and return the time to the-- next timeout.mkTimeout ::IOTimeout mkTimeout :: IO Timeout
mkTimeout =doWord64
now <-IO Word64
getMonotonicTimeNSec (expired :: [Elem (IO ())]
expired ,timeout :: Timeout
timeout )<-IORef TimeoutQueue
-> (TimeoutQueue -> (TimeoutQueue, ([Elem (IO ())], Timeout)))
-> IO ([Elem (IO ())], Timeout)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef TimeoutQueue
emTimeouts TimerManager
mgr )((TimeoutQueue -> (TimeoutQueue, ([Elem (IO ())], Timeout)))
 -> IO ([Elem (IO ())], Timeout))
-> (TimeoutQueue -> (TimeoutQueue, ([Elem (IO ())], Timeout)))
-> IO ([Elem (IO ())], Timeout)
forall a b. (a -> b) -> a -> b
$ \tq :: TimeoutQueue
tq ->let(expired :: [Elem (IO ())]
expired ,tq' :: TimeoutQueue
tq' )=Word64 -> TimeoutQueue -> ([Elem (IO ())], TimeoutQueue)
forall v. Word64 -> IntPSQ v -> ([Elem v], IntPSQ v)
Q.atMost Word64
now TimeoutQueue
tq timeout :: Timeout
timeout =caseTimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
tq' ofNothing ->Timeout
Forever Just (Q.E _t :: Word64
t _,_)->-- This value will always be positive since the call-- to 'atMost' above removed any timeouts <= 'now'lett' :: Word64
t' =Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
now inWord64
t' Word64 -> Timeout -> Timeout
forall a b. a -> b -> b
`seq`Word64 -> Timeout
Timeout Word64
t' in(TimeoutQueue
tq' ,([Elem (IO ())]
expired ,Timeout
timeout ))[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Elem (IO ()) -> IO ()) -> [Elem (IO ())] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map Elem (IO ()) -> IO ()
forall a. Elem a -> a
Q.value [Elem (IO ())]
expired Timeout -> IO Timeout
forall (m :: * -> *) a. Monad m => a -> m a
return Timeout
timeout -- | Wake up the event manager.wakeManager ::TimerManager ->IO()wakeManager :: TimerManager -> IO ()
wakeManager mgr :: TimerManager
mgr =Control -> IO ()
sendWakeup (TimerManager -> Control
emControl TimerManager
mgr )-------------------------------------------------------------------------- Registering interest in timeout eventsexpirationTime ::Int->IOQ.Prio expirationTime :: Int -> IO Word64
expirationTime us :: Int
us =doWord64
now <-IO Word64
getMonotonicTimeNSec letexpTime :: Word64
expTime -- Currently we treat overflows by clamping to maxBound. If humanity-- still exists in 2500 CE we will ned to be a bit more careful here.-- See #15158.|(Word64
forall a. Bounded a => a
maxBound Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
now )Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` 1000Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us =Word64
forall a. Bounded a => a
maxBound |Bool
otherwise =Word64
now Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
ns wherens :: Word64
ns =1000Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us Word64 -> IO Word64
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
expTime -- | Register a timeout in the given number of microseconds. The-- returned 'TimeoutKey' can be used to later unregister or update the-- timeout. The timeout is automatically unregistered after the given-- time has passed.registerTimeout ::TimerManager ->Int->TimeoutCallback ->IOTimeoutKey registerTimeout :: TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout mgr :: TimerManager
mgr us :: Int
us cb :: IO ()
cb =do!Unique
key <-UniqueSource -> IO Unique
newUnique (TimerManager -> UniqueSource
emUniqueSource TimerManager
mgr )ifInt
us Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=0thenIO ()
cb elsedoWord64
expTime <-Int -> IO Word64
expirationTime Int
us -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It-- doesn't because we just generated it from a unique supply.TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr (Unique -> Word64 -> IO () -> TimeoutEdit
forall v. Unique -> Word64 -> v -> IntPSQ v -> IntPSQ v
Q.unsafeInsertNew Unique
key Word64
expTime IO ()
cb )TimeoutKey -> IO TimeoutKey
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeoutKey -> IO TimeoutKey) -> TimeoutKey -> IO TimeoutKey
forall a b. (a -> b) -> a -> b
$ Unique -> TimeoutKey
TK Unique
key -- | Unregister an active timeout.unregisterTimeout ::TimerManager ->TimeoutKey ->IO()unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
unregisterTimeout mgr :: TimerManager
mgr (TK key :: Unique
key )=doTimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr (Unique -> TimeoutEdit
forall v. Unique -> IntPSQ v -> IntPSQ v
Q.delete Unique
key )-- | Update an active timeout to fire in the given number of-- microseconds.updateTimeout ::TimerManager ->TimeoutKey ->Int->IO()updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout mgr :: TimerManager
mgr (TK key :: Unique
key )us :: Int
us =doWord64
expTime <-Int -> IO Word64
expirationTime Int
us TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr ((Word64 -> Word64) -> Unique -> TimeoutEdit
forall a. (Word64 -> Word64) -> Unique -> PSQ a -> PSQ a
Q.adjust (Word64 -> Word64 -> Word64
forall a b. a -> b -> a
const Word64
expTime )Unique
key )editTimeouts ::TimerManager ->TimeoutEdit ->IO()editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts mgr :: TimerManager
mgr g :: TimeoutEdit
g =doBool
wake <-IORef TimeoutQueue
-> (TimeoutQueue -> (TimeoutQueue, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef TimeoutQueue
emTimeouts TimerManager
mgr )TimeoutQueue -> (TimeoutQueue, Bool)
f Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wake (TimerManager -> IO ()
wakeManager TimerManager
mgr )wheref :: TimeoutQueue -> (TimeoutQueue, Bool)
f q :: TimeoutQueue
q =(TimeoutQueue
q' ,Bool
wake )whereq' :: TimeoutQueue
q' =TimeoutEdit
g TimeoutQueue
q wake :: Bool
wake =caseTimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
q ofNothing ->Bool
TrueJust (Q.E _t0 :: Word64
t0 _,_)->caseTimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
q' ofJust (Q.E _t1 :: Word64
t1 _,_)->-- don't wake the manager if the-- minimum element didn't change.Word64
t0 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word64
t1 _->Bool
True