From 21a9fb5ff3714addf28dbe270af5d10640d89ad9 Mon Sep 17 00:00:00 2001
From: Ben Gamari <bgamari.foss@gmail.com>
Date: Wed, 30 May 2018 20:39:12 -0400
Subject: [PATCH] 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
---
libraries/base/GHC/Event/TimerManager.hs | 22 ++++++++++++++++------
libraries/base/tests/all.T | 3 +--
2 files changed, 17 insertions(+), 8 deletions(-)
diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs
index a28d361ba1..946f2333bf 100644
--- a/libraries/base/GHC/Event/TimerManager.hs
+++ b/libraries/base/GHC/Event/TimerManager.hs
@@ -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 ()
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 710b1768de..3d3ebbcd0d 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -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,[''])
--
GitLab