packages feed

system-time-monotonic (empty) → 0.1

raw patch · 13 files changed

+616/−0 lines, 13 filesdep +basedep +timesetup-changed

Dependencies added: base, time

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Time/Monotonic.hs view
@@ -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
+ System/Time/Monotonic/Direct.hsc view
@@ -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 <Windows.h>+#else+import Foreign.C+#include <time.h>+#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 <http://lwn.net/Articles/434239/>.+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
+ cbits/dll.c view
@@ -0,0 +1,10 @@+#include <windows.h>++typedef ULONGLONG (WINAPI *GetTickCount64_t)(void);++GetTickCount64_t system_time_monotonic_load_GetTickCount64(void)+{+    return (GetTickCount64_t)+        GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),+                       "GetTickCount64");+}
+ system-time-monotonic.cabal view
@@ -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
+ testing/benchmark.hs view
@@ -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)+        ]
+ testing/bombard.hs view
@@ -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 ()
+ testing/clock.hs view
@@ -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 ()
+ testing/delay.hs view
@@ -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."
+ testing/diffCTimeSpec.hs view
@@ -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"
+ testing/diffMSec32.hs view
@@ -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"
+ testing/leak.hs view
@@ -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