Repository : ssh://darcs.haskell.org//srv/darcs/packages/base On branch : master
http://hackage.haskell.org/trac/ghc/changeset/2f308f5771fc94657a80252ac16b7fac8ee80e9c >--------------------------------------------------------------- commit 2f308f5771fc94657a80252ac16b7fac8ee80e9c Author: Paolo Capriotti <[email protected]> Date: Mon Mar 19 18:00:48 2012 +0000 Use monotonic time in Event/Manager.hs. >--------------------------------------------------------------- GHC/Event/Clock.hsc | 52 +++++++++++++++++++++++++++++++++++++------- GHC/Event/Manager.hs | 8 +++--- configure.ac | 2 + include/HsBase.h | 7 ++++++ include/Nhc98BaseConfig.h | 1 + 5 files changed, 57 insertions(+), 13 deletions(-) diff --git a/GHC/Event/Clock.hsc b/GHC/Event/Clock.hsc index 4a538f4..8da01ae 100644 --- a/GHC/Event/Clock.hsc +++ b/GHC/Event/Clock.hsc @@ -1,11 +1,11 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface, CApiFFI #-} -module GHC.Event.Clock (getCurrentTime) where +module GHC.Event.Clock (getMonotonicTime) where -#include <sys/time.h> +#include "HsBase.h" -import Foreign (Ptr, Storable(..), nullPtr, with) +import Foreign import Foreign.C.Error (throwErrnoIfMinus1_) import Foreign.C.Types import GHC.Base @@ -15,18 +15,51 @@ import GHC.Real -- TODO: Implement this for Windows. --- | Return the current time, in seconds since Jan. 1, 1970. -getCurrentTime :: IO Double -getCurrentTime = do +-- | Return monotonic time in seconds, since some unspecified starting point +getMonotonicTime :: IO Double + +------------------------------------------------------------------------ +-- FFI binding + +#if HAVE_CLOCK_GETTIME + +getMonotonicTime = do + tv <- with (CTimespec 0 0) $ \tvptr -> do + throwErrnoIfMinus1_ "clock_gettime" (clock_gettime (#const CLOCK_ID) tvptr) + peek tvptr + let !t = realToFrac (sec tv) + realToFrac (nsec tv) / 1000000000.0 + return t + +data CTimespec = CTimespec + { sec :: {-# UNPACK #-} !CTime + , nsec :: {-# UNPACK #-} !CLong + } + +instance Storable CTimespec where + sizeOf _ = #size struct timespec + alignment _ = alignment (undefined :: CLong) + + peek ptr = do + sec' <- #{peek struct timespec, tv_sec} ptr + nsec' <- #{peek struct timespec, tv_nsec} ptr + return $ CTimespec sec' nsec' + + poke ptr tv = do + #{poke struct timespec, tv_sec} ptr (sec tv) + #{poke struct timespec, tv_nsec} ptr (nsec tv) + +foreign import capi unsafe "HsBase.h clock_gettime" clock_gettime + :: Int -> Ptr CTimespec -> IO CInt + +#else + +getMonotonicTime = do tv <- with (CTimeval 0 0) $ \tvptr -> do throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr) peek tvptr let !t = realToFrac (sec tv) + realToFrac (usec tv) / 1000000.0 return t ------------------------------------------------------------------------- --- FFI binding - data CTimeval = CTimeval { sec :: {-# UNPACK #-} !CTime , usec :: {-# UNPACK #-} !CSUSeconds @@ -48,3 +81,4 @@ instance Storable CTimeval where foreign import capi unsafe "HsBase.h gettimeofday" gettimeofday :: Ptr CTimeval -> Ptr () -> IO CInt +#endif diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs index 089532c..35f414b 100644 --- a/GHC/Event/Manager.hs +++ b/GHC/Event/Manager.hs @@ -63,7 +63,7 @@ import GHC.List (filter) import GHC.Num (Num(..)) import GHC.Real ((/), fromIntegral ) import GHC.Show (Show(..)) -import GHC.Event.Clock (getCurrentTime) +import GHC.Event.Clock (getMonotonicTime) import GHC.Event.Control import GHC.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite, Timeout(..)) @@ -256,7 +256,7 @@ step mgr@EventManager{..} tq = do -- next timeout. mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue) mkTimeout q = do - now <- getCurrentTime + now <- getMonotonicTime applyEdits <- atomicModifyIORef emTimeouts $ \f -> (id, f) let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q' sequence_ $ map Q.value expired @@ -363,7 +363,7 @@ registerTimeout mgr us cb = do !key <- newUnique (emUniqueSource mgr) if us <= 0 then cb else do - now <- getCurrentTime + now <- getMonotonicTime let expTime = fromIntegral us / 1000000.0 + now -- We intentionally do not evaluate the modified map to WHNF here. @@ -387,7 +387,7 @@ unregisterTimeout mgr (TK key) = do -- microseconds. updateTimeout :: EventManager -> TimeoutKey -> Int -> IO () updateTimeout mgr (TK key) us = do - now <- getCurrentTime + now <- getMonotonicTime let expTime = fromIntegral us / 1000000.0 + now atomicModifyIORef (emTimeouts mgr) $ \f -> diff --git a/configure.ac b/configure.ac index 071e42a..0ce53b7 100644 --- a/configure.ac +++ b/configure.ac @@ -36,6 +36,8 @@ dnl functions if it's really there. AC_CHECK_HEADERS([wctype.h], [AC_CHECK_FUNCS(iswspace)]) AC_CHECK_FUNCS([lstat]) +AC_CHECK_LIB([rt], [clock_gettime]) +AC_CHECK_FUNCS([clock_gettime]) AC_CHECK_FUNCS([getclock getrusage times]) AC_CHECK_FUNCS([_chsize ftruncate]) diff --git a/include/HsBase.h b/include/HsBase.h index 73106ec..b321967 100644 --- a/include/HsBase.h +++ b/include/HsBase.h @@ -104,6 +104,13 @@ #elif HAVE_STDINT_H # include <stdint.h> #endif +#if HAVE_CLOCK_GETTIME +# ifdef _POSIX_MONOTONIC_CLOCK +# define CLOCK_ID CLOCK_MONOTONIC +# else +# define CLOCK_ID CLOCK_REALTIME +# endif +#endif #if !defined(__MINGW32__) && !defined(irix_HOST_OS) # if HAVE_SYS_RESOURCE_H diff --git a/include/Nhc98BaseConfig.h b/include/Nhc98BaseConfig.h index 866e035..aabc973 100644 --- a/include/Nhc98BaseConfig.h +++ b/include/Nhc98BaseConfig.h @@ -20,6 +20,7 @@ #define HAVE_GETTIMEOFDAY 1 #define HAVE_SYS_TIME_H 1 #define HAVE_GETCLOCK 0 +#define HAVE_CLOCK_GETTIME 1 #define HAVE_SYS_TIMERS_H 0 #define HAVE_TIME_H 1 #define HAVE_SYS_TIMEB_H 1 _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
