diff options
Diffstat (limited to 'libraries/base/GHC/Event/TimerManager.hs')
| -rw-r--r-- | libraries/base/GHC/Event/TimerManager.hs | 34 |
1 files changed, 24 insertions, 10 deletions
diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index f3dbb21686..946f2333bf 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -43,11 +43,12 @@ import Data.Foldable (sequence_) import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, writeIORef) 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.Clock (getMonotonicTimeNSec) import GHC.Event.Control import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..)) import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique) @@ -67,7 +68,7 @@ import qualified GHC.Event.Poll as Poll -- | A timeout registration cookie. newtype TimeoutKey = TK Unique - deriving (Eq) + deriving Eq -- ^ @since 4.7.0.0 -- | Callback invoked on timeout events. type TimeoutCallback = IO () @@ -76,7 +77,9 @@ data State = Created | Running | Dying | Finished - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + ) -- | A priority search queue, with timeouts as priorities. type TimeoutQueue = Q.PSQ TimeoutCallback @@ -206,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 @@ -215,10 +230,11 @@ 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 - editTimeouts mgr (Q.insert key expTime cb) + -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It + -- doesn't because we just generated it from a unique supply. + editTimeouts mgr (Q.unsafeInsertNew key expTime cb) return $ TK key -- | Unregister an active timeout. @@ -230,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 () |