diff --git a/Control/Event.hs b/Control/Event.hs --- a/Control/Event.hs +++ b/Control/Event.hs @@ -1,18 +1,7 @@ -- |This module can execute events at specified time. It uses a two thread -- system that allows the STM adding and deleting of new threads without --- requiring later IO actions. --- --- This differs from control-timeout in that control-event is: --- * More complex --- * Requires initilization --- * Allows pure STM adding and removing of events (no post STM IO action) --- * Allows user control over event systems (can have more than one) --- * Allows events to run in event handler thread --- (advisable if thread spark is too expensive / computation is cheap) --- * No possible duplication of EventId (theoretical! no real advantage) --- --- A shim has been made providing control-timeout API with --- Control.Event running under the hood (called Control.Event.Timeout). +-- requiring later IO actions. For a simpler system that uses relative times +-- see Control.Event.Relative module Control.Event ( EventId ,EventSystem @@ -25,15 +14,15 @@ ,evtSystemSize ) where -import Prelude hiding (lookup) +import Prelude hiding (lookup, catch) import Control.Concurrent (forkIO, myThreadId, ThreadId, threadDelay) import Control.Concurrent.STM -import Control.Exception (throwDynTo, catchDyn, block, unblock) +import Control.Exception import Control.Monad (forever, when) import Data.Dynamic import Data.List (partition, deleteBy) import Data.Map (Map, empty, findMin, deleteFindMin, insertLookupWithKey, adjust, size, singleton, toList, insert, updateLookupWithKey, delete, lookup, fold) -import System.Time (TimeDiff(..), ClockTime(..), diffClockTimes, getClockTime) +import Data.Time type EventNumber = Int type EventSet = (EventNumber, Map EventNumber (IO ())) @@ -41,23 +30,23 @@ singletonSet a = (1, singleton 0 a) -- |IDs useful for canceling previously scheduled events. -data EventId = EvtId ClockTime EventNumber deriving (Eq, Ord, Show) +data EventId = EvtId UTCTime EventNumber deriving (Eq, Ord, Show) -- |A value indicating there is no such event. -- Canceling this event returns True and has no other effect. noEvent :: EventId noEvent = EvtId never (-1) -never :: ClockTime -never = TOD (-1) (-1) +never :: UTCTime +never = UTCTime (toEnum (-1)) (-1) -- |The event system must be initilized using initEventSystem. -- More than one event system can be instantiated at once -- (eg. for non-interference). data EventSystem = EvtSys { - esEvents :: TVar (Map ClockTime EventSet), -- Pending Events + esEvents :: TVar (Map UTCTime EventSet), -- Pending Events esThread :: TVar (Maybe ThreadId), -- Id of thread for TimerReset exceptions - esAlarm :: TVar ClockTime, -- Time of soonest event + esAlarm :: TVar UTCTime, -- Time of soonest event esNewAlarm :: TVar Bool, -- An event w/ earlier expiration was added esExpired :: TVar [[EventSet]] } @@ -88,7 +77,7 @@ expireEvents es = do block (do tid <- myThreadId - forever $ catchDyn (unblock (setTID (Just tid) es >> expireEvents' es)) + forever $ catch (unblock (setTID (Just tid) es >> expireEvents' es)) (\TimerReset -> return ()) ) where setTID i es = atomically (writeTVar (esThread es) i) @@ -107,17 +96,17 @@ case findMinM evts of Nothing -> retry Just (c,_) -> return c ) - now <- getClockTime - return $ timeDiffToMicroSec $ diffClockTimes alm now + now <- getCurrentTime + return $ timeDiffToMicroSec $ diffUTCTime alm now - findMinM :: Map ClockTime EventSet -> Maybe (ClockTime,EventSet) + findMinM :: Map UTCTime EventSet -> Maybe (UTCTime,EventSet) findMinM m | size m == 0 = Nothing | otherwise = Just $ findMin m -- |Determines which events are expired, running all their actions runExpire :: EventSystem -> IO () runExpire evtSys = do - now <- getClockTime + now <- getCurrentTime atomically (do evts <- readTVar (esEvents evtSys) let (exp, newMap) = getEarlierKeys now evts newAlarm = getAlarm newMap @@ -126,7 +115,7 @@ exps <- readTVar (esExpired evtSys) writeTVar (esExpired evtSys) (exp:exps) ) where - getEarlierKeys :: ClockTime -> Map ClockTime EventSet -> ([EventSet], Map ClockTime EventSet) + getEarlierKeys :: UTCTime -> Map UTCTime EventSet -> ([EventSet], Map UTCTime EventSet) getEarlierKeys clk m = case deleteFindMinM m of Just ((k,es), m') -> @@ -159,11 +148,11 @@ mapM_ forkIO actions -- |Add an *action* to be performed at *time* by *system*. Returns a unique ID. -addEvent :: EventSystem -> ClockTime -> IO () -> IO EventId +addEvent :: EventSystem -> UTCTime -> IO () -> IO EventId addEvent sys clk act = atomically (addEventSTM sys clk act) -- |Atomic version of addEvent -addEventSTM :: EventSystem -> ClockTime -> IO () -> STM EventId +addEventSTM :: EventSystem -> UTCTime -> IO () -> STM EventId addEventSTM sys clk act = do evts <- readTVar (esEvents sys) let (old, newMap) = insertLookupWithKey (\_ _ o -> insertEvent o) clk (singletonSet act) evts @@ -190,9 +179,9 @@ cancelEventSTM :: EventSystem -> EventId -> STM Bool cancelEventSTM sys eid@(EvtId clk num) = do evts <- readTVar (esEvents sys) - let newMap :: Map ClockTime EventSet + let newMap :: Map UTCTime EventSet prev :: Maybe EventSet - (prev,newMap) = updateLookupWithKey (\_ (num, old) -> Just (num,delete num old)) clk evts + (prev,newMap) = updateLookupWithKey (\_ (cnt, old) -> Just (cnt,delete num old)) clk evts ret = case prev of Nothing -> False -- error "Canceling an event that never existed." Just (_,p) -> case lookup clk newMap of @@ -220,16 +209,12 @@ Just i -> return i Nothing -> retry return i ) - throwDynTo tid TimerReset + throwTo tid TimerReset -- |Returns the time difference in microseconds (potentially returning maxBound <= the real difference) -timeDiffToMicroSec :: TimeDiff -> Int -timeDiffToMicroSec (TimeDiff _ _ _ _ _ sec picosec) = - if realTime > fromIntegral (maxBound :: Int) - then maxBound - else fromIntegral realTime - where - realTime :: Integer - realTime = (fromIntegral sec) * (10^6) + fromIntegral (picosec `div` (10^6)) +timeDiffToMicroSec :: NominalDiffTime -> Int +timeDiffToMicroSec = floor . (* 10^6) data TimerReset = TimerReset deriving (Eq, Ord, Show, Typeable) + +instance Exception TimerReset diff --git a/Control/Event/Relative.hs b/Control/Event/Relative.hs new file mode 100644 --- /dev/null +++ b/Control/Event/Relative.hs @@ -0,0 +1,40 @@ +-- |This module uses Haskell concurrency libraries to build an extremely simple +-- event system that should perform better than the Control.Event module +-- but does not provide features such as STM action scheduling. +module Control.Event.Relative + ( EventId + , addEvent + , delEvent + ) where + +import Prelude hiding (catch) +import Control.Concurrent +import Control.Exception +import Control.Concurrent.MVar + +type EventId = (ThreadId, MVar ()) + +-- |'addEvent delay action' will delay +-- for 'delay' miliseconds then execute 'action'. An EventId +-- is returned, allowing the event to be canceled. +addEvent :: Int -> IO () -> IO EventId +addEvent delay event = do + m <- newEmptyMVar + t <- forkIO (eventThread m) + return (t,m) + where + eventThread m = do + threadDelay delay + forkIO event + putMVar m () + +-- |'delEvent eid' deletes the event and returns +-- 'True' if the event was _probably_ deleted*. If 'False' is returned +-- then the time definately elapsed and the action was forked off. +-- +-- * There is a small possibility the delEvent occured after the forkIO +-- but before the signalling MVar was filled, thus causing this uncertainty. +delEvent :: EventId -> IO Bool +delEvent (t,m) = + killThread t >> + isEmptyMVar m diff --git a/Control/Event/Timeout.hs b/Control/Event/Timeout.hs --- a/Control/Event/Timeout.hs +++ b/Control/Event/Timeout.hs @@ -1,5 +1,7 @@ -- |This module is a shim, providing the control-timeout api using --- control-event to run the show +-- control-event to run the show. See the control-timeout package +-- for documentation. If you do not need compatability with +-- the control-timeout api then do not use this module! module Control.Event.Timeout ( addTimeout @@ -10,31 +12,28 @@ import System.IO.Unsafe import Control.Concurrent.STM import Control.Event -import System.Time +import Data.Time {-# NOINLINE evtSys #-} evtSys = unsafePerformIO initEventSystem newtype TimeoutTag = TTag EventId -addTimeout :: Float -> (IO ()) -> IO TimeoutTag +addTimeout :: Float -> IO () -> IO TimeoutTag addTimeout delay act = do clk <- getExpireTime delay i <- addEvent evtSys clk act return $ TTag i -addTimeoutAtomic :: Float -> IO () -> IO (STM TimeoutTag) -addTimeoutAtomic delay act = do +addTimeoutAtomic :: Float -> IO (IO () -> IO (STM TimeoutTag)) +addTimeoutAtomic delay = return $ \act -> do clk <- getExpireTime delay return $ addEventSTM evtSys clk act >>= return . TTag cancelTimeout :: TimeoutTag -> STM Bool cancelTimeout (TTag eid) = cancelEventSTM evtSys eid -getExpireTime :: Float -> IO ClockTime +getExpireTime :: Float -> IO UTCTime getExpireTime delay = do - (TOD sec ps) <- getClockTime - let dSec = truncate delay - dPS = truncate $ (delay - fromIntegral dSec) * 10^12 - clk = TOD (sec + dSec) (ps + dPS) - return clk + now <- getCurrentTime + return (addUTCTime (fromRational $ toRational delay) now) diff --git a/Test/Event.hs b/Test/Event.hs --- a/Test/Event.hs +++ b/Test/Event.hs @@ -2,23 +2,20 @@ import Control.Concurrent import Control.Concurrent.STM - -import Data.Time.Clock.POSIX -import System.Time import Control.Event -import GHC.Conc (unsafeIOToSTM) - import Text.Printf (printf) +import Data.Time +import Data.Time.Clock.POSIX -singleTimeout :: Float -> IO () +singleTimeout :: NominalDiffTime -> IO () singleTimeout secs = do sys <- initEventSystem a <- atomically $ newTVar 0 startTime <- getPOSIXTime - now@(TOD sec picosec) <- getClockTime + now <- getCurrentTime let newSec = truncate secs newPS = truncate $ 10^12 * (secs - (fromIntegral newSec)) - addEvent sys (TOD (sec + newSec) (picosec + newPS)) (getPOSIXTime >>= atomically . writeTVar a) + addEvent sys (addUTCTime secs now) (getPOSIXTime >>= atomically . writeTVar a) endTime <- atomically (do t <- readTVar a if t == 0 @@ -26,13 +23,13 @@ else return t) printf "%dms sleep took: %s\n" ((truncate $ secs * 1000) :: Int) (show (endTime - startTime)) -multiTimeout :: Int -> Float -> IO () +multiTimeout :: Int -> NominalDiffTime -> IO () multiTimeout n secs = do sys <- initEventSystem a <- atomically $ newTVar n - now@(TOD sec picosec) <- getClockTime + now <- getCurrentTime startTime <- getPOSIXTime - mapM_ (const $ addEvent sys (TOD (sec + truncate secs) picosec) (decAndPrint a)) [1..n] + mapM_ (const $ addEvent sys (addUTCTime secs now) (decAndPrint a)) [1..n] atomically (do n' <- readTVar a if n' == 0 @@ -47,13 +44,13 @@ n <- readTVar a writeTVar a (n - 1) ) -setAndCancelTimeout :: Int -> Float -> IO () +setAndCancelTimeout :: Int -> NominalDiffTime -> IO () setAndCancelTimeout n secs = do sys <- initEventSystem a <- atomically $ newTVar (0 :: Int) - now@(TOD sec picosec) <- getClockTime + now <- getCurrentTime startTime <- getPOSIXTime - tags <- mapM (const $ addEvent sys (TOD (sec + truncate secs) picosec) (atomically $ readTVar a >>= writeTVar a . ((+) 1))) [1..n] + tags <- mapM (const $ addEvent sys (addUTCTime secs now) (atomically $ readTVar a >>= writeTVar a . ((+) 1))) [1..n] mapM (cancelEvent sys) tags endTime <- getPOSIXTime expired <- atomically $ readTVar a @@ -62,7 +59,6 @@ main = do sequence [singleTimeout 0, singleTimeout 0.1, singleTimeout 0.5, singleTimeout 1.0] - sequence [multiTimeout 10 0.1, multiTimeout 100 0.1, multiTimeout 1000 0.1, multiTimeout 10000 0.1, multiTimeout 100000 0.1] - sequence [multiTimeout 1000 0.1, multiTimeout 10000 0.1, multiTimeout 100000 0.1] + sequence [multiTimeout 10 0.1, multiTimeout 100 0.1, multiTimeout 1000 0.1, multiTimeout 10000 0.1] sequence [setAndCancelTimeout 10 0.1, setAndCancelTimeout 100 0.1, setAndCancelTimeout 1000 0.1, setAndCancelTimeout 10000 0.1, setAndCancelTimeout 100000 0.1] return () diff --git a/control-event.cabal b/control-event.cabal --- a/control-event.cabal +++ b/control-event.cabal @@ -1,5 +1,5 @@ name: control-event -version: 0.3.1 +version: 1.0.0.0 synopsis: Event scheduling system. description: Allows scheduling and canceling of IO actions to be executed at a specified future time. @@ -9,9 +9,15 @@ author: Thomas DuBuisson maintainer: Thomas.DuBuisson@gmail.com build-type: Simple -build-Depends: base, old-time, containers >= 0.1, stm -extensions: DeriveDataTypeable -exposed-modules: Control.Event, Control.Event.Timeout -stability: alpha -tested-with: GHC == 6.8.2 +Cabal-Version: >= 1.2.3 +stability: beta +tested-with: GHC == 6.10.3 extra-source-files: Test/Event.hs Test/Timeout.hs + +Library + build-Depends: base >= 4.0 && < 5, + time >= 1.1 && < 1.2, + containers >= 0.1 && < 0.3, + stm >= 2.1 && < 2.2 + extensions: DeriveDataTypeable + exposed-modules: Control.Event, Control.Event.Timeout, Control.Event.Relative