[commit: base] master: IO manager: Edit the timeout queue directly, rather than using an edit list (e843e73)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

https://github.com/ghc/packages-base/commit/e843e73690f828498f6e33bb89f47a50c3ab2ac9

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

commit e843e73690f828498f6e33bb89f47a50c3ab2ac9
Author: Ian Lynagh <ian at well-typed.com>
Date:   Sat Jun 8 20:19:59 2013 +0100

    IO manager: Edit the timeout queue directly, rather than using an edit list
    
    Fixes #7653.

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

 GHC/Event/TimerManager.hs |   61 +++++++++++++++++++++-----------------------
 1 files changed, 29 insertions(+), 32 deletions(-)

diff --git a/GHC/Event/TimerManager.hs b/GHC/Event/TimerManager.hs
index b581891..453f2eb 100644
--- a/GHC/Event/TimerManager.hs
+++ b/GHC/Event/TimerManager.hs
@@ -39,7 +39,7 @@ module GHC.Event.TimerManager
 
 import Control.Exception (finally)
 import Control.Monad ((=<<), liftM, sequence_, when)
-import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef,
+import Data.IORef (IORef, atomicModifyIORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                    writeIORef)
 import Data.Maybe (Maybe(..))
 import Data.Monoid (mempty)
@@ -114,7 +114,7 @@ type TimeoutEdit = TimeoutQueue -> TimeoutQueue
 -- | The event manager state.
 data TimerManager = TimerManager
     { emBackend      :: !Backend
-    , emTimeouts     :: {-# UNPACK #-} !(IORef TimeoutEdit)
+    , emTimeouts     :: {-# UNPACK #-} !(IORef TimeoutQueue)
     , emState        :: {-# UNPACK #-} !(IORef State)
     , emUniqueSource :: {-# UNPACK #-} !UniqueSource
     , emControl      :: {-# UNPACK #-} !Control
@@ -144,7 +144,7 @@ new = newWith =<< newDefaultBackend
 
 newWith :: Backend -> IO TimerManager
 newWith be = do
-  timeouts <- newIORef id
+  timeouts <- newIORef Q.empty
   ctrl <- newControl True
   state <- newIORef Created
   us <- newSource
@@ -192,38 +192,39 @@ loop mgr = do
     Created -> (Running, s)
     _       -> (s, s)
   case state of
-    Created -> go Q.empty `finally` cleanup mgr
+    Created -> go `finally` cleanup mgr
     Dying   -> cleanup mgr
     _       -> do cleanup mgr
                   error $ "GHC.Event.Manager.loop: state is already " ++
                       show state
  where
-  go q = do (running, q') <- step mgr q
-            when running $ go q'
+  go = do running <- step mgr
+          when running go
 
-step :: TimerManager -> TimeoutQueue -> IO (Bool, TimeoutQueue)
-step mgr tq = do
-  (timeout, q') <- mkTimeout tq
+step :: TimerManager -> IO Bool
+step mgr = do
+  timeout <- mkTimeout
   _ <- I.poll (emBackend mgr) (Just timeout) (handleControlEvent mgr)
   state <- readIORef (emState mgr)
-  state `seq` return (state == Running, q')
+  state `seq` return (state == Running)
  where
 
   -- | Call all expired timer callbacks and return the time to the
   -- next timeout.
-  mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue)
-  mkTimeout q = do
+  mkTimeout :: IO Timeout
+  mkTimeout = do
       now <- getMonotonicTime
-      applyEdits <- atomicModifyIORef (emTimeouts mgr) $ \f -> (id, f)
-      let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q'
+      (expired, timeout) <- atomicModifyIORef (emTimeouts mgr) $ \tq ->
+           let (expired, tq') = Q.atMost now tq
+               timeout = case Q.minView tq' of
+                 Nothing             -> Forever
+                 Just (Q.E _ t _, _) ->
+                     -- This value will always be positive since the call
+                     -- to 'atMost' above removed any timeouts <= 'now'
+                     let t' = t - now in t' `seq` Timeout t'
+           in (tq', (expired, timeout))
       sequence_ $ map Q.value expired
-      let timeout = case Q.minView q'' of
-            Nothing             -> Forever
-            Just (Q.E _ t _, _) ->
-                -- This value will always be positive since the call
-                -- to 'atMost' above removed any timeouts <= 'now'
-                let t' = t - now in t' `seq` Timeout t'
-      return (timeout, q'')
+      return timeout
 
 -- | Wake up the event manager.
 wakeManager :: TimerManager -> IO ()
@@ -244,21 +245,14 @@ registerTimeout mgr us cb = do
       now <- getMonotonicTime
       let expTime = fromIntegral us / 1000000.0 + now
 
-      -- We intentionally do not evaluate the modified map to WHNF here.
-      -- Instead, we leave a thunk inside the IORef and defer its
-      -- evaluation until mkTimeout in the event loop.  This is a
-      -- workaround for a nasty IORef contention problem that causes the
-      -- thread-delay benchmark to take 20 seconds instead of 0.2.
-      atomicModifyIORef (emTimeouts mgr) $ \f ->
-          let f' = (Q.insert key expTime cb) . f in (f', ())
+      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
-  atomicModifyIORef (emTimeouts mgr) $ \f ->
-      let f' = (Q.delete key) . f in (f', ())
+  editTimeouts mgr (Q.delete key)
   wakeManager mgr
 
 -- | Update an active timeout to fire in the given number of
@@ -268,6 +262,9 @@ updateTimeout mgr (TK key) us = do
   now <- getMonotonicTime
   let expTime = fromIntegral us / 1000000.0 + now
 
-  atomicModifyIORef (emTimeouts mgr) $ \f ->
-      let f' = (Q.adjust (const expTime) key) . f in (f', ())
+  editTimeouts mgr (Q.adjust (const expTime) key)
   wakeManager mgr
+
+editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
+editTimeouts mgr g = atomicModifyIORef' (emTimeouts mgr) $ \tq -> (g tq, ())
+