{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Trustworthy #-}
module GHC.Event.TimerManager
(
TimerManager
, new
, newWith
, newDefaultBackend
, emControl
, finished
, loop
, step
, shutdown
, cleanup
, wakeManager
, TimeoutCallback
, TimeoutKey
, registerTimeout
, updateTimeout
, unregisterTimeout
) where
#include "EventConfig.h"
import Control.Exception (finally)
import Data.Foldable (sequence_)
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
writeIORef)
import GHC.Base
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Conc.Signal (runHandlers)
import GHC.Enum (maxBound)
import GHC.Num (Num(..))
import GHC.Real (quot, fromIntegral)
import GHC.Show (Show(..))
import GHC.Event.Control
import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
import GHC.Event.Unique (UniqueSource, newSource, newUnique)
import GHC.Event.TimeOut
import System.Posix.Types (Fd)
import qualified GHC.Event.Internal as I
import qualified GHC.Event.PSQ as Q
#if defined(HAVE_POLL)
import qualified GHC.Event.Poll as Poll
#else
# error not implemented for this operating system
#endif
data State = Created
| Running
| Dying
| Finished
deriving ( State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: State -> State -> Bool
Eq
, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> State -> ShowS
showsPrec :: Int -> State -> ShowS
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> ShowS
showList :: [State] -> ShowS
Show
)
data TimerManager = 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
}
handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
handleControlEvent TimerManager
mgr Fd
fd Event
_evt = do
ControlMessage
msg <- Control -> Fd -> IO ControlMessage
readControlMessage (TimerManager -> Control
emControl TimerManager
mgr) Fd
fd
case ControlMessage
msg of
ControlMessage
CMsgWakeup -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ControlMessage
CMsgDie -> IORef State -> State -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TimerManager -> IORef State
emState TimerManager
mgr) State
Finished
CMsgSignal ForeignPtr Word8
fp Signal
s -> ForeignPtr Word8 -> Signal -> IO ()
runHandlers ForeignPtr Word8
fp Signal
s
newDefaultBackend :: IO Backend
#if defined(HAVE_POLL)
newDefaultBackend :: IO Backend
newDefaultBackend = IO Backend
Poll.new
#else
newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
#endif
new :: IO TimerManager
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 -> IO TimerManager
newWith :: Backend -> IO TimerManager
newWith Backend
be = do
IORef 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
True
IORef 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
$ do
State
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
$ \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
$ do
Backend -> IO ()
I.delete Backend
be
Control -> IO ()
closeControl Control
ctrl
let mgr :: TimerManager
mgr = 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TimerManager
mgr
shutdown :: TimerManager -> IO ()
shutdown :: TimerManager -> IO ()
shutdown TimerManager
mgr = do
State
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
$ \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 -> IO Bool
finished :: TimerManager -> IO Bool
finished 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 TimerManager
mgr = do
IORef 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)
loop :: TimerManager -> IO ()
loop :: TimerManager -> IO ()
loop TimerManager
mgr = do
State
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
$ \State
s -> case State
s of
State
Created -> (State
Running, State
s)
State
_ -> (State
s, State
s)
case State
state of
State
Created -> IO ()
go IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` TimerManager -> IO ()
cleanup TimerManager
mgr
State
Dying -> TimerManager -> IO ()
cleanup TimerManager
mgr
State
_ -> do TimerManager -> IO ()
cleanup TimerManager
mgr
String -> IO ()
forall a. String -> a
errorWithoutStackTrace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"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
where
go :: IO ()
go = do Bool
running <- TimerManager -> IO Bool
step TimerManager
mgr
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
running IO ()
go
step :: TimerManager -> IO Bool
step :: TimerManager -> IO Bool
step TimerManager
mgr = do
Timeout
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (State
state State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
Running)
where
mkTimeout :: IO Timeout
mkTimeout :: IO Timeout
mkTimeout = do
Word64
now <- IO Word64
getMonotonicTimeNSec
([Elem (IO ())]
expired, 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
$ \TimeoutQueue
tq ->
let ([Elem (IO ())]
expired, 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 = case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
tq' of
Maybe (Elem (IO ()), TimeoutQueue)
Nothing -> Timeout
Forever
Just (Q.E Key
_ Word64
t IO ()
_, TimeoutQueue
_) ->
let t' :: Word64
t' = Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
now in Word64
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Timeout
timeout
wakeManager :: TimerManager -> IO ()
wakeManager :: TimerManager -> IO ()
wakeManager TimerManager
mgr = Control -> IO ()
sendWakeup (TimerManager -> Control
emControl TimerManager
mgr)
expirationTime :: Int -> IO Q.Prio
expirationTime :: Int -> IO Word64
expirationTime Int
us = do
Word64
now <- IO Word64
getMonotonicTimeNSec
let expTime :: Word64
expTime
| (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` Word64
1000 Word64 -> 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
where ns :: Word64
ns = Word64
1000 Word64 -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
expTime
registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout :: TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
mgr Int
us IO ()
cb = do
!Key
key <- UniqueSource -> IO Key
newUnique (TimerManager -> UniqueSource
emUniqueSource TimerManager
mgr)
if Int
us Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then IO ()
cb
else do
Word64
expTime <- Int -> IO Word64
expirationTime Int
us
TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr (Key -> Word64 -> IO () -> TimeoutEdit
forall v. Key -> Word64 -> v -> IntPSQ v -> IntPSQ v
Q.unsafeInsertNew Key
key Word64
expTime IO ()
cb)
TimeoutKey -> IO TimeoutKey
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeoutKey -> IO TimeoutKey) -> TimeoutKey -> IO TimeoutKey
forall a b. (a -> b) -> a -> b
$ Key -> TimeoutKey
TK Key
key
unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
unregisterTimeout TimerManager
mgr (TK Key
key) =
TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr (Key -> TimeoutEdit
forall v. Key -> IntPSQ v -> IntPSQ v
Q.delete Key
key)
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout TimerManager
mgr (TK Key
key) Int
us = do
Word64
expTime <- Int -> IO Word64
expirationTime Int
us
TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr ((Word64 -> Word64) -> Key -> TimeoutEdit
forall a. (Word64 -> Word64) -> Key -> PSQ a -> PSQ a
Q.adjust (Word64 -> Word64 -> Word64
forall a b. a -> b -> a
const Word64
expTime) Key
key)
editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr TimeoutEdit
g = do
Bool
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)
where
f :: TimeoutQueue -> (TimeoutQueue, Bool)
f TimeoutQueue
q = (TimeoutQueue
q', Bool
wake)
where
q' :: TimeoutQueue
q' = TimeoutEdit
g TimeoutQueue
q
wake :: Bool
wake = case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
q of
Maybe (Elem (IO ()), TimeoutQueue)
Nothing -> Bool
True
Just (Q.E Key
_ Word64
t0 IO ()
_, TimeoutQueue
_) ->
case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
q' of
Just (Q.E Key
_ Word64
t1 IO ()
_, TimeoutQueue
_) ->
Word64
t0 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
t1
Maybe (Elem (IO ()), TimeoutQueue)
_ -> Bool
True