[commit: ghc] master: base/TimerManager: Clamp timer expiration time to maxBound (21a9fb5)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/21a9fb5ff3714addf28dbe270af5d10640d89ad9/ghc

>---------------------------------------------------------------

commit 21a9fb5ff3714addf28dbe270af5d10640d89ad9
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Wed May 30 20:39:12 2018 -0400

    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


>---------------------------------------------------------------

21a9fb5ff3714addf28dbe270af5d10640d89ad9
 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 a28d361..946f233 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 710b176..3d3ebbc 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,[''])