TimerManagerBench.hs

{-# LANGUAGE BangPatterns #-}
module TimerManagerBench where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Strict
import Data.Foldable
import GHC.Event
import System.Random
import Control.Concurrent
import Control.Exception
import Data.IORef

main :: IO ()
main = do

  let seed = 12345 :: Int
      nthreads = 1 :: Int
      benchTime = 20 :: Int -- in seconds

  timerManager <- getSystemTimerManager :: IO TimerManager

  let
    {- worker loop
       depending on the random generator it either
        * registers a new timeout
        * updates existing timeout
        * or cancels an existing timeout

      Additionally it keeps track of a counter tracking how
      often a timermanager was being modified.
    -}
    loop :: IORef Int -> [TimeoutKey] -> StdGen -> IO a
    loop !i !timeouts !rng = do
      let (rand0, rng')   = next rng
          (rand1, rng'')  = next rng'
      case rand0 `mod` 3 of
        -- register a new timeout
        0 -> do
          timeout <- registerTimeout timerManager (1000000 * rand1) (return ())
          modifyIORef' i (+1)
          loop i (timeout:timeouts) rng''
        -- update the first timeout from timeouts
        1 | (timeout:_) <- timeouts
          -> do
            updateTimeout timerManager timeout (1000000 * rand1)
            modifyIORef' i (+1)
            loop i timeouts rng''
          | otherwise
          -> loop i timeouts rng'
        -- delete the first timeout from timeouts
        2
          | (timeout:timeouts') <- timeouts
          -> do
              unregisterTimeout timerManager timeout
              loop i timeouts' rng'
          | otherwise -> loop i timeouts rng'

        _ -> loop i timeouts rng'

  let
    -- run a computation which can produce new
    -- random generators on demand
    withRng m = evalStateT m (mkStdGen seed)

    -- split a new random generator
    newRng = do
      (rng1, rng2) <- split <$> get
      put rng1
      return rng2

  counters <- withRng $ do
    replicateM nthreads $ do
      rng <- newRng
      ref <- liftIO (newIORef 0)
      liftIO $ forkIO (loop ref [] rng)
      return ref

  threadDelay (1000000 * benchTime)
  for_ counters $ \ref -> do
    n <- readIORef ref
    putStrLn (show n)