clock-0.8.4/ 0000755 0000000 0000000 00000000000 07346545000 011007 5 ustar 00 0000000 0000000 clock-0.8.4/CHANGELOG.md 0000644 0000000 0000000 00000000235 07346545000 012620 0 ustar 00 0000000 0000000 # 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
clock-0.8.4/LICENSE 0000644 0000000 0000000 00000002727 07346545000 012024 0 ustar 00 0000000 0000000 Copyright (c) 2009-2022, Clock Contributors
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.
* The names of contributors may not 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.
clock-0.8.4/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 012444 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
clock-0.8.4/System/ 0000755 0000000 0000000 00000000000 07346545000 012273 5 ustar 00 0000000 0000000 clock-0.8.4/System/Clock.hsc 0000644 0000000 0000000 00000032263 07346545000 014033 0 ustar 00 0000000 0000000 -- | High-resolution, realtime clock and timer functions for Posix
-- systems. This module is being developed according to IEEE Std
-- 1003.1-2008: ,
--
{-# 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
# 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
clock-0.8.4/System/Clock/ 0000755 0000000 0000000 00000000000 07346545000 013326 5 ustar 00 0000000 0000000 clock-0.8.4/System/Clock/Seconds.hs 0000644 0000000 0000000 00000004463 07346545000 015267 0 ustar 00 0000000 0000000 {-# 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
clock-0.8.4/bench/ 0000755 0000000 0000000 00000000000 07346545000 012066 5 ustar 00 0000000 0000000 clock-0.8.4/bench/benchmarks.hs 0000644 0000000 0000000 00000001445 07346545000 014543 0 ustar 00 0000000 0000000 {-# 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
]
clock-0.8.4/cbits/ 0000755 0000000 0000000 00000000000 07346545000 012113 5 ustar 00 0000000 0000000 clock-0.8.4/cbits/hs_clock_win32.c 0000644 0000000 0000000 00000005607 07346545000 015076 0 ustar 00 0000000 0000000 #ifdef _WIN32
#include
#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-0.8.4/clock.cabal 0000644 0000000 0000000 00000011027 07346545000 013067 0 ustar 00 0000000 0000000 cabal-version: >= 1.10
name: clock
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 via a unified API.
.
POSIX code and surface API was developed by Cetin Sert in 2009.
.
Windows code was contributed by Eugene Kirpichov in 2010.
.
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-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 , Elefunc, Inc.
maintainer: Cetin Sert , Elefunc, Inc.
homepage: https://github.com/corsis/clock
bug-reports: https://github.com/corsis/clock/issues
category: System
build-type: Simple
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: https://github.com/corsis/clock.git
flag llvm
description: compile via LLVM
default : False
library
build-depends: base >= 4.7 && < 5
exposed-modules: System.Clock
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
clock-0.8.4/tests/ 0000755 0000000 0000000 00000000000 07346545000 012151 5 ustar 00 0000000 0000000 clock-0.8.4/tests/test.hs 0000644 0000000 0000000 00000012366 07346545000 013474 0 ustar 00 0000000 0000000 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
]