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