system-time-monotonic 0.1 → 0.2
raw patch · 5 files changed
+142/−40 lines, 5 files
Files
- System/Time/Monotonic.hs +15/−10
- System/Time/Monotonic/Direct.hsc +75/−29
- system-time-monotonic.cabal +8/−1
- testing/diffMSec32.hs +2/−0
- testing/make.hs +42/−0
System/Time/Monotonic.hs view
@@ -39,7 +39,8 @@ import Data.IORef import Data.Time.Clock (DiffTime) -data Clock = forall time. Clock !(SystemClock time) !(IORef (ClockData time))+data Clock = forall time cumtime.+ Clock !(SystemClock time cumtime) !(IORef (ClockData time cumtime)) -- We can't have the Eq instance because the time type is existentially -- quantified, meaning the equality below would have to compare two IORefs of@@ -49,15 +50,15 @@ -- instance Eq Clock where -- Clock _ a == Clock _ b = a == b --- | The externally reported time, paired with the return value of--- 'systemClockGetTime' at a given point in time.+-- | The cumulative amount of time since 'newClock' was called, paired with the+-- return value of 'systemClockGetTime', at a given point in time. ----- The disposition between the 'DiffTime' and the @time@ is set when 'newClock'+-- The disposition between the @cumtime@ and the @time@ is set when 'newClock' -- is called, and remains constant for the lifetime of the 'Clock'. -- 'clockGetTime' merely increments both quantities by the same amount.--- Therefore, barring precision loss, calling 'clockGetTime' frequently should--- not degrade the accuracy of the clock.-data ClockData time = ClockData !DiffTime !time+-- Therefore, calling 'clockGetTime' frequently should not degrade the accuracy+-- of the clock.+data ClockData time cumtime = ClockData !cumtime !time -- | Create a new 'Clock'. The result of 'clockGetTime' is based on the time -- 'newClock' was called.@@ -71,9 +72,13 @@ st2 <- systemClockGetTime clock t2 <- atomicModifyIORef ref $ \(ClockData t1 st1) ->- let t2 = t1 + systemClockDiffTime clock st2 st1+ let t2 = t1 `plus` (st2 `minus` st1) in (ClockData t2 st2, t2)- t2 `seq` return t2+ let t2d = systemClockCumToDiff clock t2+ t2 `seq` t2d `seq` return t2d+ where+ plus = systemClockAddCumTime clock+ minus = systemClockDiffTime clock -- | Variant of 'newClock' that uses the given driver. This can be used if you -- want to use a different time source than the default.@@ -82,7 +87,7 @@ newClockWithDriver :: SomeSystemClock -> IO Clock newClockWithDriver (SomeSystemClock clock) = do st <- systemClockGetTime clock- ref <- newIORef (ClockData 0 st)+ ref <- newIORef (ClockData (systemClockZeroCumTime clock) st) return (Clock clock ref) -- | Return a string identifying the time source, such as
System/Time/Monotonic/Direct.hsc view
@@ -50,7 +50,8 @@ #endif -- | Existentially-quantified wrapper around 'SystemClock'-data SomeSystemClock = forall time. SomeSystemClock (SystemClock time)+data SomeSystemClock = forall time cumtime.+ SomeSystemClock (SystemClock time cumtime) instance Show SomeSystemClock where showsPrec d (SomeSystemClock sc)@@ -58,17 +59,44 @@ $ showString "SomeSystemClock " . showsPrec 11 (systemClockName sc) -data SystemClock time = SystemClock- { systemClockGetTime :: IO time- , systemClockDiffTime :: time -> time -> DiffTime+-- | A 'SystemClock' is a driver module used by 'System.Time.Monotonic.Clock'+-- to access a particular implementation of monotonic time support.+--+-- * @time@: Type of value returned by the system's time-getting function.+--+-- * @cumtime@: Type for accumulating differences between consecutive(-ish)+-- calls to 'systemClockGetTime', in case @time@ wraps around.+-- The reason we don't simply use 'DiffTime' is this: if the implementation+-- has to divide the result by a clock frequency, it could end up with a+-- number that is not an integral number of picoseconds. Truncating to+-- 'DiffTime' would lose precision, and that precision loss could add up, at+-- least in theory.+data SystemClock time cumtime = SystemClock+ { systemClockGetTime :: IO time+ , systemClockDiffTime :: time -> time -> cumtime -- ^ @systemClockDiffTime new old@ returns the amount of time that has -- elapsed between two calls to @systemClockGetTime@. --+ -- >systemClockDiffTime new old = new - old+ -- -- This function should handle wraparound properly. Also, bear in mind -- that @new@ may be earlier than @old@. This can happen if multiple -- threads are accessing a 'System.Time.Monotonic.Clock' -- simultaneously.- , systemClockName :: String+ --+ -- Lastly, @systemClockDiffTime@ should not truncate precision in+ -- conversion to cumtime. Otherwise, repeated calls to+ -- 'System.Time.Monotonic.clockGetTime' could degrade accuracy, due to+ -- lost precision adding up.+ , systemClockZeroCumTime :: cumtime+ -- ^ The number @0@.+ , systemClockAddCumTime :: cumtime -> cumtime -> cumtime+ -- ^ Add two @cumtime@ values. This should not overflow or lose+ -- precision.+ , systemClockCumToDiff :: cumtime -> DiffTime+ -- ^ Convert a cumulative total of 'systemClockDiffTime' results to+ -- 'DiffTime'. This may truncate precision if it needs to.+ , systemClockName :: String -- ^ Label identifying this clock, like -- @\"clock_gettime(CLOCK_MONOTONIC)\"@ or -- @\"GetTickCount\"@. This label is used for the 'Show'@@ -76,7 +104,7 @@ -- 'System.Time.Monotonic.clockDriverName'. } -instance Show (SystemClock time) where+instance Show (SystemClock time cumtime) where showsPrec d sc = showParen (d > 10) $ showString "SystemClock "@@ -115,12 +143,15 @@ -- -- @GetTickCount@ has a 49.7 day wraparound, due to the type of the return -- value (milliseconds as an unsigned 32-bit integer).-systemClock_GetTickCount :: SystemClock Word32+systemClock_GetTickCount :: SystemClock Word32 DiffTime systemClock_GetTickCount = SystemClock- { systemClockGetTime = c_GetTickCount- , systemClockDiffTime = diffMSec32- , systemClockName = "GetTickCount"+ { systemClockGetTime = c_GetTickCount+ , systemClockDiffTime = diffMSec32+ , systemClockZeroCumTime = 0+ , systemClockAddCumTime = (+)+ , systemClockCumToDiff = id+ , systemClockName = "GetTickCount" } foreign import stdcall "Windows.h GetTickCount"@@ -129,7 +160,7 @@ -- | Uses @GetTickCount64@, which was introduced in Windows Vista and -- Windows Server 2008. This function tests, at runtime, if @GetTickCount64@ -- is available.-systemClock_GetTickCount64 :: IO (Maybe (SystemClock Word64))+systemClock_GetTickCount64 :: IO (Maybe (SystemClock Word64 DiffTime)) systemClock_GetTickCount64 = do fun <- system_time_monotonic_load_GetTickCount64 if fun == nullFunPtr@@ -138,9 +169,12 @@ where clock getTickCount64 = SystemClock- { systemClockGetTime = getTickCount64- , systemClockDiffTime = diffMSec64- , systemClockName = "GetTickCount64"+ { systemClockGetTime = getTickCount64+ , systemClockDiffTime = diffMSec64+ , systemClockZeroCumTime = 0+ , systemClockAddCumTime = (+)+ , systemClockCumToDiff = id+ , systemClockName = "GetTickCount64" } type C_GetTickCount64 = IO #{type ULONGLONG}@@ -152,14 +186,17 @@ foreign import stdcall "dynamic" mkGetTickCount64 :: FunPtr C_GetTickCount64 -> C_GetTickCount64 -qpcDiffTime :: Int64 -> Int64 -> Int64 -> DiffTime-qpcDiffTime freq new old =- fromRational $ fromIntegral (new - old) % fromIntegral freq+qpcDiffTime :: Int64 -> Int64 -> Integer+qpcDiffTime new old = fromIntegral (new - old) +qpcCumToDiff :: Int64 -> Integer -> DiffTime+qpcCumToDiff freq cum = fromRational (cum % fromIntegral freq)+ -- | Uses @QueryPerformanceCounter@. This is not the default because it is--- less reliable in the long run than @GetTickCount@, and it stops when the--- computer is put in suspend mode.-systemClock_QueryPerformanceCounter :: IO (Maybe (SystemClock Int64))+-- less reliable in the long run than @GetTickCount@. On my laptop, it skips+-- ahead roughly 2 seconds when the computer goes into sleep mode, but counts+-- time spent sleeping.+systemClock_QueryPerformanceCounter :: IO (Maybe (SystemClock Int64 Integer)) systemClock_QueryPerformanceCounter = do mfreq <- callQP c_QueryPerformanceFrequency case mfreq of@@ -174,8 +211,11 @@ Nothing -> fail "QueryPerformanceCounter failed,\ \ even though QueryPerformanceFrequency\ \ succeeded earlier"- , systemClockDiffTime = qpcDiffTime freq- , systemClockName = "QueryPerformanceCounter"+ , systemClockDiffTime = qpcDiffTime+ , systemClockZeroCumTime = 0+ , systemClockAddCumTime = (+)+ , systemClockCumToDiff = qpcCumToDiff freq+ , systemClockName = "QueryPerformanceCounter" } callQP :: QPFunc -> IO (Maybe Int64)@@ -206,6 +246,7 @@ , tv_nsec :: !CLong -- ^ nanoseconds. 1 second = 10^9 nanoseconds }+ deriving Show diffCTimeSpec :: CTimeSpec -> CTimeSpec -> DiffTime diffCTimeSpec a b@@ -232,12 +273,15 @@ -- -- /Warning:/ on Linux, this clock stops when the computer is suspended. -- See <http://lwn.net/Articles/434239/>.-systemClock_MONOTONIC :: SystemClock CTimeSpec+systemClock_MONOTONIC :: SystemClock CTimeSpec DiffTime systemClock_MONOTONIC = SystemClock- { systemClockGetTime = clock_gettime #{const CLOCK_MONOTONIC}- , systemClockDiffTime = diffCTimeSpec- , systemClockName = "clock_gettime(CLOCK_MONOTONIC)"+ { systemClockGetTime = clock_gettime #{const CLOCK_MONOTONIC}+ , systemClockDiffTime = diffCTimeSpec+ , systemClockZeroCumTime = 0+ , systemClockAddCumTime = (+)+ , systemClockCumToDiff = id+ , systemClockName = "clock_gettime(CLOCK_MONOTONIC)" } -- CLOCK_MONOTONIC_RAW is more reliable, but requires@@ -247,9 +291,11 @@ -- systemClock_MONOTONIC_RAW :: SystemClock CTimeSpec -- systemClock_MONOTONIC_RAW = -- SystemClock--- { systemClockGetTime = clock_gettime #{const CLOCK_MONOTONIC_RAW}--- , systemClockDiffTime = diffCTimeSpec--- , systemClockName = "clock_gettime(CLOCK_MONOTONIC_RAW)"+-- { systemClockGetTime = clock_gettime #{const CLOCK_MONOTONIC_RAW}+-- , systemClockDiffTime = diffCTimeSpec+-- , systemClockAddCumTime = (+)+-- , systemClockCumToDiff = id+-- , systemClockName = "clock_gettime(CLOCK_MONOTONIC_RAW)" -- } clock_gettime :: #{type clockid_t} -> IO CTimeSpec
system-time-monotonic.cabal view
@@ -1,5 +1,5 @@ name: system-time-monotonic-version: 0.1+version: 0.2 synopsis: Simple library for using the system's monotonic clock description: Simple library for using the system's monotonic clock. This library is@@ -14,6 +14,12 @@ @GetTickCount@. . * On Linux, this uses @clock_gettime@ with @CLOCK_MONOTONIC@.+ .+ Release history:+ .+ [0.2] Update driver API (@SystemClock@) to prevent cumulative precision loss.+ .+ [0.1] Initial release. homepage: https://github.com/joeyadams/haskell-system-time-monotonic license: BSD3 license-file: LICENSE@@ -25,6 +31,7 @@ cabal-version: >=1.8 extra-source-files:+ testing/make.hs testing/benchmark.hs testing/bombard.hs testing/clock.hs
testing/diffMSec32.hs view
@@ -6,6 +6,8 @@ test expected new old = return $ diffMSec32 new old == expected && diffMSec32 old new == -expected+ where+ diffMSec32 = systemClockDiffTime systemClock_GetTickCount main :: IO () main = do
+ testing/make.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS -fno-warn-missing-signatures #-}+import Development.Shake+import Development.Shake.FilePath+import System.Environment++tests =+ [ "benchmark"+ , "bombard"+ , "clock"+ , "delay"+ , "leak"+#if mingw32_HOST_OS+ , "diffMSec32"+#endif+ ]++#if mingw32_HOST_OS+binaries = map (++ ".exe") tests+#else+binaries = tests+#endif++intermediates = map (++ ".hi") tests+ ++ map (++ ".o") tests++main = do+ args <- getArgs+ shake shakeOptions $ do+ case args of+ ["clean"] -> clean+ _ -> build++build = do+ want binaries+ (`elem` binaries) ?> \out -> do+ let hs = replaceExtension out ".hs"+ need [hs]+ system' "ghc" ["-Wall", "-O2", "-threaded", hs, "-o", out]++clean = action $ do+ system' "rm" $ "-f" : intermediates ++ binaries