Skip to content
Snippets Groups Projects
Commit abda03be authored by Alex Biehl's avatar Alex Biehl Committed by Ben Gamari
Browse files

Optimize TimerManager

After discussion with Kazu Yamamoto we decided to try two things:
  - replace current finger tree based priority queue through a radix
    tree based one (code is based on IntPSQ from the psqueues package)
  - after editing the timer queue: don't wake up the timer manager if
    the next scheduled time didn't change

Benchmark results (number of TimerManager-Operations measured over 20
seconds, 5 runs each, higher is better)

```
-- baseline (timermanager action commented out)
28817088
28754681
27230541
27267441
28828815

-- ghc-8.3 with wake opt and new timer queue
18085502
17892831
18005256
18791301
17912456

-- ghc-8.3 with old timer queue
6982155
7003572
6834625
6979634
6664339
```

Here is the benchmark code:
```
{-# LANGUAGE BangPatterns #-}
module Main 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
        0 -> do
          timeout <- registerTimeout timerManager (rand1) (return ())
          modifyIORef' i (+1)
          loop i (timeout:timeouts) rng''
        1 | (timeout:_) <- timeouts
          -> do
            updateTimeout timerManager timeout (rand1)
            modifyIORef' i (+1)
            loop i timeouts rng''
          | otherwise
          -> loop i timeouts rng'
        2
          | (timeout:timeouts') <- timeouts
          -> do
              unregisterTimeout timerManager timeout
              modifyIORef' i (+1)
              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)

```

Reviewers: austin, hvr, bgamari

Reviewed By: bgamari

Subscribers: Phyx, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3707
parent 81de42cb
No related branches found
No related tags found
Loading
Loading
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment