Here's the latest and greatest version put together with Einar's help.
The seconds portion of ClockTime and a counter are used as the key
now and the counter wraps around. This would make two distinct timers
even if there expiration times were the same.
{-# OPTIONS_GHC -fglasgow-exts -fno-cse #-}
module Timer
(
startTimer,
stopTimer
)
where
import qualified Data.Map as M
import Data.IORef
import System.Time
import System.IO.Unsafe
import Control.Exception
import Control.Concurrent
type Timers = M.Map (Integer, Int) (IO ())
timeout :: Int
timeout = 5000000 -- 1 second
{-# NOINLINE timers #-}
{-# NOINLINE counter #-}
timers :: MVar Timers
counter :: IORef Int
(timers, counter) = unsafePerformIO $ do mv <- newMVar M.empty
c <- newIORef 0
forkIO $ checkTimers
return (mv, c)
startTimer :: Integer -> (IO ()) -> IO (Integer, Int)
startTimer seconds io =
do TOD now _ <- getClockTime
let expiration = now + seconds
id <- atomicModifyIORef counter $ \x -> (x + 1, x)
modifyMVar_ timers $ \a ->
return $! M.insert (expiration, id) io a
return (expiration, id)
stopTimer :: (Integer, Int) -> IO ()
stopTimer key = modifyMVar_ timers $ \a ->
return $! M.delete key a
checkTimers :: IO ()
checkTimers =
do t <- readMVar timers -- takes it and puts it back
case M.size t of
-- no timers
0 -> threadDelay timeout
-- some timers
_ -> do let (key@(time, _), io) = M.findMin t
TOD now _ <- getClockTime
if (time <= now)
then do stopTimer key
try $ io -- don't think we care
return ()
else threadDelay timeout
checkTimers
--
http://wagerlabs.com/
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
