1-- | High-resolution, realtime clock and timer functions for Posix 2-- systems. This module is being developed according to IEEE Std 3-- 1003.1-2008: <http://www.opengroup.org/onlinepubs/9699919799/>, 4-- <http://www.opengroup.org/onlinepubs/9699919799/functions/clock_getres.html#> 5 6{-# OPTIONS_GHC -fno-warn-type-defaults #-} 7-- To allow importing Data.Int and Data.Word indiscriminately on all platforms, 8-- since we can't systematically predict what typedef's expand to. 9{-# OPTIONS_GHC -fno-warn-unused-imports #-} 10 11module System.Clock 12 ( Clock(..) 13 , TimeSpec(..) 14 , getTime 15 , getRes 16 , fromNanoSecs 17 , toNanoSecs 18 , diffTimeSpec 19 , timeSpecAsNanoSecs 20 ) where 21 22import Control.Applicative ((<$>), (<*>)) 23import Data.Int 24import Data.Word 25import Data.Typeable (Typeable) 26import Foreign.C 27import Foreign.Ptr 28import Foreign.Storable 29import Foreign.Marshal.Alloc 30import GHC.Generics (Generic) 31 32#if defined(_WIN32) 33# include "hs_clock_win32.c" 34#else 35# include <time.h> 36# ifndef CLOCK_PROCESS_CPUTIME_ID 37# define CLOCK_PROCESS_CPUTIME_ID 15 38# endif 39#endif 40 41#if __GLASGOW_HASKELL__ < 800 42# let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) 43#endif 44 45-- | Clock types. A clock may be system-wide (that is, visible to all processes) 46-- or per-process (measuring time that is meaningful only within a process). 47-- All implementations shall support 'Realtime'. 48data Clock 49 50 -- | The identifier for the system-wide monotonic clock, which is defined as 51 -- a clock measuring real time, whose value cannot be set via 52 -- @clock_settime@ and which cannot have negative clock jumps. The maximum 53 -- possible clock jump shall be implementation defined. For this clock, 54 -- the value returned by 'getTime' represents the amount of time (in 55 -- seconds and nanoseconds) since an unspecified point in the past (for 56 -- example, system start-up time, or the Epoch). This point does not 57 -- change after system start-up time. Note that the absolute value of the 58 -- monotonic clock is meaningless (because its origin is arbitrary), and 59 -- thus there is no need to set it. Furthermore, realtime applications can 60 -- rely on the fact that the value of this clock is never set. 61 -- (Identical to 'Boottime' since Linux 4.17, see https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/commit/?id=d6ed449afdb38f89a7b38ec50e367559e1b8f71f) 62 -- @CLOCK_MONOTONIC@ (macOS - @SYSTEM_CLOCK@) 63 = Monotonic 64 65 -- | The identifier of the system-wide clock measuring real time. For this 66 -- clock, the value returned by 'getTime' represents the amount of time (in 67 -- seconds and nanoseconds) since the Epoch. 68 -- @CLOCK_REALTIME@ (macOS - @CALENDAR_CLOCK@, Windows - @GetSystemTimeAsFileTime@) 69 | Realtime 70 71 -- | The identifier of the CPU-time clock associated with the calling 72 -- process. For this clock, the value returned by 'getTime' represents the 73 -- amount of execution time of the current process. 74 | ProcessCPUTime 75 76 -- | The identifier of the CPU-time clock associated with the calling OS 77 -- thread. For this clock, the value returned by 'getTime' represents the 78 -- amount of execution time of the current OS thread. 79 | ThreadCPUTime 80 81#if defined (CLOCK_MONOTONIC_RAW) 82 -- | (since Linux 2.6.28, macOS 10.12) 83 -- Similar to 'Monotonic', but provides access to a 84 -- raw hardware-based time that is not subject to NTP 85 -- adjustments or the incremental adjustments performed by 86 -- adjtime(3). 87 -- @CLOCK_MONOTONIC_RAW@ (Windows - @QueryPerformanceCounter@, @QueryPerformanceFrequency@) 88 | MonotonicRaw 89#endif 90 91#if defined (CLOCK_BOOTTIME) 92 -- | (since Linux 2.6.39; Linux-specific) 93 -- Identical to `Monotonic`, except it also includes 94 -- any time that the system is suspended. This allows 95 -- applications to get a suspend-aware monotonic clock 96 -- without having to deal with the complications of 'Realtime', 97 -- which may have discontinuities if the time is changed 98 -- using settimeofday(2). 99 -- (since Linux 4.17; identical to 'Monotonic') 100 -- @CLOCK_BOOTTIME@ 101 | Boottime 102#endif 103 104#if defined (CLOCK_MONOTONIC_COARSE) 105 -- | (since Linux 2.6.32; Linux-specific) 106 -- A faster but less precise version of 'Monotonic'. 107 -- Use when you need very fast, but not fine-grained timestamps. 108 -- @CLOCK_MONOTONIC_COARSE@ 109 | MonotonicCoarse 110#endif 111 112#if defined (CLOCK_REALTIME_COARSE) 113 -- | (since Linux 2.6.32; Linux-specific) 114 -- A faster but less precise version of 'Realtime'. 115 -- Use when you need very fast, but not fine-grained timestamps. 116 -- @CLOCK_REALTIME_COARSE@ 117 | RealtimeCoarse 118#endif 119 120 deriving (Eq, Enum, Generic, Read, Show, Typeable) 121 122#if defined(_WIN32) 123foreign import ccall unsafe hs_clock_win32_gettime_monotonic :: Ptr TimeSpec -> IO () 124foreign import ccall unsafe hs_clock_win32_gettime_realtime :: Ptr TimeSpec -> IO () 125foreign import ccall unsafe hs_clock_win32_gettime_processtime :: Ptr TimeSpec -> IO () 126foreign import ccall unsafe hs_clock_win32_gettime_threadtime :: Ptr TimeSpec -> IO () 127foreign import ccall unsafe hs_clock_win32_getres_monotonic :: Ptr TimeSpec -> IO () 128foreign import ccall unsafe hs_clock_win32_getres_realtime :: Ptr TimeSpec -> IO () 129foreign import ccall unsafe hs_clock_win32_getres_processtime :: Ptr TimeSpec -> IO () 130foreign import ccall unsafe hs_clock_win32_getres_threadtime :: Ptr TimeSpec -> IO () 131#else 132foreign import ccall unsafe clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO CInt 133foreign import ccall unsafe clock_getres :: #{type clockid_t} -> Ptr TimeSpec -> IO CInt 134#endif 135 136#if !defined(_WIN32) 137clockToConst :: Clock -> #{type clockid_t} 138clockToConst Monotonic = #const CLOCK_MONOTONIC 139clockToConst Realtime = #const CLOCK_REALTIME 140clockToConst ProcessCPUTime = #const CLOCK_PROCESS_CPUTIME_ID 141clockToConst ThreadCPUTime = #const CLOCK_THREAD_CPUTIME_ID 142 143#if defined (CLOCK_MONOTONIC_RAW) 144clockToConst MonotonicRaw = #const CLOCK_MONOTONIC_RAW 145#endif 146#if defined (CLOCK_BOOTTIME) 147clockToConst Boottime = #const CLOCK_BOOTTIME 148#endif 149#if defined (CLOCK_MONOTONIC_COARSE) 150clockToConst MonotonicCoarse = #const CLOCK_MONOTONIC_COARSE 151#endif 152#if defined (CLOCK_REALTIME_COARSE) 153clockToConst RealtimeCoarse = #const CLOCK_REALTIME_COARSE 154#endif 155#endif 156 157allocaAndPeek :: Storable a => (Ptr a -> IO ()) -> IO a 158allocaAndPeek f = alloca $ \ptr -> f ptr >> peek ptr 159 160-- | The 'getTime' function shall return the current value for the 161-- specified clock. 162getTime :: Clock -> IO TimeSpec 163 164-- | The 'getRes' function shall return the resolution of any clock. 165-- Clock resolutions are implementation-defined and cannot be set 166-- by a process. 167getRes :: Clock -> IO TimeSpec 168 169#if defined(_WIN32) 170getTime Monotonic = allocaAndPeek hs_clock_win32_gettime_monotonic 171getTime Realtime = allocaAndPeek hs_clock_win32_gettime_realtime 172getTime ProcessCPUTime = allocaAndPeek hs_clock_win32_gettime_processtime 173getTime ThreadCPUTime = allocaAndPeek hs_clock_win32_gettime_threadtime 174#else 175getTime clk = allocaAndPeek $! throwErrnoIfMinus1_ "clock_gettime" . clock_gettime (clockToConst clk) 176#endif 177 178#if defined(_WIN32) 179getRes Monotonic = allocaAndPeek hs_clock_win32_getres_monotonic 180getRes Realtime = allocaAndPeek hs_clock_win32_getres_realtime 181getRes ProcessCPUTime = allocaAndPeek hs_clock_win32_getres_processtime 182getRes ThreadCPUTime = allocaAndPeek hs_clock_win32_getres_threadtime 183#else 184getRes clk = allocaAndPeek $! throwErrnoIfMinus1_ "clock_getres" . clock_getres (clockToConst clk) 185#endif 186 187-- | TimeSpec structure 188data TimeSpec = TimeSpec 189 { sec :: {-# UNPACK #-} !Int64 -- ^ seconds 190 , nsec :: {-# UNPACK #-} !Int64 -- ^ nanoseconds 191 } deriving (Generic, Read, Show, Typeable) 192 193#if defined(_WIN32) 194instance Storable TimeSpec where 195 sizeOf _ = sizeOf (undefined :: Int64) * 2 196 alignment _ = alignment (undefined :: Int64) 197 poke ptr ts = do 198 pokeByteOff ptr 0 (sec ts) 199 pokeByteOff ptr (sizeOf (undefined :: Int64)) (nsec ts) 200 peek ptr = do 201 TimeSpec 202 <$> peekByteOff ptr 0 203 <*> peekByteOff ptr (sizeOf (undefined :: Int64)) 204#else 205instance Storable TimeSpec where 206 sizeOf _ = #{size struct timespec} 207 alignment _ = #{alignment struct timespec} 208 poke ptr ts = do 209 let xs :: #{type time_t} = fromIntegral $ sec ts 210 xn :: #{type long} = fromIntegral $ nsec ts 211 #{poke struct timespec, tv_sec} ptr (xs) 212 #{poke struct timespec, tv_nsec} ptr (xn) 213 peek ptr = do 214 xs :: #{type time_t} <- #{peek struct timespec, tv_sec} ptr 215 xn :: #{type long} <- #{peek struct timespec, tv_nsec} ptr 216 return $ TimeSpec (fromIntegral xs) (fromIntegral xn) 217#endif 218 219s2ns :: Num a => a 220s2ns = 10^9 221 222normalize :: TimeSpec -> TimeSpec 223normalize (TimeSpec xs xn) | xn < 0 || xn >= s2ns = TimeSpec (xs + q) r 224 | otherwise = TimeSpec xs xn 225 where (q, r) = xn `divMod` s2ns 226 227instance Num TimeSpec where 228 (TimeSpec xs xn) + (TimeSpec ys yn) = normalize $! TimeSpec (xs + ys) (xn + yn) 229 (TimeSpec xs xn) - (TimeSpec ys yn) = normalize $! TimeSpec (xs - ys) (xn - yn) 230 (TimeSpec xs xn) * (TimeSpec ys yn) = normalize $! TimeSpec (xsi_ysi) (xni_yni) 231 where xsi_ysi = fromInteger $! xsi*ysi 232 xni_yni = fromInteger $! (xni*yni + (xni*ysi + xsi*yni) * s2ns) `div` s2ns 233 xsi = toInteger xs 234 ysi = toInteger ys 235 xni = toInteger xn 236 yni = toInteger yn 237 238 negate (TimeSpec xs xn) = normalize $! TimeSpec (negate xs) (negate xn) 239 abs (normalize -> TimeSpec xs xn) | xs == 0 = normalize $! TimeSpec 0 xn 240 | otherwise = normalize $! TimeSpec (abs xs) (signum xs * xn) 241 signum (normalize -> TimeSpec xs xn) | xs == 0 = TimeSpec (signum xn) 0 242 | otherwise = TimeSpec (signum xs) 0 243 fromInteger x = TimeSpec (fromInteger q) (fromInteger r) where (q, r) = x `divMod` s2ns 244 245instance Eq TimeSpec where 246 (normalize -> TimeSpec xs xn) == (normalize -> TimeSpec ys yn) | True == es = xn == yn 247 | otherwise = es 248 where es = xs == ys 249 250instance Ord TimeSpec where 251 compare (normalize -> TimeSpec xs xn) (normalize -> TimeSpec ys yn) | EQ == os = compare xn yn 252 | otherwise = os 253 where os = compare xs ys 254 255-- | TimeSpec from nano seconds. 256fromNanoSecs :: Integer -> TimeSpec 257fromNanoSecs x = TimeSpec (fromInteger q) (fromInteger r) where (q, r) = x `divMod` s2ns 258 259 260-- | TimeSpec to nano seconds. 261toNanoSecs :: TimeSpec -> Integer 262toNanoSecs (TimeSpec (toInteger -> s) (toInteger -> n)) = s * s2ns + n 263 264-- | Compute the absolute difference. 265diffTimeSpec :: TimeSpec -> TimeSpec -> TimeSpec 266diffTimeSpec ts1 ts2 = abs (ts1 - ts2) 267 268{-# DEPRECATED timeSpecAsNanoSecs "Use toNanoSecs instead! Replaced timeSpecAsNanoSecs with the same signature TimeSpec -> Integer" #-} 269-- | TimeSpec as nano seconds. 270timeSpecAsNanoSecs :: TimeSpec -> Integer 271timeSpecAsNanoSecs (TimeSpec s n) = toInteger s * s2ns + toInteger n 272