diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Joseph Adams + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Joseph Adams nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Time/Monotonic.hs b/System/Time/Monotonic.hs new file mode 100644 --- /dev/null +++ b/System/Time/Monotonic.hs @@ -0,0 +1,115 @@ +-- | +-- Module: System.Time.Monotonic +-- Copyright: (c) Joseph Adams 2012 +-- License: BSD3 +-- Maintainer: joeyadams3.14159@gmail.com +-- Portability: Tested on Linux and Windows. +-- +-- This module provides a platform-independent API for using the system's +-- monotonic clock. +-- +-- Known issues: +-- +-- * On Windows XP, this uses @GetTickCount@, which has a 49.7 day wraparound. +-- 'Clock' works around this problem, but the workaround only works if +-- 'clockGetTime' is called at least once every 24.8 days. +-- +-- * On Linux, this uses @clock_gettime@ with @CLOCK_MONOTONIC@, +-- which (unfortunately) stops when the computer is suspended. Thus, +-- 'clockGetTime' will not include time spent sleeping. Do not rely on this +-- behavior, as it may be fixed in a future version of this library. +{-# LANGUAGE ExistentialQuantification #-} +module System.Time.Monotonic ( + -- * Clock + Clock, + newClock, + clockGetTime, + + -- ** Drivers + newClockWithDriver, + clockDriverName, + + -- * Utilities + delay, +) where + +import System.Time.Monotonic.Direct + +import Control.Concurrent (threadDelay) +import Data.IORef +import Data.Time.Clock (DiffTime) + +data Clock = forall time. Clock !(SystemClock time) !(IORef (ClockData time)) + +-- 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 +-- different value type. If we really wanted it, we could add a dummy IORef, +-- use Typeable, or perhaps even use unsafeCoerce. +-- +-- 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 disposition between the 'DiffTime' 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 + +-- | Create a new 'Clock'. The result of 'clockGetTime' is based on the time +-- 'newClock' was called. +newClock :: IO Clock +newClock = newClockWithDriver =<< getSystemClock + +-- | Return the amount of time that has elapsed since the clock was created +-- with 'newClock'. +clockGetTime :: Clock -> IO DiffTime +clockGetTime (Clock clock ref) = do + st2 <- systemClockGetTime clock + t2 <- atomicModifyIORef ref $ + \(ClockData t1 st1) -> + let t2 = t1 + systemClockDiffTime clock st2 st1 + in (ClockData t2 st2, t2) + t2 `seq` return t2 + +-- | Variant of 'newClock' that uses the given driver. This can be used if you +-- want to use a different time source than the default. +-- +-- @'newClock' = 'newClockWithDriver' =<< 'getSystemClock'@ +newClockWithDriver :: SomeSystemClock -> IO Clock +newClockWithDriver (SomeSystemClock clock) = do + st <- systemClockGetTime clock + ref <- newIORef (ClockData 0 st) + return (Clock clock ref) + +-- | Return a string identifying the time source, such as +-- @\"clock_gettime(CLOCK_MONOTONIC)\"@ or +-- @\"GetTickCount\"@. +clockDriverName :: Clock -> String +clockDriverName (Clock clock _) = systemClockName clock + +-- | Variant of 'threadDelay' for 'DiffTime'. +delay :: DiffTime -> IO () +delay difftime = + loop $ ceiling $ difftime * 1000000 + where + loop :: Integer -> IO () + loop usec + | usec <= maxWait = wait usec + | otherwise = wait maxWait + >> loop (usec - maxWait) + + -- maxWait is 100 seconds. 2^31-1 microseconds is about 2147 seconds. + -- This gives the implementation of 'threadDelay' plenty of leeway if it + -- needs to do some arithmetic on the time value first. + maxWait = 100000000 + + wait usec = case fromIntegral usec of + n | n > 0 -> threadDelay n + | otherwise -> return () + -- Guard against negative argument to threadDelay, + -- for earlier versions of base. + -- See http://hackage.haskell.org/trac/ghc/ticket/2892 diff --git a/System/Time/Monotonic/Direct.hsc b/System/Time/Monotonic/Direct.hsc new file mode 100644 --- /dev/null +++ b/System/Time/Monotonic/Direct.hsc @@ -0,0 +1,267 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- | +-- Module: System.Time.Monotonic.Direct +-- Copyright: (c) Joseph Adams 2012 +-- License: BSD3 +-- Maintainer: joeyadams3.14159@gmail.com +-- Portability: Tested on Linux and Windows +-- +-- This module provides more direct access to the system's monotonic clock, +-- but provides less protection against wraparound. +-- +-- More specifically, in the higher-level "System.Time.Monotonic" API, +-- 'System.Time.Monotonic.Clock' updates its internal disposition every time +-- 'System.Time.Monotonic.clockGetTime' is called. The only way to get a +-- wraparound issue with the higher-level API is to call +-- 'System.Time.Monotonic.clockGetTime' very seldomly (e.g. less than once +-- every 24.8 days, if @GetTickCount@ is being used). +module System.Time.Monotonic.Direct ( + getSystemClock, + SomeSystemClock(..), + SystemClock(..), + + -- * Implementation(s) + -- | The set of definitions below is platform-dependent. + +#if mingw32_HOST_OS + systemClock_GetTickCount, + systemClock_GetTickCount64, + systemClock_QueryPerformanceCounter, +#else + systemClock_MONOTONIC, + CTimeSpec, +#endif +) where + +import Data.Bits (isSigned) +import Data.Int +import Data.Time.Clock (DiffTime) +import Data.Word +import Foreign (Ptr, FunPtr, allocaBytes, nullFunPtr, peekByteOff) + +#if mingw32_HOST_OS +import Data.Ratio ((%)) +#include +#else +import Foreign.C +#include +#endif + +-- | Existentially-quantified wrapper around 'SystemClock' +data SomeSystemClock = forall time. SomeSystemClock (SystemClock time) + +instance Show SomeSystemClock where + showsPrec d (SomeSystemClock sc) + = showParen (d > 10) + $ showString "SomeSystemClock " + . showsPrec 11 (systemClockName sc) + +data SystemClock time = SystemClock + { systemClockGetTime :: IO time + , systemClockDiffTime :: time -> time -> DiffTime + -- ^ @systemClockDiffTime new old@ returns the amount of time that has + -- elapsed between two calls to @systemClockGetTime@. + -- + -- 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 + -- ^ Label identifying this clock, like + -- @\"clock_gettime(CLOCK_MONOTONIC)\"@ or + -- @\"GetTickCount\"@. This label is used for the 'Show' + -- instances of 'SystemClock' and 'SomeSystemClock', and for + -- 'System.Time.Monotonic.clockDriverName'. + } + +instance Show (SystemClock time) where + showsPrec d sc + = showParen (d > 10) + $ showString "SystemClock " + . showsPrec 11 (systemClockName sc) + +-- | Return a module used for accessing the system's monotonic clock. The +-- reason this is an 'IO' action, rather than simply a 'SystemClock' value, is +-- that the implementation may need to make a system call to determine what +-- monotonic time source to use, and how to use it. +getSystemClock :: IO SomeSystemClock +#if mingw32_HOST_OS +getSystemClock = do + m <- systemClock_GetTickCount64 + case m of + Just gtc64 -> return $ SomeSystemClock gtc64 + Nothing -> return $ SomeSystemClock systemClock_GetTickCount +#else +getSystemClock = + return $ SomeSystemClock systemClock_MONOTONIC +#endif + +#if mingw32_HOST_OS + +diffMSec32 :: Word32 -> Word32 -> DiffTime +diffMSec32 a b = fromIntegral (fromIntegral (a - b :: Word32) :: Int32) / 1000 + -- Do the subtraction modulo 2^32, to handle wraparound properly. + -- However, convert it from unsigned to signed, to avoid + -- a bogus result if a is earlier than b. + +diffMSec64 :: Word64 -> Word64 -> DiffTime +diffMSec64 a b = fromIntegral (fromIntegral (a - b :: Word64) :: Int64) / 1000 + + +-- | Use @GetTickCount@. This is the default on Windows when @GetTickCount64@ +-- is not available. +-- +-- @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 + { systemClockGetTime = c_GetTickCount + , systemClockDiffTime = diffMSec32 + , systemClockName = "GetTickCount" + } + +foreign import stdcall "Windows.h GetTickCount" + c_GetTickCount :: IO #{type DWORD} + +-- | 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 = do + fun <- system_time_monotonic_load_GetTickCount64 + if fun == nullFunPtr + then return Nothing + else return $ Just $ clock $ mkGetTickCount64 fun + where + clock getTickCount64 = + SystemClock + { systemClockGetTime = getTickCount64 + , systemClockDiffTime = diffMSec64 + , systemClockName = "GetTickCount64" + } + +type C_GetTickCount64 = IO #{type ULONGLONG} + +-- Defined in cbits/dll.c +foreign import ccall + system_time_monotonic_load_GetTickCount64 :: IO (FunPtr C_GetTickCount64) + +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 + +-- | 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)) +systemClock_QueryPerformanceCounter = do + mfreq <- callQP c_QueryPerformanceFrequency + case mfreq of + Nothing -> return Nothing + Just 0 -> return Nothing -- Shouldn't happen; just a safeguard to + -- prevent zero denominator in 'qpcDiffTime'. + Just freq -> return $ Just SystemClock + { systemClockGetTime = do + m <- callQP c_QueryPerformanceCounter + case m of + Just t -> return t + Nothing -> fail "QueryPerformanceCounter failed,\ + \ even though QueryPerformanceFrequency\ + \ succeeded earlier" + , systemClockDiffTime = qpcDiffTime freq + , systemClockName = "QueryPerformanceCounter" + } + +callQP :: QPFunc -> IO (Maybe Int64) +callQP qpfunc = + allocaBytes #{size LARGE_INTEGER} $ \ptr -> do + ok <- qpfunc ptr + if ok /= 0 + then do + n <- #{peek LARGE_INTEGER, QuadPart} ptr + return (Just n) + else return Nothing + +type QPFunc = Ptr Int64 -> IO #{type BOOL} + +foreign import stdcall "Windows.h QueryPerformanceFrequency" + c_QueryPerformanceFrequency :: QPFunc + +foreign import stdcall "Windows.h QueryPerformanceCounter" + c_QueryPerformanceCounter :: QPFunc + +#else + +type Time_t = #{type time_t} + +data CTimeSpec = CTimeSpec + { tv_sec :: !Time_t + -- ^ seconds + , tv_nsec :: !CLong + -- ^ nanoseconds. 1 second = 10^9 nanoseconds + } + +diffCTimeSpec :: CTimeSpec -> CTimeSpec -> DiffTime +diffCTimeSpec a b + = diffCTime (tv_sec a) (tv_sec b) + + fromIntegral (tv_nsec a - tv_nsec b) / 1000000000 + +diffCTime :: Time_t -> Time_t -> DiffTime +diffCTime a b + | isSigned a = fromIntegral (a - b) + | otherwise = error "System.Time.Monotonic.Direct: time_t is unsigned" + -- time_t is supposed to be signed on POSIX systems. + -- If a is earlier than b, unsigned subtraction will produce an + -- enormous result. + +peekCTimeSpec :: Ptr CTimeSpec -> IO CTimeSpec +peekCTimeSpec ptr = do + sec <- #{peek struct timespec, tv_sec} ptr + nsec <- #{peek struct timespec, tv_nsec} ptr + return CTimeSpec { tv_sec = sec + , tv_nsec = nsec + } + +-- | Uses @clock_gettime@ with @CLOCK_MONOTONIC@. +-- +-- /Warning:/ on Linux, this clock stops when the computer is suspended. +-- See . +systemClock_MONOTONIC :: SystemClock CTimeSpec +systemClock_MONOTONIC = + SystemClock + { systemClockGetTime = clock_gettime #{const CLOCK_MONOTONIC} + , systemClockDiffTime = diffCTimeSpec + , systemClockName = "clock_gettime(CLOCK_MONOTONIC)" + } + +-- CLOCK_MONOTONIC_RAW is more reliable, but requires +-- a recent kernel and glibc. +-- +-- -- | @clock_gettime(CLOCK_MONOTONIC_RAW)@ +-- systemClock_MONOTONIC_RAW :: SystemClock CTimeSpec +-- systemClock_MONOTONIC_RAW = +-- SystemClock +-- { systemClockGetTime = clock_gettime #{const CLOCK_MONOTONIC_RAW} +-- , systemClockDiffTime = diffCTimeSpec +-- , systemClockName = "clock_gettime(CLOCK_MONOTONIC_RAW)" +-- } + +clock_gettime :: #{type clockid_t} -> IO CTimeSpec +clock_gettime clk_id = + allocaBytes #{size struct timespec} $ \ptr -> do + throwErrnoIfMinus1_ "clock_gettime" $ + c_clock_gettime clk_id ptr + peekCTimeSpec ptr + +foreign import ccall "time.h clock_gettime" + c_clock_gettime :: #{type clockid_t} + -> Ptr CTimeSpec + -> IO CInt + +#endif diff --git a/cbits/dll.c b/cbits/dll.c new file mode 100644 --- /dev/null +++ b/cbits/dll.c @@ -0,0 +1,10 @@ +#include + +typedef ULONGLONG (WINAPI *GetTickCount64_t)(void); + +GetTickCount64_t system_time_monotonic_load_GetTickCount64(void) +{ + return (GetTickCount64_t) + GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")), + "GetTickCount64"); +} diff --git a/system-time-monotonic.cabal b/system-time-monotonic.cabal new file mode 100644 --- /dev/null +++ b/system-time-monotonic.cabal @@ -0,0 +1,54 @@ +name: system-time-monotonic +version: 0.1 +synopsis: Simple library for using the system's monotonic clock +description: + Simple library for using the system's monotonic clock. This library is + geared toward programs that need to run for long periods of time. It does + not (necessarily) provide high-resolution timing. + . + * On Windows, this uses @GetTickCount64@, but falls back to + @GetTickCount@ if it is not available. @GetTickCount64@ was + introduced in Windows Vista and Windows Server 2008. + Support for @QueryPerformanceCounter@ is also available, but is not + used by default, as it is less accurate in the long run than + @GetTickCount@. + . + * On Linux, this uses @clock_gettime@ with @CLOCK_MONOTONIC@. +homepage: https://github.com/joeyadams/haskell-system-time-monotonic +license: BSD3 +license-file: LICENSE +author: Joey Adams +maintainer: joeyadams3.14159@gmail.com +copyright: Copyright (c) Joseph Adams 2012 +category: System +build-type: Simple +cabal-version: >=1.8 + +extra-source-files: + testing/benchmark.hs + testing/bombard.hs + testing/clock.hs + testing/delay.hs + testing/diffCTimeSpec.hs + testing/diffMSec32.hs + testing/leak.hs + +source-repository head + type: git + location: git://github.com/joeyadams/haskell-system-time-monotonic.git + +library + exposed-modules: + System.Time.Monotonic + System.Time.Monotonic.Direct + + build-tools: hsc2hs + + ghc-options: -Wall -fwarn-tabs + + if os(windows) { + c-sources: cbits/dll.c + } + + build-depends : base == 4.* + , time diff --git a/testing/benchmark.hs b/testing/benchmark.hs new file mode 100644 --- /dev/null +++ b/testing/benchmark.hs @@ -0,0 +1,12 @@ +import System.Time.Monotonic +import Criterion.Main + +main :: IO () +main = do + clock <- newClock + putStrLn $ "Using " ++ clockDriverName clock + + defaultMain + [ bench "newClock" newClock + , bench "clockGetTime" (clockGetTime clock) + ] diff --git a/testing/bombard.hs b/testing/bombard.hs new file mode 100644 --- /dev/null +++ b/testing/bombard.hs @@ -0,0 +1,18 @@ +-- Bombard a 'Clock' with 'clockGetTime' calls, to make sure this does not +-- degrade its accuracy. + +import System.Time.Monotonic +import Control.Concurrent (forkOS) +import Control.Monad (forever) + +main :: IO () +main = do + clock <- newClock + putStrLn $ "Using " ++ clockDriverName clock + _ <- forkOS $ forever $ clockGetTime clock + _ <- forkOS $ forever $ clockGetTime clock + _ <- forkOS $ forever $ clockGetTime clock + forever $ do + print =<< clockGetTime clock + _ <- getLine + return () diff --git a/testing/clock.hs b/testing/clock.hs new file mode 100644 --- /dev/null +++ b/testing/clock.hs @@ -0,0 +1,11 @@ +import System.Time.Monotonic +import Control.Monad (forever) + +main :: IO () +main = do + clock <- newClock + putStrLn $ "Using " ++ clockDriverName clock + forever $ do + print =<< clockGetTime clock + _ <- getLine + return () diff --git a/testing/delay.hs b/testing/delay.hs new file mode 100644 --- /dev/null +++ b/testing/delay.hs @@ -0,0 +1,29 @@ +import System.Time.Monotonic + +main :: IO () +main = do + clock <- newClock + putStrLn $ "Using " ++ clockDriverName clock + + print =<< clockGetTime clock + + delay 0.5 + print =<< clockGetTime clock + + t0 <- clockGetTime clock + delay 0.01 + t1 <- clockGetTime clock + delay 0.02 + t2 <- clockGetTime clock + delay 0.001 + t3 <- clockGetTime clock + print (t0, t1, t2, t3) + + putStrLn "Waiting -1 seconds (should do nothing)" + delay (-1) + + putStrLn "Waiting 105 seconds" + delay 105 + print =<< clockGetTime clock + + putStrLn "Done." diff --git a/testing/diffCTimeSpec.hs b/testing/diffCTimeSpec.hs new file mode 100644 --- /dev/null +++ b/testing/diffCTimeSpec.hs @@ -0,0 +1,35 @@ +import System.Time.Monotonic.Direct +import Data.Time.Clock (DiffTime) + +test :: DiffTime -> CTimeSpec -> CTimeSpec -> IO Bool +test expected new old = + return $ diffCTimeSpec new old == expected + && diffCTimeSpec old new == -expected + +main :: IO () +main = do + True <- test 0.000000001 + (CTimeSpec 100 999999999) + (CTimeSpec 100 999999998) + + True <- test 0.000000002 + (CTimeSpec 101 1) + (CTimeSpec 100 999999999) + + True <- test 0.000000002 + (CTimeSpec minBound 1) + (CTimeSpec maxBound 999999999) + + True <- test 1.999999998 + (CTimeSpec minBound 999999999) + (CTimeSpec maxBound 1) + + True <- test 1.0 + (CTimeSpec minBound 0) + (CTimeSpec maxBound 0) + + True <- test 0.0 + (CTimeSpec 0 0) + (CTimeSpec 0 0) + + putStrLn "All tests passed" diff --git a/testing/diffMSec32.hs b/testing/diffMSec32.hs new file mode 100644 --- /dev/null +++ b/testing/diffMSec32.hs @@ -0,0 +1,25 @@ +import System.Time.Monotonic.Direct +import Data.Word (Word32) +import Data.Time.Clock (DiffTime) + +test :: DiffTime -> Word32 -> Word32 -> IO Bool +test expected new old = + return $ diffMSec32 new old == expected + && diffMSec32 old new == -expected + +main :: IO () +main = do + True <- test 0 100 100 + True <- test 0 0 0 + True <- test 0 maxBound maxBound + + True <- test 0.001 101 100 + True <- test (-0.001) 100 101 + + True <- test 2000000 3000000000 1000000000 + True <- test (-2000000) 1000000000 3000000000 + + True <- test 0.001 minBound maxBound + True <- test (-0.001) maxBound minBound + + putStrLn "All tests passed" diff --git a/testing/leak.hs b/testing/leak.hs new file mode 100644 --- /dev/null +++ b/testing/leak.hs @@ -0,0 +1,8 @@ +import System.Time.Monotonic +import Control.Monad (forever) + +main :: IO () +main = do + clock <- newClock + putStrLn $ "Using " ++ clockDriverName clock + forever $ clockGetTime clock