Replace getUSecOfDay with monotonic timer (#5865)

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

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

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__)