Ticket #5865: 5865-win32-threaded.2.patch

File 5865-win32-threaded.2.patch, 4.2 KB (added by pcapriotti, 3 years ago)
  • GHC/Conc/Windows.hs

    From cc09f874de906160fb24d52fea430c3eb8c2bb90 Mon Sep 17 00:00:00 2001
    From: Paolo Capriotti <[email protected]>
    Date: Fri, 23 Mar 2012 14:26:20 +0000
    Subject: [PATCH] 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 b waitForDelayEventSTM usecs = do 
    140140 
    141141calculateTarget :: Int -> IO USecs 
    142142calculateTarget usecs = do 
    143     now <- getUSecOfDay 
     143    now <- getMonotonicUSec 
    144144    return $ now + (fromIntegral usecs) 
    145145 
    146146data DelayReq 
    foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore" 
    167167 
    168168ensureIOManagerIsRunning :: IO () 
    169169ensureIOManagerIsRunning 
    170   | threaded  = startIOManagerThread 
     170  | threaded  = initializeIOManager 
    171171  | otherwise = return () 
    172172 
     173initializeIOManager :: IO () 
     174initializeIOManager = do 
     175    initializeTimer 
     176    startIOManagerThread 
     177 
    173178startIOManagerThread :: IO () 
    174179startIOManagerThread = do 
    175180  modifyMVar_ ioManagerThread $ \old -> do 
    delayTime (DelaySTM t _) = t 
    195200 
    196201type USecs = Word64 
    197202 
    198 foreign import ccall unsafe "getUSecOfDay" 
    199   getUSecOfDay :: IO USecs 
     203foreign import ccall unsafe "getMonotonicUSec" 
     204  getMonotonicUSec :: IO USecs 
     205 
     206foreign import ccall unsafe "initializeTimer" 
     207  initializeTimer :: IO () 
    200208 
    201209{-# NOINLINE prodding #-} 
    202210prodding :: IORef Bool 
    service_loop wakeup old_delays = do 
    232240  new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a)) 
    233241  let  delays = foldr insertDelay old_delays new_delays 
    234242 
    235   now <- getUSecOfDay 
     243  now <- getMonotonicUSec 
    236244  (delays', timeout) <- getDelay now delays 
    237245 
    238246  r <- c_WaitForSingleObject wakeup timeout 
  • cbits/Win32Utils.c

    diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c
    index fd4d1eb..84b6b69 100644
    a b void maperrno (void) 
    110110                        errno = EINVAL; 
    111111} 
    112112 
    113 HsWord64 getUSecOfDay(void) 
     113// Number of ticks per second used by the QueryPerformanceFrequency 
     114// implementaiton, represented by a 64-bit union type. 
     115static LARGE_INTEGER qpc_frequency = {.QuadPart = 0}; 
     116 
     117// Initialize qpc_frequency. This function should be called before any call to 
     118// getMonotonicUSec.  If QPC is not supported on this system, qpc_frequency is 
     119// set to 0. 
     120void initializeTimer() 
    114121{ 
    115     HsWord64 t; 
    116     FILETIME ft; 
    117     GetSystemTimeAsFileTime(&ft); 
    118     t = ((HsWord64)ft.dwHighDateTime << 32) | ft.dwLowDateTime; 
    119     t = t / 10LL; 
    120     /* FILETIMES are in units of 100ns, 
    121        so we divide by 10 to get microseconds */ 
    122     return t; 
     122    BOOL qpc_supported = QueryPerformanceFrequency(&qpc_frequency); 
     123    if (!qpc_supported) 
     124    { 
     125        qpc_frequency.QuadPart = 0; 
     126    } 
    123127} 
    124128 
    125 #endif 
     129HsWord64 getMonotonicUSec() 
     130{ 
     131    if (qpc_frequency.QuadPart) 
     132    { 
     133        // system_time is a 64-bit union type used to represent the 
     134        // tick count returned by QueryPerformanceCounter 
     135        LARGE_INTEGER system_time; 
     136 
     137        // get the tick count. 
     138        QueryPerformanceCounter(&system_time); 
     139 
     140        // compute elapsed seconds as double 
     141        double secs = (double)system_time.QuadPart / 
     142                      (double)qpc_frequency.QuadPart; 
     143 
     144        // return elapsed time in microseconds 
     145        return (HsWord64)(secs * 1e6); 
     146    } 
     147    else // fallback to GetTickCount 
     148    { 
     149        // NOTE: GetTickCount is a 32-bit millisecond value, so it wraps around 
     150        // every 49 days. 
     151        DWORD count = GetTickCount(); 
     152 
     153        // getTickCount is in milliseconds, so multiply it by 1000 to get 
     154        // microseconds. 
     155        return (HsWord64)count * 1000; 
     156    } 
     157} 
    126158 
     159#endif 
  • include/HsBase.h

    diff --git a/include/HsBase.h b/include/HsBase.h
    index 29559d5..70e85db 100644
    a b  
    141141#if defined(__MINGW32__) 
    142142/* in Win32Utils.c */ 
    143143extern void maperrno (void); 
    144 extern HsWord64 getUSecOfDay(void); 
     144extern HsWord64 getMonotonicUSec(void); 
    145145#endif 
    146146 
    147147#if defined(__MINGW32__)