* made the wrapround of the underlying O/S occur before the wrapround
of the delayed threads by making threads delay in microseconds since
O/S epoch (1970 - Unix, 1601 - Windows) stored in Word64.
* removed redundant calls reading O/S realtime clock
* removed rounding to 1/50th of sec for timers
* Only for Unix version of scheduler.
-- | Suspends the current thread for a given number of microseconds
-- (GHC only).
--
-- | Suspends the current thread for a given number of microseconds
-- (GHC only).
--
--- Note that the resolution used by the Haskell runtime system's
--- internal timer is 1\/50 second, and 'threadDelay' will round its
--- argument up to the nearest multiple of this resolution.
---
-- There is no guarantee that the thread will be rescheduled promptly
-- when the delay has expired, but the thread will never continue to
-- run /earlier/ than specified.
-- There is no guarantee that the thread will be rescheduled promptly
-- when the delay has expired, but the thread will never continue to
-- run /earlier/ than specified.
case delay# time# s of { s -> (# s, () #)
}}
case delay# time# s of { s -> (# s, () #)
}}
+
+-- | Set the value of returned TVar to True after a given number of
+-- microseconds. The caveats associated with threadDelay also apply.
+--
registerDelay :: Int -> IO (TVar Bool)
registerDelay usecs
| threaded = waitForDelayEventSTM usecs
registerDelay :: Int -> IO (TVar Bool)
registerDelay usecs
| threaded = waitForDelayEventSTM usecs
waitForDelayEvent :: Int -> IO ()
waitForDelayEvent usecs = do
m <- newEmptyMVar
waitForDelayEvent :: Int -> IO ()
waitForDelayEvent usecs = do
m <- newEmptyMVar
target <- calculateTarget usecs
atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
prodServiceThread
target <- calculateTarget usecs
atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
prodServiceThread
waitForDelayEventSTM :: Int -> IO (TVar Bool)
waitForDelayEventSTM usecs = do
t <- atomically $ newTVar False
waitForDelayEventSTM :: Int -> IO (TVar Bool)
waitForDelayEventSTM usecs = do
t <- atomically $ newTVar False
target <- calculateTarget usecs
atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
prodServiceThread
return t
target <- calculateTarget usecs
atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
prodServiceThread
return t
-calculateTarget :: Int -> IO Int
+calculateTarget :: Int -> IO USecs
calculateTarget usecs = do
calculateTarget usecs = do
- now <- getTicksOfDay
- let -- Convert usecs to ticks, rounding up as we must wait /at least/
- -- as long as we are told
- usecs' = (usecs + tick_usecs - 1) `quot` tick_usecs
- target = now + 1 -- getTicksOfDay will have rounded down, but
- -- again we need to wait for /at least/ as long
- -- as we are told, so add 1 to it
- + usecs'
- return target
+ now <- getUSecOfDay
+ return $ now + (fromIntegral usecs)
+
-- ----------------------------------------------------------------------------
-- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay
-- ----------------------------------------------------------------------------
-- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay
- = Delay {-# UNPACK #-} !Int {-# UNPACK #-} !(MVar ())
- | DelaySTM {-# UNPACK #-} !Int {-# UNPACK #-} !(TVar Bool)
+ = Delay {-# UNPACK #-} !Word64 {-# UNPACK #-} !(MVar ())
+ | DelaySTM {-# UNPACK #-} !Word64 {-# UNPACK #-} !(TVar Bool)
#ifndef mingw32_HOST_OS
pendingEvents :: IORef [IOReq]
#ifndef mingw32_HOST_OS
pendingEvents :: IORef [IOReq]
delayTime (Delay t _) = t
delayTime (DelaySTM t _) = t
delayTime (Delay t _) = t
delayTime (DelaySTM t _) = t
-type Ticks = Int
-tick_freq = 50 :: Ticks -- accuracy of threadDelay (ticks per sec)
-tick_usecs = 1000000 `quot` tick_freq :: Int
-tick_msecs = 1000 `quot` tick_freq :: Int
-- XXX: move into GHC.IOBase from Data.IORef?
atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
-- XXX: move into GHC.IOBase from Data.IORef?
atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
-foreign import ccall unsafe "getTicksOfDay"
- getTicksOfDay :: IO Ticks
+foreign import ccall unsafe "getUSecOfDay"
+ getUSecOfDay :: IO USecs
#ifdef mingw32_HOST_OS
-- ----------------------------------------------------------------------------
#ifdef mingw32_HOST_OS
-- ----------------------------------------------------------------------------
new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
let delays = foldr insertDelay old_delays new_delays
new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
let delays = foldr insertDelay old_delays new_delays
(delays', timeout) <- getDelay now delays
r <- c_WaitForSingleObject wakeup timeout
(delays', timeout) <- getDelay now delays
r <- c_WaitForSingleObject wakeup timeout
-- Walk the queue of pending delays, waking up any that have passed
-- and return the smallest delay to wait for. The queue of pending
-- delays is kept ordered.
-- Walk the queue of pending delays, waking up any that have passed
-- and return the smallest delay to wait for. The queue of pending
-- delays is kept ordered.
-getDelay :: Ticks -> [DelayReq] -> IO ([DelayReq], DWORD)
+getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
getDelay now [] = return ([], iNFINITE)
getDelay now all@(d : rest)
= case d of
getDelay now [] = return ([], iNFINITE)
getDelay now all@(d : rest)
= case d of
-- check the current time and wake up any thread in
-- threadDelay whose timeout has expired. Also find the
-- timeout value for the select() call.
-- check the current time and wake up any thread in
-- threadDelay whose timeout has expired. Also find the
-- timeout value for the select() call.
(delays', timeout) <- getDelay now ptimeval delays
res <- c_select ((max wakeup maxfd)+1) readfds writefds
(delays', timeout) <- getDelay now ptimeval delays
res <- c_select ((max wakeup maxfd)+1) readfds writefds
-- Walk the queue of pending delays, waking up any that have passed
-- and return the smallest delay to wait for. The queue of pending
-- delays is kept ordered.
-- Walk the queue of pending delays, waking up any that have passed
-- and return the smallest delay to wait for. The queue of pending
-- delays is kept ordered.
-getDelay :: Ticks -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)
+getDelay :: USecs -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)
getDelay now ptimeval [] = return ([],nullPtr)
getDelay now ptimeval all@(d : rest)
= case d of
getDelay now ptimeval [] = return ([],nullPtr)
getDelay now ptimeval all@(d : rest)
= case d of
sizeofTimeVal :: Int
foreign import ccall unsafe "setTimevalTicks"
sizeofTimeVal :: Int
foreign import ccall unsafe "setTimevalTicks"
- setTimevalTicks :: Ptr CTimeVal -> Ticks -> IO ()
+ setTimevalTicks :: Ptr CTimeVal -> USecs -> IO ()
{-
On Win32 we're going to have a single Pipe, and a
{-
On Win32 we're going to have a single Pipe, and a
#if defined(__MINGW32__)
/* in Win32Utils.c */
extern void maperrno (void);
#if defined(__MINGW32__)
/* in Win32Utils.c */
extern void maperrno (void);
-extern HsInt getTicksOfDay(void);
+extern HsInt getUSecOfDay(void);
#endif
#if defined(__MINGW32__)
#endif
#if defined(__MINGW32__)
// gettimeofday()-related
#if !defined(__MINGW32__)
// gettimeofday()-related
#if !defined(__MINGW32__)
INLINE HsInt sizeofTimeVal(void) { return sizeof(struct timeval); }
INLINE HsInt sizeofTimeVal(void) { return sizeof(struct timeval); }
-INLINE HsInt getTicksOfDay(void)
+INLINE HsWord64 getUSecOfDay(void)
{
struct timeval tv;
gettimeofday(&tv, (struct timezone *) NULL);
{
struct timeval tv;
gettimeofday(&tv, (struct timezone *) NULL);
- return (tv.tv_sec * TICK_FREQ +
- tv.tv_usec * TICK_FREQ / 1000000);
+ return (tv.tv_sec * 1000000 + tv.tv_usec);
-INLINE void setTimevalTicks(struct timeval *p, HsInt ticks)
+INLINE void setTimevalTicks(struct timeval *p, HsWord64 usecs)
- p->tv_sec = ticks / TICK_FREQ;
- p->tv_usec = (ticks % TICK_FREQ) * (1000000 / TICK_FREQ);
+ p->tv_sec = usecs / 1000000;
+ p->tv_usec = usecs % 1000000;
}
#endif /* !defined(__MINGW32__) */
}
#endif /* !defined(__MINGW32__) */