Skip to content
Browse files

Worked around a generational GC issue

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:

Since e.g. 'registerTimeout' doesn't force the evaluation of the
thunks inside the 'emTimeouts' IORef a number of thunks build up
inside the IORef.  If the I/O manager thread doesn't evaluate these
thunks soon enough they'll get promoted to the old generation and
become roots for all subsequent minor GCs.

When the thunks eventually get evaluated they will each create a new
intermediate 'TimeoutQueue' that immediately becomes garbage.  Since
the thunks serve as roots until the next major GC these intermediate
'TimeoutQueue's will get copied unnecesarily in the next minor GC,
increasing GC time.  This problem is known as "floating garbage".

Keeping a list of edits doesn't stop this from happening but makes the
amount of data that gets copied smaller.

The run-time of "thread-delay -n 20000" goes down by 34%.  The
measurement was done by taking the median run-time of five runs.
  • Loading branch information...
1 parent 5185583 commit 2adfeaa56b488b6e56f75e327db3f2744046160b @tibbe committed Mar 19, 2010
Showing with 66 additions and 24 deletions.
  1. +66 −24 src/System/Event/Manager.hs
View
90 src/System/Event/Manager.hs
@@ -47,6 +47,7 @@ import Control.Exception (finally)
import Control.Monad (forM_, liftM, when)
import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef,
writeIORef)
+import Data.List (foldl')
import Data.Monoid (mconcat, mempty)
import Prelude hiding (init)
import System.Event.Clock (getCurrentTime)
@@ -99,11 +100,46 @@ data State = Created
| Finished
deriving (Eq, Show)
+-- | A priority search queue, with timeouts as priorities.
+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:
+
+Since e.g. 'registerTimeout' doesn't force the evaluation of the
+thunks inside the 'emTimeouts' IORef a number of thunks build up
+inside the IORef. If the I/O manager thread doesn't evaluate these
+thunks soon enough they'll get promoted to the old generation and
+become roots for all subsequent minor GCs.
+
+When the thunks eventually get evaluated they will each create a new
+intermediate 'TimeoutQueue' that immediately becomes garbage. Since
+the thunks serve as roots until the next major GC these intermediate
+'TimeoutQueue's will get copied unnecesarily in the next minor GC,
+increasing GC time. This problem is known as "floating garbage".
+
+Keeping a list of edits doesn't stop this from happening but makes the
+amount of data that gets copied smaller.
+
+TODO: Evaluate the content of the IORef to WHNF on each insert once
+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 :: {-# UNPACK #-} !Backend
, emFds :: {-# UNPACK #-} !(MVar (IM.IntMap [FdData]))
- , emTimeouts :: {-# UNPACK #-} !(IORef (Q.PSQ TimeoutCallback))
+ , emTimeouts :: {-# UNPACK #-} !(IORef [TimeoutEdit])
, emState :: {-# UNPACK #-} !(IORef State)
, emUniqueSource :: {-# UNPACK #-} !UniqueSource
, emControl :: {-# UNPACK #-} !Control
@@ -138,7 +174,7 @@ new = newWith =<< newDefaultBackend
newWith :: Backend -> IO EventManager
newWith be = do
iofds <- newMVar IM.empty
- timeouts <- newIORef Q.empty
+ timeouts <- newIORef []
ctrl <- newControl
state <- newIORef Created
us <- newSource
@@ -187,9 +223,10 @@ cleanup mgr@EventManager{..} = do
loop :: EventManager -> IO ()
loop mgr@EventManager{..} = do
init mgr
- go `finally` cleanup mgr
+ go Q.empty `finally` cleanup mgr
where
- go = step mgr >>= (`when` go)
+ go q = do (running, q') <- step mgr q
+ when running $ go q'
init :: EventManager -> IO ()
init mgr@EventManager{..} = do
@@ -199,27 +236,29 @@ init mgr@EventManager{..} = do
when (state /= Created) .
error $ "System.Event.Manager.init: state is already " ++ show state
-step :: EventManager -> IO Bool
-step mgr@EventManager{..} = do
- timeout <- mkTimeout
+step :: EventManager -> TimeoutQueue -> IO (Bool, TimeoutQueue)
+step mgr@EventManager{..} q = do
+ (timeout, q') <- mkTimeout q
I.poll emBackend timeout (onFdEvent mgr)
state <- readIORef emState
- return $! state == Running
+ state `seq` return (state == Running, q')
where
+
-- | Call all expired timer callbacks and return the time to the
-- next timeout.
- mkTimeout :: IO Timeout
- mkTimeout = do
+ mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue)
+ mkTimeout q = do
now <- getCurrentTime
- (expired, q') <- atomicModifyIORef emTimeouts $ \q ->
- let res@(_, q') = Q.atMost now q in (q', res)
+ newTimeouts <- atomicModifyIORef emTimeouts $ \q -> ([], q)
+ let (expired, q') = Q.atMost now (applyTimeoutEdits q newTimeouts)
sequence_ $ map Q.value expired
- case Q.minView q' of
- Nothing -> return Forever
- Just (Q.E _ t _, _) ->
- -- This value will always be positive since the call
- -- to 'atMost' above removed any timeouts <= 'now'
- return $! Timeout (t - now)
+ 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'
+ Timeout $! t - now
+ return (timeout, q')
------------------------------------------------------------------------
-- Registering interest in I/O events
@@ -319,24 +358,27 @@ 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) $ \q ->
- let q' = Q.insert key expTime cb q in (q', q')
+ _ <- atomicModifyIORef (emTimeouts mgr) $ \edits ->
+ let edits' = (Q.insert key expTime cb) : edits
+ in (edits', edits')
wakeManager mgr
return $! TK key
unregisterTimeout :: EventManager -> TimeoutKey -> IO ()
unregisterTimeout mgr (TK key) = do
- !_ <- atomicModifyIORef (emTimeouts mgr) $ \q ->
- let q' = Q.delete key q in (q', q')
+ !_ <- atomicModifyIORef (emTimeouts mgr) $ \edits ->
+ let edits' = (Q.delete key) : edits
+ in (edits', edits')
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) $ \q ->
- let q' = Q.adjust (const expTime) key q in (q', q')
+ !_ <- atomicModifyIORef (emTimeouts mgr) $ \edits ->
+ let edits' = (Q.adjust (const expTime) key) : edits
+ in (edits', edits')
wakeManager mgr
------------------------------------------------------------------------

0 comments on commit 2adfeaa

Please sign in to comment.
Something went wrong with that request. Please try again.