{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE BangPatterns
, CPP
, ExistentialQuantification
, NoImplicitPrelude
, TypeSynonymInstances
, FlexibleInstances
#-}
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.Num (Num(..))
import GHC.Real (fromIntegral)
import GHC.Show (Show(..))
import GHC.Event.Control
import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
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
newtype TimeoutKey = TK Unique
deriving (Eq)
type TimeoutCallback = IO ()
data State = Created
| Running
| Dying
| Finished
deriving (Eq, Show)
type TimeoutQueue = Q.PSQ TimeoutCallback
type TimeoutEdit = TimeoutQueue -> TimeoutQueue
data TimerManager = TimerManager
{ emBackend :: !Backend
, emTimeouts :: {-# UNPACK #-} !(IORef TimeoutQueue)
, emState :: {-# UNPACK #-} !(IORef State)
, emUniqueSource :: {-# UNPACK #-} !UniqueSource
, emControl :: {-# UNPACK #-} !Control
}
handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
handleControlEvent mgr fd _evt = do
msg <- readControlMessage (emControl mgr) fd
case msg of
CMsgWakeup -> return ()
CMsgDie -> writeIORef (emState mgr) Finished
CMsgSignal fp s -> runHandlers fp s
newDefaultBackend :: IO Backend
#if defined(HAVE_POLL)
newDefaultBackend = Poll.new
#else
newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
#endif
new :: IO TimerManager
new = newWith =<< newDefaultBackend
newWith :: Backend -> IO TimerManager
newWith be = do
timeouts <- newIORef Q.empty
ctrl <- newControl True
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
st <- atomicModifyIORef' state $ \s -> (Finished, s)
when (st /= Finished) $ do
I.delete be
closeControl ctrl
let mgr = TimerManager { emBackend = be
, emTimeouts = timeouts
, emState = state
, emUniqueSource = us
, emControl = ctrl
}
_ <- I.modifyFd be (controlReadFd ctrl) mempty evtRead
_ <- I.modifyFd be (wakeupReadFd ctrl) mempty evtRead
return mgr
shutdown :: TimerManager -> IO ()
shutdown mgr = do
state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s)
when (state == Running) $ sendDie (emControl mgr)
finished :: TimerManager -> IO Bool
finished mgr = (== Finished) `liftM` readIORef (emState mgr)
cleanup :: TimerManager -> IO ()
cleanup mgr = do
writeIORef (emState mgr) Finished
I.delete (emBackend mgr)
closeControl (emControl mgr)
loop :: TimerManager -> IO ()
loop mgr = do
state <- atomicModifyIORef' (emState mgr) $ \s -> case s of
Created -> (Running, s)
_ -> (s, s)
case state of
Created -> go `finally` cleanup mgr
Dying -> cleanup mgr
_ -> do cleanup mgr
errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++
show state
where
go = do running <- step mgr
when running go
step :: TimerManager -> IO Bool
step mgr = do
timeout <- mkTimeout
_ <- I.poll (emBackend mgr) (Just timeout) (handleControlEvent mgr)
state <- readIORef (emState mgr)
state `seq` return (state == Running)
where
mkTimeout :: IO Timeout
mkTimeout = do
now <- getMonotonicTimeNSec
(expired, timeout) <- atomicModifyIORef' (emTimeouts mgr) $ \tq ->
let (expired, tq') = Q.atMost now tq
timeout = case Q.minView tq' of
Nothing -> Forever
Just (Q.E _ t _, _) ->
let t' = t - now in t' `seq` Timeout t'
in (tq', (expired, timeout))
sequence_ $ map Q.value expired
return timeout
wakeManager :: TimerManager -> IO ()
wakeManager mgr = sendWakeup (emControl mgr)
registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout mgr us cb = do
!key <- newUnique (emUniqueSource mgr)
if us <= 0 then cb
else do
now <- getMonotonicTimeNSec
let expTime = fromIntegral us * 1000 + now
editTimeouts mgr (Q.insert key expTime cb)
return $ TK key
unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
unregisterTimeout mgr (TK key) = do
editTimeouts mgr (Q.delete key)
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout mgr (TK key) us = do
now <- getMonotonicTimeNSec
let expTime = fromIntegral us * 1000 + now
editTimeouts mgr (Q.adjust (const expTime) key)
editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts mgr g = do
wake <- atomicModifyIORef' (emTimeouts mgr) f
when wake (wakeManager mgr)
where
f q = (q', wake)
where
q' = g q
wake = case Q.minView q of
Nothing -> True
Just (Q.E _ t0 _, _) ->
case Q.minView q' of
Just (Q.E _ t1 _, _) ->
t0 /= t1
_ -> True