diff --git a/System/Time/Monotonic.hs b/System/Time/Monotonic.hs --- a/System/Time/Monotonic.hs +++ b/System/Time/Monotonic.hs @@ -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 diff --git a/System/Time/Monotonic/Direct.hsc b/System/Time/Monotonic/Direct.hsc --- a/System/Time/Monotonic/Direct.hsc +++ b/System/Time/Monotonic/Direct.hsc @@ -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 . -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 diff --git a/system-time-monotonic.cabal b/system-time-monotonic.cabal --- a/system-time-monotonic.cabal +++ b/system-time-monotonic.cabal @@ -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 diff --git a/testing/diffMSec32.hs b/testing/diffMSec32.hs --- a/testing/diffMSec32.hs +++ b/testing/diffMSec32.hs @@ -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 diff --git a/testing/make.hs b/testing/make.hs new file mode 100644 --- /dev/null +++ b/testing/make.hs @@ -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