From: Neil Davies Date: Mon, 29 Jan 2007 16:05:19 +0000 (+0000) Subject: wrapround of thread delays X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=4ff009b65beefe01fe812a68f60269279bdc056e;p=haskell-directory.git wrapround of thread delays * 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. --- diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 83a4df8..bd03295 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -622,10 +622,6 @@ threadWaitWrite fd -- | 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. @@ -638,6 +634,10 @@ threadDelay time 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 @@ -648,7 +648,6 @@ foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool waitForDelayEvent :: Int -> IO () waitForDelayEvent usecs = do m <- newEmptyMVar - now <- getTicksOfDay target <- calculateTarget usecs atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ())) prodServiceThread @@ -658,23 +657,16 @@ waitForDelayEvent usecs = do waitForDelayEventSTM :: Int -> IO (TVar Bool) waitForDelayEventSTM usecs = do t <- atomically $ newTVar False - now <- getTicksOfDay target <- calculateTarget usecs atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ())) prodServiceThread return t -calculateTarget :: Int -> IO Int +calculateTarget :: Int -> IO USecs 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 @@ -715,8 +707,8 @@ data IOReq #endif data DelayReq - = 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] @@ -747,17 +739,14 @@ insertDelay d1 ds@(d2 : rest) 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 +type USecs = Word64 -- 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 -- ---------------------------------------------------------------------------- @@ -778,7 +767,7 @@ service_loop wakeup old_delays = do new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a)) let delays = foldr insertDelay old_delays new_delays - now <- getTicksOfDay + now <- getUSecOfDay (delays', timeout) <- getDelay now delays r <- c_WaitForSingleObject wakeup timeout @@ -836,7 +825,7 @@ prodServiceThread = do -- 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 @@ -922,7 +911,7 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do -- check the current time and wake up any thread in -- threadDelay whose timeout has expired. Also find the -- timeout value for the select() call. - now <- getTicksOfDay + now <- getUSecOfDay (delays', timeout) <- getDelay now ptimeval delays res <- c_select ((max wakeup maxfd)+1) readfds writefds @@ -1048,7 +1037,7 @@ waitForWriteEvent fd = do -- 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 @@ -1068,7 +1057,7 @@ foreign import ccall unsafe "sizeofTimeVal" 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 diff --git a/include/HsBase.h b/include/HsBase.h index 161cf9d..519adf7 100644 --- a/include/HsBase.h +++ b/include/HsBase.h @@ -134,7 +134,7 @@ #if defined(__MINGW32__) /* in Win32Utils.c */ extern void maperrno (void); -extern HsInt getTicksOfDay(void); +extern HsInt getUSecOfDay(void); #endif #if defined(__MINGW32__) @@ -717,22 +717,20 @@ extern void hsFD_ZERO(fd_set *fds); // gettimeofday()-related #if !defined(__MINGW32__) -#define TICK_FREQ 50 INLINE HsInt sizeofTimeVal(void) { return sizeof(struct timeval); } -INLINE HsInt getTicksOfDay(void) +INLINE HsWord64 getUSecOfDay(void) { 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__) */