Permalink
Browse files

Fix bug where timeout queue edits were being applied in reverse order

  • Loading branch information...
Johan Tibell
Johan Tibell committed Jun 4, 2010
1 parent 532cc1a commit e8b7cdc64012d6a6836d23cca4ad78e71ac521c3
Showing with 14 additions and 20 deletions.
  1. +14 −20 src/System/Event/Manager.hs
@@ -109,9 +109,10 @@ type TimeoutQueue = Q.PSQ TimeoutCallback
{-
Instead of directly modifying the 'TimeoutQueue' in
-e.g. 'registerTimeout' we keep a list of edits to perform and have the
-I/O manager thread perform the edits later. This exist to address the
-following GC problem:
+e.g. 'registerTimeout' we keep a list of edits to perform, in the form
+of a chain of function closures, and have the I/O manager thread
+perform the edits later. This exist to address the following GC
+problem:
Since e.g. 'registerTimeout' doesn't force the evaluation of the
thunks inside the 'emTimeouts' IORef a number of thunks build up
@@ -135,15 +136,11 @@ this bug is resolved: http://hackage.haskell.org/trac/ghc/ticket/3838
-- | An edit to apply to a 'TimeoutQueue'.
type TimeoutEdit = TimeoutQueue -> TimeoutQueue
--- | Apply a list of edits to a 'TimeoutQueue'.
-applyTimeoutEdits :: TimeoutQueue -> [TimeoutEdit] -> TimeoutQueue
-applyTimeoutEdits = foldl' (flip ($))
-
-- | The event manager state.
data EventManager = EventManager
{ emBackend :: !Backend
, emFds :: {-# UNPACK #-} !(MVar (IM.IntMap [FdData]))
- , emTimeouts :: {-# UNPACK #-} !(IORef [TimeoutEdit])
+ , emTimeouts :: {-# UNPACK #-} !(IORef TimeoutEdit)
, emState :: {-# UNPACK #-} !(IORef State)
, emUniqueSource :: {-# UNPACK #-} !UniqueSource
, emControl :: {-# UNPACK #-} !Control
@@ -177,7 +174,7 @@ new = newWith =<< newDefaultBackend
newWith :: Backend -> IO EventManager
newWith be = do
iofds <- newMVar IM.empty
- timeouts <- newIORef []
+ timeouts <- newIORef id
ctrl <- newControl
state <- newIORef Created
us <- newSource
@@ -247,8 +244,8 @@ step mgr@EventManager{..} tq = do
mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue)
mkTimeout q = do
now <- getCurrentTime
- newTimeouts <- atomicModifyIORef emTimeouts $ \q' -> ([], q')
- let (expired, q') = Q.atMost now (applyTimeoutEdits q newTimeouts)
+ applyEdits <- atomicModifyIORef emTimeouts $ \f -> (id, f)
+ let (expired, q') = Q.atMost now $! (applyEdits q)
sequence_ $ map Q.value expired
let timeout = case Q.minView q' of
Nothing -> Forever
@@ -356,27 +353,24 @@ registerTimeout mgr ms cb = do
-- 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) $ \edits ->
- let edits' = (Q.insert key expTime cb) : edits
- in (edits', edits')
+ atomicModifyIORef (emTimeouts mgr) $ \f ->
+ let f' = (Q.insert key expTime cb) . f in (f', ())
wakeManager mgr
return $! TK key
unregisterTimeout :: EventManager -> TimeoutKey -> IO ()
unregisterTimeout mgr (TK key) = do
- !_ <- atomicModifyIORef (emTimeouts mgr) $ \edits ->
- let edits' = (Q.delete key) : edits
- in (edits', edits')
+ atomicModifyIORef (emTimeouts mgr) $ \f ->
+ let f' = (Q.delete key) . f in (f', ())
wakeManager mgr
updateTimeout :: EventManager -> TimeoutKey -> Int -> IO ()
updateTimeout mgr (TK key) ms = do
now <- getCurrentTime
let expTime = fromIntegral ms / 1000.0 + now
- !_ <- atomicModifyIORef (emTimeouts mgr) $ \edits ->
- let edits' = (Q.adjust (const expTime) key) : edits
- in (edits', edits')
+ atomicModifyIORef (emTimeouts mgr) $ \f ->
+ let f' = (Q.adjust (const expTime) key) . f in (f', ())
wakeManager mgr
------------------------------------------------------------------------

0 comments on commit e8b7cdc

Please sign in to comment.