Commit 21a9fb5f authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

base/TimerManager: Clamp timer expiration time to maxBound

Previously we would allow the expiration time to overflow, which in
practice meant that `threadDelay maxBound` we return far earlier than
circa 2500 CE. For now we fix this by simply clamping to maxBound.

Fixes #15158.

Test Plan: Validate, run T8089

Reviewers: simonmar, hvr

Reviewed By: simonmar

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15158

Differential Revision: https://phabricator.haskell.org/D4719
parent d1beebb8
......@@ -45,8 +45,9 @@ import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
import GHC.Base
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Conc.Signal (runHandlers)
import GHC.Enum (maxBound)
import GHC.Num (Num(..))
import GHC.Real (fromIntegral)
import GHC.Real (quot, fromIntegral)
import GHC.Show (Show(..))
import GHC.Event.Control
import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
......@@ -208,6 +209,18 @@ wakeManager mgr = sendWakeup (emControl mgr)
------------------------------------------------------------------------
-- Registering interest in timeout events
expirationTime :: Int -> IO Q.Prio
expirationTime us = do
now <- getMonotonicTimeNSec
let expTime
-- Currently we treat overflows by clamping to maxBound. If humanity
-- still exists in 2500 CE we will ned to be a bit more careful here.
-- See #15158.
| (maxBound - now) `quot` 1000 < fromIntegral us = maxBound
| otherwise = now + ns
where ns = 1000 * fromIntegral us
return expTime
-- | Register a timeout in the given number of microseconds. The
-- returned 'TimeoutKey' can be used to later unregister or update the
-- timeout. The timeout is automatically unregistered after the given
......@@ -217,8 +230,7 @@ registerTimeout mgr us cb = do
!key <- newUnique (emUniqueSource mgr)
if us <= 0 then cb
else do
now <- getMonotonicTimeNSec
let expTime = fromIntegral us * 1000 + now
expTime <- expirationTime us
-- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It
-- doesn't because we just generated it from a unique supply.
......@@ -234,9 +246,7 @@ unregisterTimeout mgr (TK key) = do
-- microseconds.
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout mgr (TK key) us = do
now <- getMonotonicTimeNSec
let expTime = fromIntegral us * 1000 + now
expTime <- expirationTime us
editTimeouts mgr (Q.adjust (const expTime) key)
editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
......
......@@ -203,8 +203,7 @@ test('T9681', normal, compile_fail, [''])
# make an educated guess how long it needs to be guaranteed to reach the C
# call."
test('T8089',
[exit_code(99), run_timeout_multiplier(0.01),
expect_broken_for(15158, ['ghci', 'threaded1', 'threaded2', 'profthreaded'])],
[exit_code(99), run_timeout_multiplier(0.01)],
compile_and_run, [''])
test('T8684', expect_broken(8684), compile_and_run, [''])
test('T9826',normal, compile_and_run,[''])
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment