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