<p dir="ltr">Is this related to some bug? The edit list was there for a reason. :)</p>
<div class="gmail_quote">On Jun 8, 2013 1:19 PM, "Ian Lynagh" <<a href="mailto:igloo@earth.li">igloo@earth.li</a>> wrote:<br type="attribution"><blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">
Repository : ssh://<a href="http://darcs.haskell.org//srv/darcs/packages/base" target="_blank">darcs.haskell.org//srv/darcs/packages/base</a><br>
<br>
On branch : master<br>
<br>
<a href="https://github.com/ghc/packages-base/commit/e843e73690f828498f6e33bb89f47a50c3ab2ac9" target="_blank">https://github.com/ghc/packages-base/commit/e843e73690f828498f6e33bb89f47a50c3ab2ac9</a><br>
<br>
>---------------------------------------------------------------<br>
<br>
commit e843e73690f828498f6e33bb89f47a50c3ab2ac9<br>
Author: Ian Lynagh <<a href="mailto:ian@well-typed.com">ian@well-typed.com</a>><br>
Date: Sat Jun 8 20:19:59 2013 +0100<br>
<br>
IO manager: Edit the timeout queue directly, rather than using an edit list<br>
<br>
Fixes #7653.<br>
<br>
>---------------------------------------------------------------<br>
<br>
GHC/Event/TimerManager.hs | 61 +++++++++++++++++++++-----------------------<br>
1 files changed, 29 insertions(+), 32 deletions(-)<br>
<br>
diff --git a/GHC/Event/TimerManager.hs b/GHC/Event/TimerManager.hs<br>
index b581891..453f2eb 100644<br>
--- a/GHC/Event/TimerManager.hs<br>
+++ b/GHC/Event/TimerManager.hs<br>
@@ -39,7 +39,7 @@ module GHC.Event.TimerManager<br>
<br>
import Control.Exception (finally)<br>
import Control.Monad ((=<<), liftM, sequence_, when)<br>
-import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef,<br>
+import Data.IORef (IORef, atomicModifyIORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,<br>
writeIORef)<br>
import Data.Maybe (Maybe(..))<br>
import Data.Monoid (mempty)<br>
@@ -114,7 +114,7 @@ type TimeoutEdit = TimeoutQueue -> TimeoutQueue<br>
-- | The event manager state.<br>
data TimerManager = TimerManager<br>
{ emBackend :: !Backend<br>
- , emTimeouts :: {-# UNPACK #-} !(IORef TimeoutEdit)<br>
+ , emTimeouts :: {-# UNPACK #-} !(IORef TimeoutQueue)<br>
, emState :: {-# UNPACK #-} !(IORef State)<br>
, emUniqueSource :: {-# UNPACK #-} !UniqueSource<br>
, emControl :: {-# UNPACK #-} !Control<br>
@@ -144,7 +144,7 @@ new = newWith =<< newDefaultBackend<br>
<br>
newWith :: Backend -> IO TimerManager<br>
newWith be = do<br>
- timeouts <- newIORef id<br>
+ timeouts <- newIORef Q.empty<br>
ctrl <- newControl True<br>
state <- newIORef Created<br>
us <- newSource<br>
@@ -192,38 +192,39 @@ loop mgr = do<br>
Created -> (Running, s)<br>
_ -> (s, s)<br>
case state of<br>
- Created -> go Q.empty `finally` cleanup mgr<br>
+ Created -> go `finally` cleanup mgr<br>
Dying -> cleanup mgr<br>
_ -> do cleanup mgr<br>
error $ "GHC.Event.Manager.loop: state is already " ++<br>
show state<br>
where<br>
- go q = do (running, q') <- step mgr q<br>
- when running $ go q'<br>
+ go = do running <- step mgr<br>
+ when running go<br>
<br>
-step :: TimerManager -> TimeoutQueue -> IO (Bool, TimeoutQueue)<br>
-step mgr tq = do<br>
- (timeout, q') <- mkTimeout tq<br>
+step :: TimerManager -> IO Bool<br>
+step mgr = do<br>
+ timeout <- mkTimeout<br>
_ <- I.poll (emBackend mgr) (Just timeout) (handleControlEvent mgr)<br>
state <- readIORef (emState mgr)<br>
- state `seq` return (state == Running, q')<br>
+ state `seq` return (state == Running)<br>
where<br>
<br>
-- | Call all expired timer callbacks and return the time to the<br>
-- next timeout.<br>
- mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue)<br>
- mkTimeout q = do<br>
+ mkTimeout :: IO Timeout<br>
+ mkTimeout = do<br>
now <- getMonotonicTime<br>
- applyEdits <- atomicModifyIORef (emTimeouts mgr) $ \f -> (id, f)<br>
- let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q'<br>
+ (expired, timeout) <- atomicModifyIORef (emTimeouts mgr) $ \tq -><br>
+ let (expired, tq') = Q.atMost now tq<br>
+ timeout = case Q.minView tq' of<br>
+ Nothing -> Forever<br>
+ Just (Q.E _ t _, _) -><br>
+ -- This value will always be positive since the call<br>
+ -- to 'atMost' above removed any timeouts <= 'now'<br>
+ let t' = t - now in t' `seq` Timeout t'<br>
+ in (tq', (expired, timeout))<br>
sequence_ $ map Q.value expired<br>
- let timeout = case Q.minView q'' of<br>
- Nothing -> Forever<br>
- Just (Q.E _ t _, _) -><br>
- -- This value will always be positive since the call<br>
- -- to 'atMost' above removed any timeouts <= 'now'<br>
- let t' = t - now in t' `seq` Timeout t'<br>
- return (timeout, q'')<br>
+ return timeout<br>
<br>
-- | Wake up the event manager.<br>
wakeManager :: TimerManager -> IO ()<br>
@@ -244,21 +245,14 @@ registerTimeout mgr us cb = do<br>
now <- getMonotonicTime<br>
let expTime = fromIntegral us / 1000000.0 + now<br>
<br>
- -- We intentionally do not evaluate the modified map to WHNF here.<br>
- -- Instead, we leave a thunk inside the IORef and defer its<br>
- -- evaluation until mkTimeout in the event loop. This is a<br>
- -- workaround for a nasty IORef contention problem that causes the<br>
- -- thread-delay benchmark to take 20 seconds instead of 0.2.<br>
- atomicModifyIORef (emTimeouts mgr) $ \f -><br>
- let f' = (Q.insert key expTime cb) . f in (f', ())<br>
+ editTimeouts mgr (Q.insert key expTime cb)<br>
wakeManager mgr<br>
return $ TK key<br>
<br>
-- | Unregister an active timeout.<br>
unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()<br>
unregisterTimeout mgr (TK key) = do<br>
- atomicModifyIORef (emTimeouts mgr) $ \f -><br>
- let f' = (Q.delete key) . f in (f', ())<br>
+ editTimeouts mgr (Q.delete key)<br>
wakeManager mgr<br>
<br>
-- | Update an active timeout to fire in the given number of<br>
@@ -268,6 +262,9 @@ updateTimeout mgr (TK key) us = do<br>
now <- getMonotonicTime<br>
let expTime = fromIntegral us / 1000000.0 + now<br>
<br>
- atomicModifyIORef (emTimeouts mgr) $ \f -><br>
- let f' = (Q.adjust (const expTime) key) . f in (f', ())<br>
+ editTimeouts mgr (Q.adjust (const expTime) key)<br>
wakeManager mgr<br>
+<br>
+editTimeouts :: TimerManager -> TimeoutEdit -> IO ()<br>
+editTimeouts mgr g = atomicModifyIORef' (emTimeouts mgr) $ \tq -> (g tq, ())<br>
+<br>
<br>
<br>
<br>
_______________________________________________<br>
ghc-commits mailing list<br>
<a href="mailto:ghc-commits@haskell.org">ghc-commits@haskell.org</a><br>
<a href="http://www.haskell.org/mailman/listinfo/ghc-commits" target="_blank">http://www.haskell.org/mailman/listinfo/ghc-commits</a><br>
</blockquote></div>