module GHC.Event.TimerManager
(
TimerManager
, new
, newWith
, newDefaultBackend
, finished
, loop
, step
, shutdown
, cleanup
, wakeManager
, TimeoutCallback
, TimeoutKey
, registerTimeout
, updateTimeout
, unregisterTimeout
) where
#include "EventConfig.h"
import Control.Exception (finally)
import Control.Monad ((=<<), liftM, sequence_, when)
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
writeIORef)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import GHC.Base
import GHC.Conc.Signal (runHandlers)
import GHC.Num (Num(..))
import GHC.Real ((/), fromIntegral )
import GHC.Show (Show(..))
import GHC.Event.Clock (getMonotonicTime)
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 :: !(IORef TimeoutQueue)
, emState :: !(IORef State)
, emUniqueSource :: !UniqueSource
, emControl :: !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 = error "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
error $ "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 <- getMonotonicTime
(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 <- getMonotonicTime
let expTime = fromIntegral us / 1000000.0 + now
editTimeouts mgr (Q.insert key expTime cb)
wakeManager mgr
return $ TK key
unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
unregisterTimeout mgr (TK key) = do
editTimeouts mgr (Q.delete key)
wakeManager mgr
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout mgr (TK key) us = do
now <- getMonotonicTime
let expTime = fromIntegral us / 1000000.0 + now
editTimeouts mgr (Q.adjust (const expTime) key)
wakeManager mgr
editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts mgr g = atomicModifyIORef' (emTimeouts mgr) $ \tq -> (g tq, ())