Commit e449f181 authored by tibbe's avatar tibbe
Browse files

Fixed a rounding error in threadDelay

parent 0d34321e
......@@ -344,14 +344,14 @@ fdWasClosed mgr fd =
------------------------------------------------------------------------
-- Registering interest in timeout events
-- | Register a timeout in the given number of milliseconds.
-- | Register a timeout in the given number of microseconds.
registerTimeout :: EventManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout mgr ms cb = do
registerTimeout mgr us cb = do
!key <- newUnique (emUniqueSource mgr)
if ms <= 0 then cb
if us <= 0 then cb
else do
now <- getCurrentTime
let expTime = fromIntegral ms / 1000.0 + now
let expTime = fromIntegral us / 1000000.0 + now
-- We intentionally do not evaluate the modified map to WHNF here.
-- Instead, we leave a thunk inside the IORef and defer its
......@@ -370,9 +370,9 @@ unregisterTimeout mgr (TK key) = do
wakeManager mgr
updateTimeout :: EventManager -> TimeoutKey -> Int -> IO ()
updateTimeout mgr (TK key) ms = do
updateTimeout mgr (TK key) us = do
now <- getCurrentTime
let expTime = fromIntegral ms / 1000.0 + now
let expTime = fromIntegral us / 1000000.0 + now
atomicModifyIORef (emTimeouts mgr) $ \f ->
let f' = (Q.adjust (const expTime) key) . f in (f', ())
......
......@@ -17,8 +17,6 @@ import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
labelThread, modifyMVar_, newTVar, sharedCAF,
threadStatus, writeTVar)
import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import GHC.Num (fromInteger)
import GHC.Real (div)
import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
new, registerFd, unregisterFd_, registerTimeout)
import System.IO.Unsafe (unsafePerformIO)
......@@ -34,7 +32,7 @@ threadDelay :: Int -> IO ()
threadDelay usecs = do
Just mgr <- readIORef eventManager
m <- newEmptyMVar
_ <- registerTimeout mgr (usecs `div` 1000) (putMVar m ())
_ <- registerTimeout mgr usecs (putMVar m ())
takeMVar m
-- | Set the value of returned TVar to True after a given number of
......@@ -44,7 +42,7 @@ registerDelay :: Int -> IO (TVar Bool)
registerDelay usecs = do
t <- atomically $ newTVar False
Just mgr <- readIORef eventManager
_ <- registerTimeout mgr (usecs `div` 1000) . atomically $ writeTVar t True
_ <- registerTimeout mgr usecs . atomically $ writeTVar t True
return t
-- | Block the current thread until data is available to read from the
......
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