[commit: base] master: Replace getUSecOfDay with monotonic timer (#5865) (4bea82c)

[Paolo Capriotti]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/4bea82c27d75845d0816617bcfa8514d02400b77

>---------------------------------------------------------------

commit 4bea82c27d75845d0816617bcfa8514d02400b77
Author: Paolo Capriotti <p.capriotti at gmail.com>
Date:   Fri Mar 23 14:26:20 2012 +0000

    Replace getUSecOfDay with monotonic timer (#5865)

>---------------------------------------------------------------

 GHC/Conc/Windows.hs |   18 ++++++++++++----
 cbits/Win32Utils.c  |   53 +++++++++++++++++++++++++++++++++++++++++---------
 include/HsBase.h    |    2 +-
 3 files changed, 57 insertions(+), 16 deletions(-)

diff --git a/GHC/Conc/Windows.hs b/GHC/Conc/Windows.hs
index 6ea147c..85032d9 100644
--- a/GHC/Conc/Windows.hs
+++ b/GHC/Conc/Windows.hs
@@ -140,7 +140,7 @@ waitForDelayEventSTM usecs = do
 
 calculateTarget :: Int -> IO USecs
 calculateTarget usecs = do
-    now <- getUSecOfDay
+    now <- getMonotonicUSec
     return $ now + (fromIntegral usecs)
 
 data DelayReq
@@ -167,9 +167,14 @@ foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
 
 ensureIOManagerIsRunning :: IO ()
 ensureIOManagerIsRunning
-  | threaded  = startIOManagerThread
+  | threaded  = initializeIOManager
   | otherwise = return ()
 
+initializeIOManager :: IO ()
+initializeIOManager = do
+    initializeTimer
+    startIOManagerThread
+
 startIOManagerThread :: IO ()
 startIOManagerThread = do
   modifyMVar_ ioManagerThread $ \old -> do
@@ -195,8 +200,11 @@ delayTime (DelaySTM t _) = t
 
 type USecs = Word64
 
-foreign import ccall unsafe "getUSecOfDay"
-  getUSecOfDay :: IO USecs
+foreign import ccall unsafe "getMonotonicUSec"
+  getMonotonicUSec :: IO USecs
+
+foreign import ccall unsafe "initializeTimer"
+  initializeTimer :: IO ()
 
 {-# NOINLINE prodding #-}
 prodding :: IORef Bool
@@ -232,7 +240,7 @@ service_loop wakeup old_delays = do
   new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
   let  delays = foldr insertDelay old_delays new_delays
 
-  now <- getUSecOfDay
+  now <- getMonotonicUSec
   (delays', timeout) <- getDelay now delays
 
   r <- c_WaitForSingleObject wakeup timeout
diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c
index fd4d1eb..84b6b69 100644
--- a/cbits/Win32Utils.c
+++ b/cbits/Win32Utils.c
@@ -110,17 +110,50 @@ void maperrno (void)
 			errno = EINVAL;
 }
 
-HsWord64 getUSecOfDay(void)
+// Number of ticks per second used by the QueryPerformanceFrequency
+// implementaiton, represented by a 64-bit union type.
+static LARGE_INTEGER qpc_frequency = {.QuadPart = 0};
+
+// Initialize qpc_frequency. This function should be called before any call to
+// getMonotonicUSec.  If QPC is not supported on this system, qpc_frequency is
+// set to 0.
+void initializeTimer()
 {
-    HsWord64 t;
-    FILETIME ft;
-    GetSystemTimeAsFileTime(&ft);
-    t = ((HsWord64)ft.dwHighDateTime << 32) | ft.dwLowDateTime;
-    t = t / 10LL;
-    /* FILETIMES are in units of 100ns,
-       so we divide by 10 to get microseconds */
-    return t;
+    BOOL qpc_supported = QueryPerformanceFrequency(&qpc_frequency);
+    if (!qpc_supported)
+    {
+        qpc_frequency.QuadPart = 0;
+    }
 }
 
-#endif
+HsWord64 getMonotonicUSec()
+{
+    if (qpc_frequency.QuadPart)
+    {
+        // system_time is a 64-bit union type used to represent the
+        // tick count returned by QueryPerformanceCounter
+        LARGE_INTEGER system_time;
+
+        // get the tick count.
+        QueryPerformanceCounter(&system_time);
+
+        // compute elapsed seconds as double
+        double secs = (double)system_time.QuadPart /
+                      (double)qpc_frequency.QuadPart;
+
+        // return elapsed time in microseconds
+        return (HsWord64)(secs * 1e6);
+    }
+    else // fallback to GetTickCount
+    {
+        // NOTE: GetTickCount is a 32-bit millisecond value, so it wraps around
+        // every 49 days.
+        DWORD count = GetTickCount();
+
+        // getTickCount is in milliseconds, so multiply it by 1000 to get
+        // microseconds.
+        return (HsWord64)count * 1000;
+    }
+}
 
+#endif
diff --git a/include/HsBase.h b/include/HsBase.h
index 29559d5..70e85db 100644
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -141,7 +141,7 @@
 #if defined(__MINGW32__)
 /* in Win32Utils.c */
 extern void maperrno (void);
-extern HsWord64 getUSecOfDay(void);
+extern HsWord64 getMonotonicUSec(void);
 #endif
 
 #if defined(__MINGW32__)