git.iko.soy/streamly
on 50232af help sign in
streamly/src/Streamly/Time/Clock.hsc
309 lines 10 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE ScopedTypeVariables #-}
6#if __GLASGOW_HASKELL__ >= 800
7{-# OPTIONS_GHC -Wno-identities #-}
8{-# OPTIONS_GHC -Wno-orphans #-}
9{-# OPTIONS_GHC -fno-warn-unused-imports #-}
10#endif
12#ifndef __GHCJS__
13#include "config.h"
14#endif
16-- |
17-- Module : Streamly.Time.Clock
18-- Copyright : (c) 2019 Harendra Kumar
19-- (c) 2009-2012, Cetin Sert
20-- (c) 2010, Eugene Kirpichov
21-- License : BSD3
22-- Maintainer : harendra.kumar@gmail.com
23-- Stability : experimental
24-- Portability : GHC
26-- A majority of the code below has been stolen from the "clock" package.
28#if __GHCJS__
29#define HS_CLOCK_GHCJS 1
30#elif (defined (HAVE_TIME_H) && defined(HAVE_CLOCK_GETTIME))
31#define HS_CLOCK_POSIX 1
32#elif __APPLE__
33#define HS_CLOCK_OSX 1
34#elif defined(_WIN32)
35#define HS_CLOCK_WINDOWS 1
36#else
37#error "Time/Clock functionality not implemented for this system"
38#endif
40module Streamly.Time.Clock
41 (
42 -- * get time from the system clock
43 Clock(..)
44 , getTime
45 )
46where
48import Data.Int (Int32, Int64)
49import Data.Typeable (Typeable)
50import Data.Word (Word32)
51import Foreign.C (CInt(..), throwErrnoIfMinus1_, CTime(..), CLong(..))
52import Foreign.Marshal.Alloc (alloca)
53import Foreign.Ptr (Ptr)
54import Foreign.Storable (Storable(..), peek)
55import GHC.Generics (Generic)
57import Streamly.Time.Units (TimeSpec(..), AbsTime(..))
59-------------------------------------------------------------------------------
60-- Clock Types
61-------------------------------------------------------------------------------
63#if HS_CLOCK_POSIX
64#include <time.h>
66#if defined(CLOCK_MONOTONIC_RAW)
67#define HAVE_CLOCK_MONOTONIC_RAW
68#endif
70-- XXX this may be RAW on apple not RAW on linux
71#if __linux__ && defined(CLOCK_MONOTONIC_COARSE)
72#define HAVE_CLOCK_MONOTONIC_COARSE
73#endif
75#if __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX)
76#define HAVE_CLOCK_MONOTONIC_COARSE
77#endif
79#if __linux__ && defined(CLOCK_BOOTTIME)
80#define HAVE_CLOCK_MONOTONIC_UPTIME
81#endif
83#if __APPLE__ && defined(CLOCK_UPTIME_RAW)
84#define HAVE_CLOCK_MONOTONIC_UPTIME
85#endif
87#if __linux__ && defined(CLOCK_REALTIME_COARSE)
88#define HAVE_CLOCK_REALTIME_COARSE
89#endif
91#endif
93-- | Clock types. A clock may be system-wide (that is, visible to all processes)
94-- or per-process (measuring time that is meaningful only within a process).
95-- All implementations shall support CLOCK_REALTIME. (The only suspend-aware
96-- monotonic is CLOCK_BOOTTIME on Linux.)
97data Clock
99 -- | The identifier for the system-wide monotonic clock, which is defined as
100 -- a clock measuring real time, whose value cannot be set via
101 -- @clock_settime@ and which cannot have negative clock jumps. The maximum
102 -- possible clock jump shall be implementation defined. For this clock,
103 -- the value returned by 'getTime' represents the amount of time (in
104 -- seconds and nanoseconds) since an unspecified point in the past (for
105 -- example, system start-up time, or the Epoch). This point does not
106 -- change after system start-up time. Note that the absolute value of the
107 -- monotonic clock is meaningless (because its origin is arbitrary), and
108 -- thus there is no need to set it. Furthermore, realtime applications can
109 -- rely on the fact that the value of this clock is never set.
110 = Monotonic
112 -- | The identifier of the system-wide clock measuring real time. For this
113 -- clock, the value returned by 'getTime' represents the amount of time (in
114 -- seconds and nanoseconds) since the Epoch.
115 | Realtime
117#ifndef HS_CLOCK_GHCJS
118 -- | The identifier of the CPU-time clock associated with the calling
119 -- process. For this clock, the value returned by 'getTime' represents the
120 -- amount of execution time of the current process.
121 | ProcessCPUTime
123 -- | The identifier of the CPU-time clock associated with the calling OS
124 -- thread. For this clock, the value returned by 'getTime' represents the
125 -- amount of execution time of the current OS thread.
126 | ThreadCPUTime
127#endif
129#if defined (HAVE_CLOCK_MONOTONIC_RAW)
130 -- | (since Linux 2.6.28; Linux and Mac OSX)
131 -- Similar to CLOCK_MONOTONIC, but provides access to a
132 -- raw hardware-based time that is not subject to NTP
133 -- adjustments or the incremental adjustments performed by
134 -- adjtime(3).
135 | MonotonicRaw
136#endif
138#if defined (HAVE_CLOCK_MONOTONIC_COARSE)
139 -- | (since Linux 2.6.32; Linux and Mac OSX)
140 -- A faster but less precise version of CLOCK_MONOTONIC.
141 -- Use when you need very fast, but not fine-grained timestamps.
142 | MonotonicCoarse
143#endif
145#if defined (HAVE_CLOCK_MONOTONIC_UPTIME)
146 -- | (since Linux 2.6.39; Linux and Mac OSX)
147 -- Identical to CLOCK_MONOTONIC, except it also includes
148 -- any time that the system is suspended. This allows
149 -- applications to get a suspend-aware monotonic clock
150 -- without having to deal with the complications of
151 -- CLOCK_REALTIME, which may have discontinuities if the
152 -- time is changed using settimeofday(2).
153 | Uptime
154#endif
156#if defined (HAVE_CLOCK_REALTIME_COARSE)
157 -- | (since Linux 2.6.32; Linux-specific)
158 -- A faster but less precise version of CLOCK_REALTIME.
159 -- Use when you need very fast, but not fine-grained timestamps.
160 | RealtimeCoarse
161#endif
163 deriving (Eq, Enum, Generic, Read, Show, Typeable)
165-------------------------------------------------------------------------------
166-- Translate the Haskell "Clock" type to C
167-------------------------------------------------------------------------------
169#if HS_CLOCK_POSIX
170-- Posix systems (Linux and Mac OSX 10.12 and later)
171clockToPosixClockId :: Clock -> #{type clockid_t}
172clockToPosixClockId Monotonic = #const CLOCK_MONOTONIC
173clockToPosixClockId Realtime = #const CLOCK_REALTIME
174clockToPosixClockId ProcessCPUTime = #const CLOCK_PROCESS_CPUTIME_ID
175clockToPosixClockId ThreadCPUTime = #const CLOCK_THREAD_CPUTIME_ID
177#if defined(CLOCK_MONOTONIC_RAW)
178clockToPosixClockId MonotonicRaw = #const CLOCK_MONOTONIC_RAW
179#endif
181#if __linux__ && defined (CLOCK_MONOTONIC_COARSE)
182clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_COARSE
183#elif __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX)
184clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_RAW_APPROX
185#endif
187#if __linux__ && defined (CLOCK_REALTIME_COARSE)
188clockToPosixClockId RealtimeCoarse = #const CLOCK_REALTIME_COARSE
189#endif
191#if __linux__ && defined(CLOCK_BOOTTIME)
192clockToPosixClockId Uptime = #const CLOCK_BOOTTIME
193#elif __APPLE__ && defined(CLOCK_UPTIME_RAW)
194clockToPosixClockId Uptime = #const CLOCK_UPTIME_RAW
195#endif
197#elif HS_CLOCK_OSX
198-- Mac OSX versions prior to 10.12
199#include <time.h>
200#include <mach/clock.h>
202clockToOSXClockId :: Clock -> #{type clock_id_t}
203clockToOSXClockId Monotonic = #const SYSTEM_CLOCK
204clockToOSXClockId Realtime = #const CALENDAR_CLOCK
205clockToOSXClockId ProcessCPUTime = #const SYSTEM_CLOCK
206clockToOSXClockId ThreadCPUTime = #const SYSTEM_CLOCK
207#elif HS_CLOCK_GHCJS
208-- XXX need to implement a monotonic clock for JS using performance.now()
209clockToJSClockId :: Clock -> CInt
210clockToJSClockId Monotonic = 0
211clockToJSClockId Realtime = 0
212#endif
214-------------------------------------------------------------------------------
215-- Clock time
216-------------------------------------------------------------------------------
218#if __GLASGOW_HASKELL__ < 800
219#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
220#endif
222#ifdef HS_CLOCK_GHCJS
223instance Storable TimeSpec where
224 sizeOf _ = 8
225 alignment _ = 4
226 peek p = do
227 CTime s <- peekByteOff p 0
228 CLong ns <- peekByteOff p 4
229 return (TimeSpec (fromIntegral s) (fromIntegral ns))
230 poke p (TimeSpec s ns) = do
231 pokeByteOff p 0 ((fromIntegral s) :: CTime)
232 pokeByteOff p 4 ((fromIntegral ns) :: CLong)
234#elif HS_CLOCK_WINDOWS
235instance Storable TimeSpec where
236 sizeOf _ = sizeOf (undefined :: Int64) * 2
237 alignment _ = alignment (undefined :: Int64)
238 peek ptr = do
239 s <- peekByteOff ptr 0
240 ns <- peekByteOff ptr (sizeOf (undefined :: Int64))
241 return (TimeSpec s ns)
242 poke ptr ts = do
243 pokeByteOff ptr 0 (sec ts)
244 pokeByteOff ptr (sizeOf (undefined :: Int64)) (nsec ts)
245#else
246instance Storable TimeSpec where
247 sizeOf _ = #{size struct timespec}
248 alignment _ = #{alignment struct timespec}
249 peek ptr = do
250 s :: #{type time_t} <- #{peek struct timespec, tv_sec} ptr
251 ns :: #{type long} <- #{peek struct timespec, tv_nsec} ptr
252 return $ TimeSpec (fromIntegral s) (fromIntegral ns)
253 poke ptr ts = do
254 let s :: #{type time_t} = fromIntegral $ sec ts
255 ns :: #{type long} = fromIntegral $ nsec ts
256 #{poke struct timespec, tv_sec} ptr (s)
257 #{poke struct timespec, tv_nsec} ptr (ns)
258#endif
260{-# INLINE getTimeWith #-}
261getTimeWith :: (Ptr TimeSpec -> IO ()) -> IO AbsTime
262getTimeWith f = do
263 t <- alloca (\ptr -> f ptr >> peek ptr)
264 return $ AbsTime t
266#if HS_CLOCK_GHCJS
268foreign import ccall unsafe "time.h clock_gettime_js"
269 clock_gettime_js :: CInt -> Ptr TimeSpec -> IO CInt
271{-# INLINABLE getTime #-}
272getTime :: Clock -> IO AbsTime
273getTime clock =
274 getTimeWith (throwErrnoIfMinus1_ "clock_gettime" .
275 clock_gettime_js (clockToJSClockId clock))
277#elif HS_CLOCK_POSIX
279foreign import ccall unsafe "time.h clock_gettime"
280 clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO CInt
282{-# INLINABLE getTime #-}
283getTime :: Clock -> IO AbsTime
284getTime clock =
285 getTimeWith (throwErrnoIfMinus1_ "clock_gettime" .
286 clock_gettime (clockToPosixClockId clock))
288#elif HS_CLOCK_OSX
290-- XXX perform error checks inside c implementation
291foreign import ccall
292 clock_gettime_darwin :: #{type clock_id_t} -> Ptr TimeSpec -> IO ()
294{-# INLINABLE getTime #-}
295getTime :: Clock -> IO AbsTime
296getTime clock = getTimeWith $ clock_gettime_darwin (clockToOSXClockId clock)
298#elif HS_CLOCK_WINDOWS
300-- XXX perform error checks inside c implementation
301foreign import ccall clock_gettime_win32_monotonic :: Ptr TimeSpec -> IO ()
303{-# INLINABLE getTime #-}
304getTime :: Clock -> IO AbsTime
305getTime Monotonic = getTimeWith $ clock_gettime_win32_monotonic
306getTime RealTime = getTimeWith $ clock_gettime_win32_realtime
307getTime ProcessCPUTime = getTimeWith $ clock_gettime_win32_processtime
308getTime ThreadCPUTime = getTimeWith $ clock_gettime_win32_threadtime
309#endif