[commit: ghc] master: Optimize TimerManager (abda03b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/abda03be6794ffd9bbc2c4f77d7f9d534a202b21/ghc

>---------------------------------------------------------------

commit abda03be6794ffd9bbc2c4f77d7f9d534a202b21
Author: alexbiehl <alex.biehl at gmail.com>
Date:   Tue Jul 11 13:57:51 2017 -0400

    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


>---------------------------------------------------------------

abda03be6794ffd9bbc2c4f77d7f9d534a202b21
 libraries/base/GHC/Event/PSQ.hs          | 808 +++++++++++++++----------------
 libraries/base/GHC/Event/TimerManager.hs |  21 +-
 2 files changed, 404 insertions(+), 425 deletions(-)

Diff suppressed because of size. To see it, use:

    git diff-tree --root --patch-with-stat --no-color --find-copies-harder --ignore-space-at-eol --cc abda03be6794ffd9bbc2c4f77d7f9d534a202b21