diff --git a/GHC/Conc/Windows.hs b/GHC/Conc/Windows.hs index 6ea147ce..85032d9f 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 fd4d1eb0..84b6b690 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 29559d5e..70e85db1 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__)