[commit: base] master: Use monotonic time in Event/Manager.hs. (2f308f5)

[Paolo Capriotti]

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 <p.capriotti at gmail.com>
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 at 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