Commit abda03be authored by alexbiehl's avatar alexbiehl 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
This diff is collapsed.
......@@ -219,14 +219,12 @@ registerTimeout mgr us cb = do
let expTime = fromIntegral us * 1000 + now
editTimeouts mgr (Q.insert key expTime cb)
wakeManager mgr
return $ TK key
-- | Unregister an active timeout.
unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
unregisterTimeout mgr (TK key) = do
editTimeouts mgr (Q.delete key)
wakeManager mgr
-- | Update an active timeout to fire in the given number of
-- microseconds.
......@@ -236,8 +234,21 @@ updateTimeout mgr (TK key) us = do
let expTime = fromIntegral us * 1000 + now
editTimeouts mgr (Q.adjust (const expTime) key)
wakeManager mgr
editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts mgr g = atomicModifyIORef' (emTimeouts mgr) $ \tq -> (g tq, ())
editTimeouts mgr g = do
wake <- atomicModifyIORef' (emTimeouts mgr) f
when wake (wakeManager mgr)
where
f q = (q', wake)
where
q' = g q
wake = case Q.minView q of
Nothing -> True
Just (Q.E _ t0 _, _) ->
case Q.minView q' of
Just (Q.E _ t1 _, _) ->
-- don't wake the manager if the
-- minimum element didn't change.
t0 /= t1
_ -> True
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment