clock 0.3 → 0.8.4
raw patch · 11 files changed
Files
- CHANGELOG.md +7/−0
- LICENSE +1/−2
- System/Clock.hs +0/−117
- System/Clock.hsc +332/−0
- System/Clock/Seconds.hs +77/−0
- bench/benchmarks.hs +26/−0
- cbits/hs_clock_win32.c +118/−0
- clock.cabal +102/−19
- csec/clock.c +0/−192
- csec/clock.h +0/−9
- tests/test.hs +109/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# 0.8.3++- Dropped support for GHC < 7.8.+- Tested with GHC 7.8 - 9.2.+- TODO: new module `System.Clock.Seconds`+- TODO: new functions+- TODO: other changes
LICENSE view
@@ -1,5 +1,4 @@-Copyright (c) 2009-2012, Cetin Sert-Copyright (c) 2010, Eugene Kirpichov+Copyright (c) 2009-2022, Clock Contributors All rights reserved.
− System/Clock.hs
@@ -1,117 +0,0 @@--- | High-resolution, realtime clock and timer functions for Posix--- systems. This module is being developed according to IEEE Std--- 1003.1-2008: <http://www.opengroup.org/onlinepubs/9699919799/>,--- <http://www.opengroup.org/onlinepubs/9699919799/functions/clock_getres.html#>--module System.Clock (-- Clock (Monotonic, Realtime, ProcessCPUTime, ThreadCPUTime),- TimeSpec (TimeSpec),-- getTime,- getRes,-- sec,- nsec--) where--import Foreign.Ptr-import Foreign.Storable-import Foreign.Marshal.Alloc-import Control.Applicative---- | Clock types.--- A clock may be system-wide (that is, visible to all processes)--- or per-process (measuring time that is meaningful only within--- a process). All implementations shall support CLOCK_REALTIME.-data Clock = Monotonic -- ^ The identifier for the system-wide monotonic clock, which is defined as a clock measuring real time, whose value cannot be set via clock_settime and which cannot have negative clock jumps. The maximum possible clock jump shall be implementation-defined. For this clock, the value returned by 'getTime' represents the amount of time (in seconds and nanoseconds) since an unspecified point in the past (for example, system start-up time, or the Epoch). This point does not change after system start-up time. Note that the absolute value of the monotonic clock is meaningless (because its origin is arbitrary), and thus there is no need to set it. Furthermore, realtime applications can rely on the fact that the value of this clock is never set.- | Realtime -- ^ The identifier of the system-wide clock measuring real time. For this clock, the value returned by getTime represents the amount of time (in seconds and nanoseconds) since the Epoch.- | ProcessCPUTime -- ^ The identifier of the CPU-time clock associated with the calling process. For this clock, the value returned by getTime represents the amount of execution time of the current process.- | ThreadCPUTime -- ^ The identifier of the CPU-time clock associated with the calling OS thread. For this clock, the value returned by getTime represents the amount of execution time of the current OS thread.---- | TimeSpec structure-data TimeSpec = TimeSpec {-# UNPACK #-} !Int -- seconds- {-# UNPACK #-} !Int -- nanoseconds- deriving (Show, Read, Eq)---- | Gets seconds of a timespec value.-sec :: TimeSpec -> Int--- | Gets nanoseconds of a timespec value.-nsec :: TimeSpec -> Int--sec (TimeSpec s _) = s-nsec (TimeSpec _ n) = n--instance Storable TimeSpec where- sizeOf _ = sizeOf (0 :: Int) * 2- alignment _ = 1- poke t v = do- let i :: Ptr Int = castPtr t- i |^ 0 $! sec v- i |^ 1 $! nsec v- peek t = do- let i :: Ptr Int = castPtr t- TimeSpec <$> i |. 0 <*> i |. 1--instance Ord TimeSpec where- compare (TimeSpec xs xn) (TimeSpec ys yn) = - if xs > ys then GT- else if xs < ys then LT- else if xn > yn then GT- else if xn < yn then LT- else EQ---- | The 'getTime' function shall return the current value for the--- specified clock.-getTime :: Clock -> IO TimeSpec-getTime = call . time---- | The 'getRes' function shall return the resolution of any clock.--- Clock resolutions are implementation-defined and cannot be set--- by a process.-getRes :: Clock -> IO TimeSpec-getRes = call . res--------------------------------------------------- Reader function-type ReaderFunc = Ptr TimeSpec -> IO ()---- Readers-foreign import ccall clock_readtime_monotonic :: ReaderFunc-foreign import ccall clock_readtime_realtime :: ReaderFunc-foreign import ccall clock_readtime_processtime :: ReaderFunc-foreign import ccall clock_readtime_threadtime :: ReaderFunc--foreign import ccall clock_readres_monotonic :: ReaderFunc-foreign import ccall clock_readres_realtime :: ReaderFunc-foreign import ccall clock_readres_processtime :: ReaderFunc-foreign import ccall clock_readres_threadtime :: ReaderFunc---- Clock-to-time reading-time :: Clock -> ReaderFunc-time Monotonic = clock_readtime_monotonic-time Realtime = clock_readtime_realtime-time ProcessCPUTime = clock_readtime_processtime-time ThreadCPUTime = clock_readtime_threadtime---- Clock-to-res reading-res :: Clock -> ReaderFunc-res Monotonic = clock_readres_monotonic-res Realtime = clock_readres_realtime-res ProcessCPUTime = clock_readres_processtime-res ThreadCPUTime = clock_readres_threadtime---- Marshalling-call :: ReaderFunc -> IO TimeSpec-call read_ = do- x <- malloc- read_ x- t <- peek x- free x- return t---- Allocation and pointer operations-{-# INLINE (|.) #-}; (|.)::Storable a=>Ptr a -> Int -> IO a ; (|.) a i = peekElemOff a i-{-# INLINE (|^) #-}; (|^)::Storable a=>Ptr a -> Int -> a -> IO (); (|^) a i v = pokeElemOff a i v
+ System/Clock.hsc view
@@ -0,0 +1,332 @@+-- | High-resolution, realtime clock and timer functions for Posix+-- systems. This module is being developed according to IEEE Std+-- 1003.1-2008: <http://www.opengroup.org/onlinepubs/9699919799/>,+-- <http://www.opengroup.org/onlinepubs/9699919799/functions/clock_getres.html#>++{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- To allow importing Data.Int and Data.Word indiscriminately on all platforms,+-- since we can't systematically predict what typedef's expand to.+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module System.Clock+ ( Clock(..)+ , TimeSpec(..)+ , getTime+ , getRes+ , fromNanoSecs+ , toNanoSecs+ , diffTimeSpec+ , timeSpecAsNanoSecs+ , normalize+ , s2ns+ ) where++import Control.Applicative ((<$>), (<*>))+import Data.Int+import Data.Word+import Data.Ratio+import Data.Typeable (Typeable)+import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import GHC.Generics (Generic)++#if defined(_WIN32)+# include "hs_clock_win32.c"+# define HS_CLOCK_HAVE_PROCESS_CPUTIME+# define HS_CLOCK_HAVE_THREAD_CPUTIME+#else+# include <time.h>+# ifdef CLOCK_PROCESS_CPUTIME_ID+# define HS_CLOCK_HAVE_PROCESS_CPUTIME+# endif+# ifdef CLOCK_THREAD_CPUTIME_ID+# define HS_CLOCK_HAVE_THREAD_CPUTIME+# endif+import System.Posix.Types+#endif++#if __GLASGOW_HASKELL__ < 800+# let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#endif++-- | Clock types. A clock may be system-wide (that is, visible to all processes)+-- or per-process (measuring time that is meaningful only within a process).+-- All implementations shall support 'Realtime'.+data Clock++ -- | The identifier for the system-wide monotonic clock, which is defined as+ -- a clock measuring real time, whose value cannot be set via+ -- @clock_settime@ and which cannot have negative clock jumps. The maximum+ -- possible clock jump shall be implementation defined. For this clock,+ -- the value returned by 'getTime' represents the amount of time (in+ -- seconds and nanoseconds) since an unspecified point in the past (for+ -- example, system start-up time, or the Epoch). This point does not+ -- change after system start-up time. Note that the absolute value of the+ -- monotonic clock is meaningless (because its origin is arbitrary), and+ -- thus there is no need to set it. Furthermore, realtime applications can+ -- rely on the fact that the value of this clock is never set.+ -- (Identical to 'Boottime' since Linux 4.17, see https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/commit/?id=d6ed449afdb38f89a7b38ec50e367559e1b8f71f)+ -- @CLOCK_MONOTONIC@ (macOS - @SYSTEM_CLOCK@)+ = Monotonic++ -- | The identifier of the system-wide clock measuring real time. For this+ -- clock, the value returned by 'getTime' represents the amount of time (in+ -- seconds and nanoseconds) since the Epoch.+ -- @CLOCK_REALTIME@ (macOS - @CALENDAR_CLOCK@, Windows - @GetSystemTimeAsFileTime@)+ | Realtime++#ifdef HS_CLOCK_HAVE_PROCESS_CPUTIME+ -- | The identifier of the CPU-time clock associated with the calling+ -- process. For this clock, the value returned by 'getTime' represents the+ -- amount of execution time of the current process.+ | ProcessCPUTime+#endif++#ifdef HS_CLOCK_HAVE_THREAD_CPUTIME+ -- | The identifier of the CPU-time clock associated with the calling OS+ -- thread. For this clock, the value returned by 'getTime' represents the+ -- amount of execution time of the current OS thread.+ | ThreadCPUTime+#endif++#if defined (CLOCK_MONOTONIC_RAW)+ -- | (since Linux 2.6.28, macOS 10.12)+ -- Similar to 'Monotonic', but provides access to a+ -- raw hardware-based time that is not subject to NTP+ -- adjustments or the incremental adjustments performed by+ -- adjtime(3).+ -- @CLOCK_MONOTONIC_RAW@ (Windows - @QueryPerformanceCounter@, @QueryPerformanceFrequency@)+ | MonotonicRaw+#endif++#if defined (CLOCK_BOOTTIME)+ -- | (since Linux 2.6.39; Linux-specific)+ -- Identical to `Monotonic`, except it also includes+ -- any time that the system is suspended. This allows+ -- applications to get a suspend-aware monotonic clock+ -- without having to deal with the complications of 'Realtime',+ -- which may have discontinuities if the time is changed+ -- using settimeofday(2).+ -- (since Linux 4.17; identical to 'Monotonic')+ -- @CLOCK_BOOTTIME@+ | Boottime+#endif++#if defined (CLOCK_MONOTONIC_COARSE)+ -- | (since Linux 2.6.32; Linux-specific)+ -- A faster but less precise version of 'Monotonic'.+ -- Use when you need very fast, but not fine-grained timestamps.+ -- @CLOCK_MONOTONIC_COARSE@+ | MonotonicCoarse+#endif++#if defined (CLOCK_REALTIME_COARSE)+ -- | (since Linux 2.6.32; Linux-specific)+ -- A faster but less precise version of 'Realtime'.+ -- Use when you need very fast, but not fine-grained timestamps.+ -- @CLOCK_REALTIME_COARSE@+ | RealtimeCoarse+#endif++ deriving (Eq, Enum, Generic, Read, Show, Typeable)++#if defined(_WIN32)+foreign import ccall unsafe hs_clock_win32_gettime_monotonic :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_gettime_realtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_gettime_processtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_gettime_threadtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_getres_monotonic :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_getres_realtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_getres_processtime :: Ptr TimeSpec -> IO ()+foreign import ccall unsafe hs_clock_win32_getres_threadtime :: Ptr TimeSpec -> IO ()+#else+#if MIN_VERSION_base(4,10,0)+type ClockId = CClockId+#else+type ClockId = #{type clockid_t}+#endif++foreign import ccall unsafe clock_gettime :: ClockId -> Ptr TimeSpec -> IO CInt+foreign import ccall unsafe clock_getres :: ClockId -> Ptr TimeSpec -> IO CInt++foreign import capi unsafe "time.h value CLOCK_MONOTONIC" clock_MONOTONIC :: ClockId+foreign import capi unsafe "time.h value CLOCK_REALTIME" clock_REALTIME :: ClockId+#if defined (CLOCK_PROCESS_CPUTIME_ID)+foreign import capi unsafe "time.h value CLOCK_PROCESS_CPUTIME_ID" clock_PROCESS_CPUTIME_ID :: ClockId+#endif+#if defined (CLOCK_THREAD_CPUTIME_ID)+foreign import capi unsafe "time.h value CLOCK_THREAD_CPUTIME_ID" clock_THREAD_CPUTIME_ID :: ClockId+#endif+#if defined (CLOCK_MONOTONIC_RAW)+foreign import capi unsafe "time.h value CLOCK_MONOTONIC_RAW" clock_MONOTONIC_RAW :: ClockId+#endif+#if defined (CLOCK_BOOTTIME)+foreign import capi unsafe "time.h value CLOCK_BOOTTIME" clock_BOOTTIME :: ClockId+#endif+#if defined (CLOCK_MONOTONIC_COARSE)+foreign import capi unsafe "time.h value CLOCK_MONOTONIC_COARSE" clock_MONOTONIC_COARSE :: ClockId+#endif+#if defined (CLOCK_REALTIME_COARSE)+foreign import capi unsafe "time.h value CLOCK_REALTIME_COARSE" clock_REALTIME_COARSE :: ClockId+#endif+#endif++#if !defined(_WIN32)+clockToConst :: Clock -> ClockId+clockToConst Monotonic = clock_MONOTONIC+clockToConst Realtime = clock_REALTIME+#if defined (CLOCK_PROCESS_CPUTIME_ID)+clockToConst ProcessCPUTime = clock_PROCESS_CPUTIME_ID+#endif+#if defined (CLOCK_THREAD_CPUTIME_ID)+clockToConst ThreadCPUTime = clock_THREAD_CPUTIME_ID+#endif+#if defined (CLOCK_MONOTONIC_RAW)+clockToConst MonotonicRaw = clock_MONOTONIC_RAW+#endif+#if defined (CLOCK_BOOTTIME)+clockToConst Boottime = clock_BOOTTIME+#endif+#if defined (CLOCK_MONOTONIC_COARSE)+clockToConst MonotonicCoarse = clock_MONOTONIC_COARSE+#endif+#if defined (CLOCK_REALTIME_COARSE)+clockToConst RealtimeCoarse = clock_REALTIME_COARSE+#endif+#endif++allocaAndPeek :: Storable a => (Ptr a -> IO ()) -> IO a+allocaAndPeek f = alloca $ \ptr -> f ptr >> peek ptr++-- | The 'getTime' function shall return the current value for the+-- specified clock.+getTime :: Clock -> IO TimeSpec++-- | The 'getRes' function shall return the resolution of any clock.+-- Clock resolutions are implementation-defined and cannot be set+-- by a process.+getRes :: Clock -> IO TimeSpec++#if defined(_WIN32)+getTime Monotonic = allocaAndPeek hs_clock_win32_gettime_monotonic+getTime Realtime = allocaAndPeek hs_clock_win32_gettime_realtime+getTime ProcessCPUTime = allocaAndPeek hs_clock_win32_gettime_processtime+getTime ThreadCPUTime = allocaAndPeek hs_clock_win32_gettime_threadtime+#else+getTime clk = allocaAndPeek $! throwErrnoIfMinus1_ "clock_gettime" . clock_gettime (clockToConst clk)+#endif++#if defined(_WIN32)+getRes Monotonic = allocaAndPeek hs_clock_win32_getres_monotonic+getRes Realtime = allocaAndPeek hs_clock_win32_getres_realtime+getRes ProcessCPUTime = allocaAndPeek hs_clock_win32_getres_processtime+getRes ThreadCPUTime = allocaAndPeek hs_clock_win32_getres_threadtime+#else+getRes clk = allocaAndPeek $! throwErrnoIfMinus1_ "clock_getres" . clock_getres (clockToConst clk)+#endif++-- | TimeSpec structure+data TimeSpec = TimeSpec+ { sec :: {-# UNPACK #-} !Int64 -- ^ seconds+ , nsec :: {-# UNPACK #-} !Int64 -- ^ nanoseconds+ } deriving (Generic, Read, Show, Typeable)++#if defined(_WIN32)+instance Storable TimeSpec where+ sizeOf _ = sizeOf (undefined :: Int64) * 2+ alignment _ = alignment (undefined :: Int64)+ poke ptr ts = do+ pokeByteOff ptr 0 (sec ts)+ pokeByteOff ptr (sizeOf (undefined :: Int64)) (nsec ts)+ peek ptr = do+ TimeSpec+ <$> peekByteOff ptr 0+ <*> peekByteOff ptr (sizeOf (undefined :: Int64))+#else+instance Storable TimeSpec where+ sizeOf _ = #{size struct timespec}+ alignment _ = #{alignment struct timespec}+ poke ptr ts = do+ let xs :: #{type time_t} = fromIntegral $ sec ts+ xn :: #{type long} = fromIntegral $ nsec ts+ #{poke struct timespec, tv_sec} ptr (xs)+ #{poke struct timespec, tv_nsec} ptr (xn)+ peek ptr = do+ xs :: #{type time_t} <- #{peek struct timespec, tv_sec} ptr+ xn :: #{type long} <- #{peek struct timespec, tv_nsec} ptr+ return $ TimeSpec (fromIntegral xs) (fromIntegral xn)+#endif++s2ns :: Num a => a+s2ns = 10^9++normalize :: TimeSpec -> TimeSpec+normalize (TimeSpec xs xn) | xn < 0 || xn >= s2ns = TimeSpec (xs + q) r+ | otherwise = TimeSpec xs xn+ where (q, r) = xn `divMod` s2ns++instance Num TimeSpec where+ (TimeSpec xs xn) + (TimeSpec ys yn) = normalize $! TimeSpec (xs + ys) (xn + yn)+ (TimeSpec xs xn) - (TimeSpec ys yn) = normalize $! TimeSpec (xs - ys) (xn - yn)+ (normalize -> TimeSpec xs xn) * (normalize -> TimeSpec ys yn) = normalize $! TimeSpec (s2ns*xs*ys+xs*yn+xn*ys) (xn*yn)+ negate (TimeSpec xs xn) = normalize $! TimeSpec (negate xs) (negate xn)+ abs (normalize -> TimeSpec xs xn) | xs == 0 = normalize $! TimeSpec 0 xn+ | otherwise = normalize $! TimeSpec (abs xs) (signum xs * xn)+ signum (normalize -> TimeSpec xs xn) | xs == 0 = TimeSpec 0 (signum xn)+ | otherwise = TimeSpec 0 (signum xs)+ fromInteger x = TimeSpec (fromInteger q) (fromInteger r) where (q, r) = x `divMod` s2ns++instance Enum TimeSpec where+ succ x = x + 1+ pred x = x - 1+ toEnum x = normalize $ TimeSpec 0 (fromIntegral x)+ fromEnum = fromEnum . toInteger++instance Real TimeSpec where+ toRational x = toInteger x % 1++instance Integral TimeSpec where+ toInteger = toNanoSecs+ quot (toInteger-> t1) (toInteger-> t2) = fromInteger $! quot t1 t2+ rem (toInteger-> t1) (toInteger-> t2) = fromInteger $! rem t1 t2+ div (toInteger-> t1) (toInteger-> t2) = fromInteger $! div t1 t2+ mod (toInteger-> t1) (toInteger-> t2) = fromInteger $! mod t1 t2+ divMod (toInteger-> t1) (toInteger-> t2) =+ let (q,r)=divMod t1 t2 in (fromInteger $! q, fromInteger $! r)+ quotRem (toInteger-> t1) (toInteger-> t2) =+ let (q,r)=quotRem t1 t2 in (fromInteger $! q, fromInteger $! r)++instance Eq TimeSpec where+ (normalize -> TimeSpec xs xn) == (normalize -> TimeSpec ys yn) | True == es = xn == yn+ | otherwise = es+ where es = xs == ys++instance Ord TimeSpec where+ compare (normalize -> TimeSpec xs xn) (normalize -> TimeSpec ys yn) | EQ == os = compare xn yn+ | otherwise = os+ where os = compare xs ys++instance Bounded TimeSpec where+ minBound = TimeSpec minBound 0+ maxBound = TimeSpec maxBound (s2ns-1)++-- | TimeSpec from nano seconds.+fromNanoSecs :: Integer -> TimeSpec+fromNanoSecs x = TimeSpec (fromInteger q) (fromInteger r) where (q, r) = x `divMod` s2ns+++-- | TimeSpec to nano seconds.+toNanoSecs :: TimeSpec -> Integer+toNanoSecs (TimeSpec (toInteger -> s) (toInteger -> n)) = s * s2ns + n++-- | Compute the absolute difference.+diffTimeSpec :: TimeSpec -> TimeSpec -> TimeSpec+diffTimeSpec ts1 ts2 = abs (ts1 - ts2)++{-# DEPRECATED timeSpecAsNanoSecs "Use toNanoSecs instead! Replaced timeSpecAsNanoSecs with the same signature TimeSpec -> Integer" #-}+-- | TimeSpec as nano seconds.+timeSpecAsNanoSecs :: TimeSpec -> Integer+timeSpecAsNanoSecs (TimeSpec s n) = toInteger s * s2ns + toInteger n
+ System/Clock/Seconds.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module System.Clock.Seconds+ ( Clock(..)+ , Seconds(..)+ , getTime+ , getRes+ , fromNanoSecs+ , toNanoSecs+ , diffTimeSpec+ ) where++import Data.Coerce+import Data.Ratio+import Data.Typeable (Typeable)+import Foreign.Storable+import GHC.Generics (Generic)++import System.Clock(TimeSpec(..), Clock, s2ns, normalize)+import qualified System.Clock as C++newtype Seconds = Seconds { toTimeSpec :: TimeSpec }+ deriving (Generic, Read, Show, Typeable, Eq, Ord, Storable, Bounded)++instance Num Seconds where+ fromInteger n = Seconds $ TimeSpec (fromInteger n) 0+ Seconds (TimeSpec xs xn) * Seconds (TimeSpec ys yn) =+ Seconds $ normalize $! TimeSpec (xs*ys) (xs*yn+xn*ys+((xn*yn) `div` s2ns))+ (+) = coerce ((+) :: TimeSpec -> TimeSpec -> TimeSpec)+ (-) = coerce ((-) :: TimeSpec -> TimeSpec -> TimeSpec)+ negate = coerce (negate :: TimeSpec -> TimeSpec)+ abs = coerce (abs :: TimeSpec -> TimeSpec)+ signum (Seconds a) = case signum a of+ 1 -> 1+ (-1) -> (-1)+ _ -> 0++instance Enum Seconds where+ succ x = x + 1+ pred x = x - 1+ toEnum x = Seconds $ TimeSpec (fromIntegral x) 0+ fromEnum (Seconds (TimeSpec s _)) = fromEnum s++instance Real Seconds where+ toRational (Seconds x) = toInteger x % s2ns++instance Fractional Seconds where+ fromRational x = Seconds . fromInteger $ floor (x * s2ns)+ Seconds a / Seconds b = Seconds $ a * s2ns `div` b+ recip (Seconds a) = Seconds $ s2ns * s2ns `div` a++instance RealFrac Seconds where+ properFraction (Seconds (TimeSpec s ns))+ | s >= 0 = (fromIntegral s, Seconds $ TimeSpec 0 ns)+ | otherwise = (fromIntegral (s+1), Seconds $ TimeSpec (-1) ns)++-- | The 'getTime' function shall return the current value for the+-- specified clock.+getTime :: Clock -> IO Seconds+getTime = coerce C.getTime++-- | The 'getRes' function shall return the resolution of any clock.+-- Clock resolutions are implementation-defined and cannot be set+-- by a process.+getRes :: Clock -> IO Seconds+getRes = coerce C.getRes++-- | Seconds from nano seconds.+fromNanoSecs :: Integer -> Seconds+fromNanoSecs = coerce C.fromNanoSecs++-- | Seconds to nano seconds.+toNanoSecs :: Seconds -> Integer+toNanoSecs = coerce C.toNanoSecs++-- | Compute the absolute difference.+diffTimeSpec :: Seconds -> Seconds -> Seconds+diffTimeSpec = coerce C.diffTimeSpec
+ bench/benchmarks.hs view
@@ -0,0 +1,26 @@+{-# language CPP #-}+module Main (main) where++import Criterion.Main+import System.Clock++#if MIN_VERSION_base(4,11,0)+import GHC.Clock+#endif++main :: IO ()+main = defaultMain [+ bgroup "getTime" [+ bench "Monotonic" $ whnfIO (getTime Monotonic)+ , bench "Realtime" $ whnfIO (getTime Realtime)+ , bench "ProcessCPUTime" $ whnfIO (getTime ProcessCPUTime)+ , bench "ThreadCPUTime" $ whnfIO (getTime ThreadCPUTime)+ , bench "MonotonicRaw" $ whnfIO (getTime MonotonicRaw)+ , bench "Boottime" $ whnfIO (getTime Boottime)+ , bench "MonotonicCoarse" $ whnfIO (getTime MonotonicCoarse)+ , bench "RealtimeCoarse" $ whnfIO (getTime RealtimeCoarse)+ ]+#if MIN_VERSION_base(4,11,0)+ , bench "GHC.Clock.getMonotonicTimeNSec" $ whnfIO getMonotonicTimeNSec+#endif+ ]
+ cbits/hs_clock_win32.c view
@@ -0,0 +1,118 @@+#ifdef _WIN32+#include <windows.h>++#if defined(_MSC_VER) || defined(_MSC_EXTENSIONS)+ #define U64(x) x##Ui64+#else+ #define U64(x) x##ULL+#endif++#define DELTA_EPOCH_IN_100NS U64(116444736000000000)++static long ticks_to_nanos(LONGLONG subsecond_time, LONGLONG frequency)+{+ return (long)((1e9 * subsecond_time) / frequency);+}++static ULONGLONG to_quad_100ns(FILETIME ft)+{+ ULARGE_INTEGER li;+ li.LowPart = ft.dwLowDateTime;+ li.HighPart = ft.dwHighDateTime;+ return li.QuadPart;+}++static void to_timespec_from_100ns(ULONGLONG t_100ns, long long *t)+{+ t[0] = (long)(t_100ns / 10000000UL);+ t[1] = 100*(long)(t_100ns % 10000000UL);+}++/* See https://ghc.haskell.org/trac/ghc/ticket/15094 */+#if defined(_WIN32) && !defined(_WIN64)+__attribute__((optimize("-fno-expensive-optimizations")))+#endif+void hs_clock_win32_gettime_monotonic(long long* t)+{+ LARGE_INTEGER time;+ static LARGE_INTEGER frequency;+ static int hasFreq = 0;++ QueryPerformanceCounter(&time);+ if (!hasFreq)+ {+ hasFreq = 1;+ QueryPerformanceFrequency(&frequency);+ }+ // seconds+ t[0] = time.QuadPart / frequency.QuadPart;+ // nanos =+ t[1] = ticks_to_nanos(time.QuadPart % frequency.QuadPart, frequency.QuadPart);+}++void hs_clock_win32_gettime_realtime(long long* t)+{+ FILETIME ft;+ ULONGLONG tmp;++ GetSystemTimeAsFileTime(&ft);++ tmp = to_quad_100ns(ft);+ tmp -= DELTA_EPOCH_IN_100NS;++ to_timespec_from_100ns(tmp, t);+}++void hs_clock_win32_gettime_processtime(long long* t)+{+ FILETIME creation_time, exit_time, kernel_time, user_time;+ ULONGLONG time;++ GetProcessTimes(GetCurrentProcess(), &creation_time, &exit_time, &kernel_time, &user_time);+ // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117++ time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time);+ to_timespec_from_100ns(time, t);+}++void hs_clock_win32_gettime_threadtime(long long* t)+{+ FILETIME creation_time, exit_time, kernel_time, user_time;+ ULONGLONG time;++ GetThreadTimes(GetCurrentThread(), &creation_time, &exit_time, &kernel_time, &user_time);+ // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117++ time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time);+ to_timespec_from_100ns(time, t);+}++void hs_clock_win32_getres_monotonic(long long* t)+{+ LARGE_INTEGER frequency;+ QueryPerformanceFrequency(&frequency);++ ULONGLONG resolution = U64(1000000000)/frequency.QuadPart;+ t[0] = resolution / U64(1000000000);+ t[1] = resolution % U64(1000000000);+}++void hs_clock_win32_getres_realtime(long long* t)+{+ t[0] = 0;+ t[1] = 100;+}++void hs_clock_win32_getres_processtime(long long* t)+{+ t[0] = 0;+ t[1] = 100;+}++void hs_clock_win32_getres_threadtime(long long* t)+{+ t[0] = 0;+ t[1] = 100;+}++#endif /* _WIN32 */
clock.cabal view
@@ -1,36 +1,79 @@+cabal-version: >= 1.10 name: clock-version: 0.3+version: 0.8.4 stability: stable synopsis: High-resolution clock functions: monotonic, realtime, cputime. description: A package for convenient access to high-resolution clock and- timer functions of different operating systems.+ timer functions of different operating systems via a unified API. .- POSIX layer was developed by Cetin Sert in 2009.+ POSIX code and surface API was developed by Cetin Sert in 2009. .- Windows layer was contributed by Eugene Kirpichov in 2010.+ Windows code was contributed by Eugene Kirpichov in 2010. .- Both layers share the same surface API.+ FreeBSD code was contributed by Finn Espen Gundersen on 2013-10-14. .+ OS X code was contributed by Gerolf Seitz on 2013-10-15.+ .+ Derived @Generic@, @Typeable@ and other instances for @Clock@ and @TimeSpec@ was contributed by Mathieu Boespflug on 2014-09-17.+ .+ Corrected dependency listing for @GHC < 7.6@ was contributed by Brian McKenna on 2014-09-30.+ .+ Windows code corrected by Dimitri Sabadie on 2015-02-09.+ .+ Added @timeSpecAsNanoSecs@ as observed widely-used by Chris Done on 2015-01-06, exported correctly on 2015-04-20.+ .+ Imported Control.Applicative operators correctly for Haskell Platform on Windows on 2015-04-21.+ .+ Unit tests and instance fixes by Christian Burger on 2015-06-25.+ .+ Removal of fromInteger : Integer -> TimeSpec by Cetin Sert on 2015-12-15.+ .+ New Linux-specific Clocks: MonotonicRaw, Boottime, MonotonicCoarse, RealtimeCoarse by Cetin Sert on 2015-12-15.+ .+ Reintroduction fromInteger : Integer -> TimeSpec by Cetin Sert on 2016-04-05.+ .+ Fixes for older Linux build failures introduced by new Linux-specific clocks by Mario Longobardi on 2016-04-18.+ .+ Refreshment release in 2019-04 after numerous contributions.+ .+ Refactoring for Windows, Mac implementation consistence by Alexander Vershilov on 2021-01-16.+ . [Version Scheme] Major-@/R/@-ewrite . New-@/F/@-unctionality . @/I/@-mprovementAndBugFixes . @/P/@-ackagingOnly . * @PackagingOnly@ changes are made for quality assurance reasons. -copyright: Copyright © Cetin Sert 2009-2012, Eugene Kirpichov 2010+copyright: Copyright © Cetin Sert 2009-2023, Eugene Kirpichov 2010, Finn Espen Gundersen 2013, Gerolf Seitz 2013, Mathieu Boespflug 2014 2015, Chris Done 2015, Dimitri Sabadie 2015, Christian Burger 2015, Mario Longobardi 2016, Alexander Vershilov 2021. license: BSD3 license-file: LICENSE-author: Cetin Sert <cetin@corsis.eu>, Corsis Research; Eugene Kirpichov <ekirpichov@gmail.com>-maintainer: Cetin Sert <cetin@corsis.eu>, Corsis Research-homepage: http://corsis.github.com/clock/-bug-reports: http://corsis.github.com/clock/issues+author: Cetin Sert <cetin@elefunc.com>, Elefunc, Inc.+maintainer: Cetin Sert <cetin@elefunc.com>, Elefunc, Inc.+homepage: https://github.com/corsis/clock+bug-reports: https://github.com/corsis/clock/issues category: System build-type: Simple-cabal-version: >= 1.6 +tested-with:+ GHC == 9.6.1+ GHC == 9.4.4+ GHC == 9.2.7+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2+ GHC == 7.10.3+ GHC == 7.8.4 +extra-source-files:+ CHANGELOG.md++ source-repository head type: git- location: git://github.com/corsis/clock.git+ location: https://github.com/corsis/clock.git flag llvm@@ -39,13 +82,53 @@ library- build-depends: base >= 2 && <= 5+ build-depends: base >= 4.7 && < 5+ exposed-modules: System.Clock- extensions: ForeignFunctionInterface ScopedTypeVariables- c-sources: csec/clock.c- include-dirs: csec- install-includes: clock.h- ghc-options: -O2 -Wall- + System.Clock.Seconds++ default-language: Haskell2010+ default-extensions: DeriveGeneric+ DeriveDataTypeable+ ForeignFunctionInterface+ ScopedTypeVariables+ ViewPatterns+ GeneralizedNewtypeDeriving+ if os(windows)+ c-sources: cbits/hs_clock_win32.c+ include-dirs: cbits+ ghc-options: -O3 -Wall+ if flag(llvm) ghc-options: -fllvm -optlo-O3+++test-suite test+ default-language: Haskell2010+ default-extensions: ScopedTypeVariables+ GeneralizedNewtypeDeriving+ StandaloneDeriving+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ tests+ main-is:+ test.hs+ build-depends:+ base+ , tasty >= 0.10+ , tasty-quickcheck+ , clock++benchmark benchmarks+ default-language: Haskell2010+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ bench+ main-is:+ benchmarks.hs+ build-depends:+ base+ , criterion+ , clock
− csec/clock.c
@@ -1,192 +0,0 @@-#include "clock.h"--#ifdef _WIN32--// ***********************-// ******** WIN32 ********-// ***********************--#include <windows.h>--#if defined(_MSC_VER) || defined(_MSC_EXTENSIONS)- #define U64(x) x##Ui64-#else- #define U64(x) x##ULL-#endif--#define DELTA_EPOCH_IN_100NS U64(116444736000000000)--long ticks_to_nanos(LONGLONG subsecond_time, LONGLONG frequency)-{- return (long)((1e9 * subsecond_time) / frequency);-}--ULONGLONG to_quad_100ns(FILETIME ft)-{- ULARGE_INTEGER li;- li.LowPart = ft.dwLowDateTime;- li.HighPart = ft.dwHighDateTime;- return li.QuadPart;-}--void to_timespec_from_100ns(ULONGLONG t_100ns, long *t)-{- t[0] = (long)(t_100ns / 10000000UL);- t[1] = 100*(long)(t_100ns % 10000000UL);-}--void clock_readtime_monotonic(long* t)-{- LARGE_INTEGER time;- LARGE_INTEGER frequency;- QueryPerformanceCounter(&time);- QueryPerformanceFrequency(&frequency);- // seconds- t[0] = time.QuadPart / frequency.QuadPart;- // nanos = - t[1] = ticks_to_nanos(time.QuadPart % frequency.QuadPart, frequency.QuadPart);-}--void clock_readtime_realtime(long* t)-{- FILETIME ft;- ULONGLONG tmp;-- GetSystemTimeAsFileTime(&ft);- - tmp = to_quad_100ns(ft);- tmp -= DELTA_EPOCH_IN_100NS; -- to_timespec_from_100ns(tmp, t);-}--void clock_readtime_processtime(long* t)-{- FILETIME creation_time, exit_time, kernel_time, user_time;- ULONGLONG time;-- GetProcessTimes(GetCurrentProcess(), &creation_time, &exit_time, &kernel_time, &user_time);- // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117-- time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time);- to_timespec_from_100ns(time, t);-}--void clock_readtime_threadtime(long* t)-{- FILETIME creation_time, exit_time, kernel_time, user_time;- ULONGLONG time;-- GetThreadTimes(GetCurrentThread(), &creation_time, &exit_time, &kernel_time, &user_time);- // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117-- time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time);- to_timespec_from_100ns(time, t);-}--void clock_readres_monotonic(long* t)-{- LARGE_INTEGER frequency;- QueryPerformanceFrequency(&frequency);-- ULONGLONG resolution = U64(1000000000)/frequency.QuadPart;- t[0] = resolution / U64(1000000000);- t[1] = resolution % U64(1000000000);-}--void clock_readres_realtime(long* t)-{- t[0] = 0;- t[1] = 100;-}--void clock_readres_processtime(long* t)-{- t[0] = 0;- t[1] = 100;-}--void clock_readres_threadtime(long* t)-{- t[0] = 0;- t[1] = 100;-}--#else // Not _WIN32--// ***********************-// ******** POSIX ********-// ***********************--#include <time.h>--void time_(clockid_t clock, long* t)-{-- clock_gettime(clock, (struct timespec*)t);--/*struct timespec a;-- clock_gettime(clock, &a);-- t[0] = a.tv_sec;- t[1] = a.tv_nsec;*/--}--void clock_readtime_monotonic(long* t)-{- time_(CLOCK_MONOTONIC, t);-}--void clock_readtime_realtime(long* t)-{- time_(CLOCK_REALTIME, t);-}--void clock_readtime_processtime(long* t)-{- time_(CLOCK_PROCESS_CPUTIME_ID , t);-}--void clock_readtime_threadtime(long* t)-{- time_(CLOCK_THREAD_CPUTIME_ID , t);-}---void res_(clockid_t clock, long* t)-{-- clock_getres(clock, (struct timespec*)t);--/*struct timespec a;-- clock_getres(clock, &a);-- t[0] = a.tv_sec;- t[1] = a.tv_nsec;*/--}--void clock_readres_monotonic(long* t)-{- res_(CLOCK_MONOTONIC, t);-}--void clock_readres_realtime(long* t)-{- res_(CLOCK_REALTIME, t);-}--void clock_readres_processtime(long* t)-{- res_(CLOCK_PROCESS_CPUTIME_ID , t);-}--void clock_readres_threadtime(long* t)-{- res_(CLOCK_THREAD_CPUTIME_ID , t);-}--#endif
− csec/clock.h
@@ -1,9 +0,0 @@-void clock_readtime_monotonic(long* t);-void clock_readtime_realtime(long* t);-void clock_readtime_processtime(long* t);-void clock_readtime_threadtime(long* t);--void clock_readres_monotonic(long* t);-void clock_readres_realtime(long* t);-void clock_readres_processtime(long* t);-void clock_readres_threadtime(long* t);
+ tests/test.hs view
@@ -0,0 +1,109 @@+import Test.Tasty+import Test.Tasty.QuickCheck as QuickCheck+import Data.Fixed+import Data.List+-- import Test.Tasty.HUnit as HUnit+import System.Clock+import System.Clock.Seconds as S++instance Arbitrary TimeSpec where+ arbitrary = do+ sec <- arbitrarySizedIntegral+ nan <- arbitrarySizedIntegral+ return $ TimeSpec sec nan++deriving instance Arbitrary Seconds++main = defaultMain (localOption (QuickCheckTests 100000) $ tests)++tests :: TestTree+tests = testGroup "All tests" [timeSpecTests, secondsTests]++timeSpecTests = testGroup "TimeSpec tests" [qcNumInstance (0 :: TimeSpec), qcRealInstance (0 :: TimeSpec), qcTimeSpec]+secondsTests = testGroup "Seconds tests" [qcNumInstance (0 :: S.Seconds), qcRealInstance (0 :: S.Seconds), qcSeconds]++qcNumInstance :: (Eq a, Num a, Arbitrary a, Show a) => a -> TestTree+qcNumInstance (s :: a) = testGroup "Num"+ [+ QuickCheck.testProperty "Associativity of (+)" $ \(x :: a) y z ->+ (x + y) + z == x + (y + z)+ , QuickCheck.testProperty "Commutativity of (+)" $ \(x :: a) y ->+ x + y == y + x+ , QuickCheck.testProperty "fromInteger 0 is the additive identity" $ \(x :: a) ->+ x + fromInteger 0 == x+ , QuickCheck.testProperty "negate gives the additive inverse" $ \(x :: a) ->+ x + negate x == fromInteger 0+ , QuickCheck.testProperty "fromInteger 1 is the multiplicative identity" $ \(x :: a) ->+ x * fromInteger 1 == x && fromInteger 1 * x == x+ , QuickCheck.testProperty "neg(neg(x)) = x" $ \(x :: a) ->+ negate (negate x) == x+ , QuickCheck.testProperty "x = abs(x) * signum(x)" $ \(x :: a) ->+ x == (abs x) * (signum x)+ ]++qcRealInstance :: (Real a, Arbitrary a, Show a) => a -> TestTree+qcRealInstance (s :: a) = testGroup "Real"+ [+ QuickCheck.testProperty "integer addition is correct" $ \ x y ->+ toRational (x + y) == toRational (fromInteger x + fromInteger y :: a)+ , QuickCheck.testProperty "integer subtraction is correct" $ \ x y ->+ toRational (x - y) == toRational (fromInteger x - fromInteger y :: a)+ , QuickCheck.testProperty "integer multiplication is correct" $ \ x y ->+ toRational (x * y) == toRational (fromInteger x * fromInteger y :: a)+ , QuickCheck.testProperty "random list of TimeSpecs is sorted like equivalent list of rationals" $ \(x :: [a]) ->+ map toRational (sort x) == sort (map toRational x)+ ]++qcTimeSpec :: TestTree+qcTimeSpec = testGroup "TimeSpec-specific"+ [+ -- fails with Seconds on 0.000000001 * -1.000000002 * -2.000000001+ QuickCheck.testProperty "Associativity of (*)" $ \(x :: TimeSpec) y z ->+ (x * y) * z == x * (y * z)+ -- fails with Seconds on [-0.999999999,0.000000001,-1.000000001]+ , QuickCheck.testProperty "Distributivity of (*) with respect to (+)" $ \(a :: TimeSpec) b c ->+ a * (b + c) == (a * b) + (a * c) && (b + c) * a == (b * a) + (c * a)+ , QuickCheck.testProperty "TimeSpec Quot-rem division equality" $ \(x :: TimeSpec) y ->+ y == 0 || x == y * quot x y + rem x y+ , QuickCheck.testProperty "TimeSpec Rem is within bounds" $ \(x :: TimeSpec) y ->+ let r = rem x y in y == 0 || r == fromInteger 0 || abs r < abs y+ , QuickCheck.testProperty "TimeSpec quotRem agrees with quot and rem" $ \(x :: TimeSpec) y ->+ let (q,r) = quotRem x y in+ y == 0 || (q == quot x y && r == rem x y)+ , QuickCheck.testProperty "TimeSpec Div-mod division equality" $ \(x :: TimeSpec) y ->+ y == 0 || x == y * div x y + mod x y+ , QuickCheck.testProperty "TimeSpec Mod is within bounds" $ \(x :: TimeSpec) y ->+ let r = mod x y in y == 0 || (r == fromInteger 0 || abs r < abs y)+ , QuickCheck.testProperty "TimeSpec divMod agrees with div and mod" $ \(x :: TimeSpec) y ->+ let (q,r) = divMod x y in+ y == 0 || (q == div x y && r == mod x y)+ , QuickCheck.testProperty "TimeSpec toInteger . fromInteger is the identity" $ \x ->+ x == toInteger (fromInteger x :: TimeSpec)+ , QuickCheck.testProperty "TimeSpec fromInteger . toInteger is the identity" $ \(x :: TimeSpec) ->+ x == fromInteger (toInteger x)+ , QuickCheck.testProperty "TimeSpec division agrees with Integer" $ \(x :: TimeSpec) y ->+ y == 0 || toInteger (x `div` y) == toInteger x `div` toInteger y+ , QuickCheck.testProperty "TimeSpec quot agrees with Integer" $ \(x :: TimeSpec) y ->+ y == 0 || toInteger (x `quot` y) == toInteger x `quot` toInteger y+ ]++qcSeconds :: TestTree+qcSeconds = testGroup "Seconds-specific"+ [+ QuickCheck.testProperty "Seconds multiplication is Nano multiplication" $ \x y ->+ let nano = toRational $ (x :: Nano) * (y :: Nano)+ seconds = toRational $ (realToFrac x) * (realToFrac y :: Seconds)+ in nano == seconds+ , QuickCheck.testProperty "Seconds truncate is Nano truncate" $ \(x :: Nano) ->+ let nano = truncate x :: Integer+ seconds = truncate (realToFrac x :: Seconds)+ in nano == seconds+ , QuickCheck.testProperty "Seconds / is Nano /" $ \(x :: Nano) (y :: Nano) ->+ let nano = toRational $ x / y+ seconds = toRational (realToFrac x / realToFrac y :: Seconds)+ in y == 0 || nano == seconds+ , QuickCheck.testProperty "Seconds recip is Nano recip" $ \(x :: Nano) ->+ let nano = toRational $ recip x+ seconds = toRational (recip $ realToFrac x :: Seconds)+ in x == 0 || nano == seconds+ ]