base: Track timer PSQ timeouts as Word64 instead of Double

Test Plan: Validate on all the platforms

Reviewers: nh2, hvr, austin

Subscribers: Phyx, nh2, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3417

7 files changed, 33 insertions, 24 deletions

diff --git a/libraries/base/GHC/Event/Clock.hsc b/libraries/base/GHC/Event/Clock.hsc
index 5dbdb674d3..7f98a03cd2 100644
--- a/libraries/base/GHC/Event/Clock.hsc
+++ b/libraries/base/GHC/Event/Clock.hsc
@@ -1,7 +1,10 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module GHC.Event.Clock (getMonotonicTime) where
+module GHC.Event.Clock
+    ( getMonotonicTime
+    , getMonotonicTimeNSec
+    ) where
 
 import GHC.Base
 import GHC.Real
@@ -9,9 +12,10 @@ import Data.Word
 
 -- | Return monotonic time in seconds, since some unspecified starting point
 getMonotonicTime :: IO Double
-getMonotonicTime = do w <- getMonotonicNSec
+getMonotonicTime = do w <- getMonotonicTimeNSec
                       return (fromIntegral w / 1000000000)
 
+-- | Return monotonic time in nanoseconds, since some unspecified starting point
 foreign import ccall unsafe "getMonotonicNSec"
-    getMonotonicNSec :: IO Word64
+    getMonotonicTimeNSec :: IO Word64
 
diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc
index 47e69a68e0..32bfc3913b 100644
--- a/libraries/base/GHC/Event/EPoll.hsc
+++ b/libraries/base/GHC/Event/EPoll.hsc
@@ -48,7 +48,7 @@ import Foreign.Ptr (Ptr)
 import Foreign.Storable (Storable(..))
 import GHC.Base
 import GHC.Num (Num(..))
-import GHC.Real (ceiling, fromIntegral)
+import GHC.Real (fromIntegral, div)
 import GHC.Show (Show)
 import System.Posix.Internals (c_close)
 import System.Posix.Internals (setCloseOnExec)
@@ -223,7 +223,9 @@ toEvent e = remap (epollIn  .|. epollErr .|. epollHup) E.evtRead `mappend`
 
 fromTimeout :: Timeout -> Int
 fromTimeout Forever     = -1
-fromTimeout (Timeout s) = ceiling $ 1000 * s
+fromTimeout (Timeout s) = fromIntegral $ s `divRoundUp` 1000000
+  where
+    divRoundUp num denom = (num + denom - 1) `div` denom
 
 foreign import ccall unsafe "sys/epoll.h epoll_create"
     c_epoll_create :: CInt -> IO CInt
diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs
index f6eb8efac9..9b8230c032 100644
--- a/libraries/base/GHC/Event/Internal.hs
+++ b/libraries/base/GHC/Event/Internal.hs
@@ -33,6 +33,7 @@ import Data.OldList (foldl', filter, intercalate, null)
 import Foreign.C.Error (eINTR, getErrno, throwErrno)
 import System.Posix.Types (Fd)
 import GHC.Base
+import GHC.Word (Word64)
 import GHC.Num (Num(..))
 import GHC.Show (Show(..))
 
@@ -133,8 +134,8 @@ elEvent :: EventLifetime -> Event
 elEvent (EL x) = Event (x .&. 0x7)
 {-# INLINE elEvent #-}
 
--- | A type alias for timeouts, specified in seconds.
-data Timeout = Timeout {-# UNPACK #-} !Double
+-- | A type alias for timeouts, specified in nanoseconds.
+data Timeout = Timeout {-# UNPACK #-} !Word64
              | Forever
                deriving (Show)
 
diff --git a/libraries/base/GHC/Event/KQueue.hsc b/libraries/base/GHC/Event/KQueue.hsc
index f26d199219..a76cc51b52 100644
--- a/libraries/base/GHC/Event/KQueue.hsc
+++ b/libraries/base/GHC/Event/KQueue.hsc
@@ -38,7 +38,7 @@ import Foreign.Storable (Storable(..))
 import GHC.Base
 import GHC.Enum (toEnum)
 import GHC.Num (Num(..))
-import GHC.Real (ceiling, floor, fromIntegral)
+import GHC.Real (quotRem, fromIntegral)
 import GHC.Show (Show(show))
 import GHC.Event.Internal (Timeout(..))
 import System.Posix.Internals (c_close)
@@ -265,13 +265,13 @@ withTimeSpec ts f
 
 fromTimeout :: Timeout -> TimeSpec
 fromTimeout Forever     = TimeSpec (-1) (-1)
-fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
+fromTimeout (Timeout s) = TimeSpec (toEnum sec') (toEnum nanosec')
   where
-    sec :: Int
-    sec     = floor s
+    (sec, nanosec) = s `quotRem` 1000000000
 
-    nanosec :: Int
-    nanosec = ceiling $ (s - fromIntegral sec) * 1000000000
+    nanosec', sec' :: Int
+    sec' = fromIntegral sec
+    nanosec' = fromIntegral nanosec
 
 toEvent :: Filter -> E.Event
 toEvent (Filter f)
diff --git a/libraries/base/GHC/Event/PSQ.hs b/libraries/base/GHC/Event/PSQ.hs
index b03bc9ce76..26ab5313cf 100644
--- a/libraries/base/GHC/Event/PSQ.hs
+++ b/libraries/base/GHC/Event/PSQ.hs
@@ -89,7 +89,7 @@ module GHC.Event.PSQ
     ) where
 
 import GHC.Base hiding (empty)
-import GHC.Float () -- for Show Double instance
+import GHC.Word (Word64)
 import GHC.Num (Num(..))
 import GHC.Show (Show(showsPrec))
 import GHC.Event.Unique (Unique)
@@ -104,7 +104,7 @@ data Elem a = E
 ------------------------------------------------------------------------
 -- | A mapping from keys @k@ to priorites @p@.
 
-type Prio = Double
+type Prio = Word64
 type Key = Unique
 
 data PSQ a = Void
diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc
index 330007c317..5c5ad494ca 100644
--- a/libraries/base/GHC/Event/Poll.hsc
+++ b/libraries/base/GHC/Event/Poll.hsc
@@ -35,7 +35,7 @@ import GHC.Base
 import GHC.Conc.Sync (withMVar)
 import GHC.Enum (maxBound)
 import GHC.Num (Num(..))
-import GHC.Real (ceiling, fromIntegral)
+import GHC.Real (fromIntegral, div)
 import GHC.Show (Show)
 import System.Posix.Types (Fd(..))
 
@@ -143,7 +143,9 @@ poll p mtout f = do
 
 fromTimeout :: E.Timeout -> Int
 fromTimeout E.Forever     = -1
-fromTimeout (E.Timeout s) = ceiling $ 1000 * s
+fromTimeout (E.Timeout s) = fromIntegral $ s `divRoundUp` 1000000
+  where
+    divRoundUp num denom = (num + denom - 1) `div` denom
 
 data PollFd = PollFd {
       pfdFd      :: {-# UNPACK #-} !Fd
diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs
index 93b1766f5e..10baa3b3b2 100644
--- a/libraries/base/GHC/Event/TimerManager.hs
+++ b/libraries/base/GHC/Event/TimerManager.hs
@@ -45,9 +45,9 @@ import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
 import GHC.Base
 import GHC.Conc.Signal (runHandlers)
 import GHC.Num (Num(..))
-import GHC.Real ((/), fromIntegral )
+import GHC.Real (fromIntegral)
 import GHC.Show (Show(..))
-import GHC.Event.Clock (getMonotonicTime)
+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)
@@ -186,7 +186,7 @@ step mgr = do
   -- next timeout.
   mkTimeout :: IO Timeout
   mkTimeout = do
-      now <- getMonotonicTime
+      now <- getMonotonicTimeNSec
       (expired, timeout) <- atomicModifyIORef' (emTimeouts mgr) $ \tq ->
            let (expired, tq') = Q.atMost now tq
                timeout = case Q.minView tq' of
@@ -215,8 +215,8 @@ registerTimeout mgr us cb = do
   !key <- newUnique (emUniqueSource mgr)
   if us <= 0 then cb
     else do
-      now <- getMonotonicTime
-      let expTime = fromIntegral us / 1000000.0 + now
+      now <- getMonotonicTimeNSec
+      let expTime = fromIntegral us * 1000 + now
 
       editTimeouts mgr (Q.insert key expTime cb)
       wakeManager mgr
@@ -232,8 +232,8 @@ unregisterTimeout mgr (TK key) = do
 -- microseconds.
 updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
 updateTimeout mgr (TK key) us = do
-  now <- getMonotonicTime
-  let expTime = fromIntegral us / 1000000.0 + now
+  now <- getMonotonicTimeNSec
+  let expTime = fromIntegral us * 1000 + now
 
   editTimeouts mgr (Q.adjust (const expTime) key)
   wakeManager mgr