GitLab

Erik de Castro Lopo pushed to branch wip/fix-9809 at Glasgow Haskell Compiler / GHC

Commits:

469488b6

by Erik de Castro Lopo at 2026-10-27T08:40:15+11:00

TimerManager: publish only evaluated timeout queues (#9809)

When many threads register timeouts at once, for example 100k forked
threads each calling registerDelay or threadDelay, the timer manager
showed huge GC overhead, memory use and timer latency. With 100k forked
registrations on -N4, master took 0.59 s and 437 MB peak memory, against
0.03 s and 31 MB when the same registrations come from one thread.

The cause goes back to 2d5eccdf1c ("IO manager: Edit the timeout queue
directly, rather than using an edit list", fixing #7653), which made every
registration atomicModifyIORef' the shared timeout queue. That publishes
the new queue as a thunk and only evaluates it afterwards, so each thread
builds its O(log n) insert on top of the previous thread's unevaluated
insert, giving thunk chains, threads blocking on each other's partly
evaluated updates, and many queue copies kept alive at once.

Registering threads now use a compare-and-swap loop that evaluates the new
queue before publishing it (IntPSQ is spine strict, so WHNF is fully
evaluated). The timer manager's own update in mkTimeout keeps using
atomicModifyIORef': with compare-and-swap its long update almost never won
against a stream of short inserts on other capabilities, which starved it
and delayed expired timeouts by hundreds of milliseconds.

Forked registrations of 100k timeouts (median of 5 runs):
  -N4:  0.589 s, 437 MB  ->  0.077 s, 37 MB
  -N12: 1.182 s, 465 MB  ->  0.125 s, 74 MB
Forked registrations of 1M timeouts on -N1:
  5.85 s (range 0.69-6.49 s), 1824 MB  ->  0.69 s, 193 MB
Single-thread registrations are unchanged or slightly faster, and timer
latency during registration storms improves (p99 lateness of a 1 ms
threadDelay during 100k forked registrations on -N4: 342-534 ms -> 4-7 ms).

The registration code still runs in constant stack, so #7653 stays fixed;
T7653 and the concurrent, base and ghc-internal testsuites pass.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>

a4c4af60

by Erik de Castro Lopo at 2026-10-27T08:40:15+11:00

Add a test for the fix for #9809

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>

5 changed files:

+ changelog.d/T9809-timer-manager-contention
libraries/base/tests/.gitignore
+ libraries/base/tests/T9809.hs
libraries/base/tests/all.T
libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs

Changes:

changelog.d/T9809-timer-manager-contention

 +section: ghc-internal
 +synopsis: Fix excessive GC, memory use and timer latency when many threads
 +  register timeouts at once with ``threadDelay``, ``registerDelay`` or
 +  ``System.Timeout.timeout``.
 +issues: #9809
 +mrs: !16863
 +description: {
 +    Threads registering timeouts now publish only fully evaluated updates to
 +    the timer manager's timeout queue, using a compare-and-swap loop, instead
 +    of building chains of unevaluated updates that other threads then had to
 +    evaluate or block on.
 +}

libraries/base/tests/.gitignore

@@ -275,4 +275,5 @@
  /weak001
  /T9395
  /T9532
 +/T9809
  /T11555

libraries/base/tests/T9809.hs

 +-- #9809: when many threads registered timeouts at the same time, the
 +-- TimerManager published unevaluated timeout queues with atomicModifyIORef'.
 +-- The threads then built long chains of thunks and blocked on each other's
 +-- black holes, and the heap grew to hundreds of megabytes. all.T runs this
 +-- test with a heap limit that the old code exceeded.
++
 +import Control.Concurrent
 +import Control.Monad
 +import Data.IORef
 +import GHC.Conc (TVar, atomically, newTVarIO, readTVar, registerDelay, retry, writeTVar)
++
 +main :: IO ()
 +main = do
 +    let n = 100000
 +    ref <- newIORef []
 +    registered <- newTVarIO (0 :: Int)
 +    replicateM_ n . forkIO $ do
 +        tv <- registerDelay 10
 +        atomicModifyIORef' ref (\tvs -> (tv : tvs, ()))
 +        atomically $ readTVar registered >>= writeTVar registered . (+ 1)
 +    atomically $ do
 +        r <- readTVar registered
 +        when (r /= n) retry
 +    readIORef ref >>= mapM_ waitFor
++
 +-- | Block until a delay has fired, so that the test also checks that the
 +-- TimerManager fires every timeout.
 +waitFor :: TVar Bool -> IO ()
 +waitFor tv = atomically $ readTVar tv >>= \fired -> unless fired retry

libraries/base/tests/all.T

@@ -193,6 +193,12 @@ test('T7653', [when(opsys('mingw32'), skip),
                 omit_ways(prof_ways + ghci_ways)], compile_and_run, [''])
  test('T7787', normal, compile_and_run, [''])
 +# Before the fix for #9809 this needed more than 256MB of heap.
 +test('T9809', [req_ghc_smp,
 +               req_target_smp,
 +               only_ways(['threaded1', 'threaded2', 'nonmoving_thr'])],
 +               compile_and_run, ['-threaded -with-rtsopts="-N2 -M128m"'])
++
  test('topHandler01', [when(opsys('mingw32'), skip), js_broken(22261), req_process], compile_and_run, [''])
  test('topHandler02',
       [when(opsys('mingw32'), skip),

libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs

@@ -13,8 +13,10 @@ import GHC.Internal.Types ()
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE FlexibleInstances #-}
 +{-# LANGUAGE MagicHash #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE Trustworthy #-}
 +{-# LANGUAGE UnboxedTuples #-}
  -- TODO: use the new Windows IO manager
  module GHC.Internal.Event.TimerManager
@@ -53,6 +55,9 @@ import GHC.Internal.Control.Exception (finally)
  import GHC.Internal.Data.Foldable (sequence_)
  import GHC.Internal.Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                     writeIORef)
 +import GHC.Internal.IORef (IORef(..))
 +import GHC.Internal.Prim (casMutVar#, readMutVar#)
 +import GHC.Internal.STRef (STRef(..))
  import GHC.Internal.Err (errorWithoutStackTrace)
  import GHC.Internal.Clock (getMonotonicTimeNSec)
  import GHC.Internal.Conc.Signal (runHandlers)
@@ -260,7 +265,7 @@ updateTimeout mgr (TK key) us = do
  editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
  editTimeouts mgr g = do
 -  wake <- atomicModifyIORef' (emTimeouts mgr) f
 +  wake <- modifyTimeouts (emTimeouts mgr) f
    when wake (wakeManager mgr)
    where
      f q = (q', wake)
@@ -276,4 +281,37 @@ editTimeouts mgr g = do
                        t0 /= t1
                      _ -> True
 +-- | Atomically replace the timeout queue with the first component of
 +-- @f old@ and return the second component.
 +--
 +-- Unlike 'atomicModifyIORef'', the new queue is evaluated /before/ it is
 +-- published, using a compare-and-swap loop. 'atomicModifyIORef'' installs
 +-- the new contents as a thunk and only evaluates it afterwards, so when many
 +-- threads register timeouts at once (#9809) each one builds its insert on
 +-- top of the previous thread's unevaluated insert, giving long thunk chains,
 +-- threads blocking on each other's half evaluated updates and lots of extra
 +-- GC work. Since 'Q.IntPSQ' is spine strict, WHNF means fully evaluated, and
 +-- other threads only ever see a fully evaluated queue.
 +--
 +-- The cost is that a thread whose compare-and-swap loses a race has to redo
 +-- its O(log n) update. The update runs in constant stack (see #7653).
 +--
 +-- Only the short edits made by registering threads use this. The timer
 +-- manager's own update in 'mkTimeout' (removing every expired timeout) can
 +-- take much longer, and under a stream of registrations from other
 +-- capabilities its compare-and-swap would almost never succeed, starving it
 +-- so that expired timeouts don't fire. It therefore keeps using
 +-- 'atomicModifyIORef'', which never retries: it publishes a single thunk and
 +-- evaluates it straight away. A registering thread that reads that thunk
 +-- evaluates it (or waits for the manager to) before publishing its own fully
 +-- evaluated queue, so thunks still cannot pile up.
 +modifyTimeouts :: IORef TimeoutQueue -> (TimeoutQueue -> (TimeoutQueue, b)) -> IO b
 +modifyTimeouts (IORef (STRef ref)) f = IO modLoop
 +  where
 +    modLoop s0 = case readMutVar# ref s0 of
 +      (# s1, oldVar #) -> case f oldVar of
 +        (newVar, r) -> newVar `seq` case casMutVar# ref oldVar newVar s1 of
 +          (# s2, 0#, _ #) -> (# s2, r #)
 +          (# s2, _, _ #) -> modLoop s2
++
  #endif