git.iko.soy/streamly
on 2a522a1 help sign in
streamly/src/Streamly/Internal/Data/Time/System.hsc
252 lines 8.9 kB history raw
1{-# OPTIONS_GHC -Wno-identities #-}
2{-# OPTIONS_GHC -fno-warn-unused-imports #-}
4#ifndef __GHCJS__
5#include "config.h"
6#endif
8#include "Streamly/Internal/Data/Time/config-clock.h"
10-- |
11-- Module : Streamly.Internal.Data.Time.System
12-- Copyright : (c) 2019 Composewell Technologies
13-- (c) 2009-2012, Cetin Sert
14-- (c) 2010, Eugene Kirpichov
15-- License : BSD3
16-- Maintainer : streamly@composewell.com
17-- Stability : experimental
18-- Portability : GHC
20-- A majority of the code below has been stolen from the "clock" package.
22module Streamly.Internal.Data.Time.System
23 (
24 -- * get time from the system clock
25 Clock(..)
26 , getTime
27 )
28where
30import Data.Int (Int32, Int64)
31import Data.Typeable (Typeable)
32import Data.Word (Word32)
33import Foreign.C (CInt(..), throwErrnoIfMinus1_, CTime(..), CLong(..))
34import Foreign.Marshal.Alloc (alloca)
35import Foreign.Ptr (Ptr)
36import Foreign.Storable (Storable(..), peek)
37import GHC.Generics (Generic)
39import Streamly.Internal.Data.Time.Units (TimeSpec(..), AbsTime(..))
41-------------------------------------------------------------------------------
42-- Clock Types
43-------------------------------------------------------------------------------
45#if HS_CLOCK_POSIX
46#include <time.h>
48#if defined(CLOCK_MONOTONIC_RAW)
49#define HAVE_CLOCK_MONOTONIC_RAW
50#endif
52-- XXX this may be RAW on apple not RAW on linux
53#if __linux__ && defined(CLOCK_MONOTONIC_COARSE)
54#define HAVE_CLOCK_MONOTONIC_COARSE
55#endif
57#if __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX)
58#define HAVE_CLOCK_MONOTONIC_COARSE
59#endif
61#if __linux__ && defined(CLOCK_BOOTTIME)
62#define HAVE_CLOCK_MONOTONIC_UPTIME
63#endif
65#if __APPLE__ && defined(CLOCK_UPTIME_RAW)
66#define HAVE_CLOCK_MONOTONIC_UPTIME
67#endif
69#if __linux__ && defined(CLOCK_REALTIME_COARSE)
70#define HAVE_CLOCK_REALTIME_COARSE
71#endif
73#endif
75-- | Clock types. A clock may be system-wide (that is, visible to all processes)
76-- or per-process (measuring time that is meaningful only within a process).
77-- All implementations shall support CLOCK_REALTIME. (The only suspend-aware
78-- monotonic is CLOCK_BOOTTIME on Linux.)
79data Clock
81 -- | The identifier for the system-wide monotonic clock, which is defined as
82 -- a clock measuring real time, whose value cannot be set via
83 -- @clock_settime@ and which cannot have negative clock jumps. The maximum
84 -- possible clock jump shall be implementation defined. For this clock,
85 -- the value returned by 'getTime' represents the amount of time (in
86 -- seconds and nanoseconds) since an unspecified point in the past (for
87 -- example, system start-up time, or the Epoch). This point does not
88 -- change after system start-up time. Note that the absolute value of the
89 -- monotonic clock is meaningless (because its origin is arbitrary), and
90 -- thus there is no need to set it. Furthermore, realtime applications can
91 -- rely on the fact that the value of this clock is never set.
92 = Monotonic
94 -- | The identifier of the system-wide clock measuring real time. For this
95 -- clock, the value returned by 'getTime' represents the amount of time (in
96 -- seconds and nanoseconds) since the Epoch.
97 | Realtime
99#ifndef HS_CLOCK_GHCJS
100 -- | The identifier of the CPU-time clock associated with the calling
101 -- process. For this clock, the value returned by 'getTime' represents the
102 -- amount of execution time of the current process.
103 | ProcessCPUTime
105 -- | The identifier of the CPU-time clock associated with the calling OS
106 -- thread. For this clock, the value returned by 'getTime' represents the
107 -- amount of execution time of the current OS thread.
108 | ThreadCPUTime
109#endif
111#if defined (HAVE_CLOCK_MONOTONIC_RAW)
112 -- | (since Linux 2.6.28; Linux and Mac OSX)
113 -- Similar to CLOCK_MONOTONIC, but provides access to a
114 -- raw hardware-based time that is not subject to NTP
115 -- adjustments or the incremental adjustments performed by
116 -- adjtime(3).
117 | MonotonicRaw
118#endif
120#if defined (HAVE_CLOCK_MONOTONIC_COARSE)
121 -- | (since Linux 2.6.32; Linux and Mac OSX)
122 -- A faster but less precise version of CLOCK_MONOTONIC.
123 -- Use when you need very fast, but not fine-grained timestamps.
124 | MonotonicCoarse
125#endif
127#if defined (HAVE_CLOCK_MONOTONIC_UPTIME)
128 -- | (since Linux 2.6.39; Linux and Mac OSX)
129 -- Identical to CLOCK_MONOTONIC, except it also includes
130 -- any time that the system is suspended. This allows
131 -- applications to get a suspend-aware monotonic clock
132 -- without having to deal with the complications of
133 -- CLOCK_REALTIME, which may have discontinuities if the
134 -- time is changed using settimeofday(2).
135 | Uptime
136#endif
138#if defined (HAVE_CLOCK_REALTIME_COARSE)
139 -- | (since Linux 2.6.32; Linux-specific)
140 -- A faster but less precise version of CLOCK_REALTIME.
141 -- Use when you need very fast, but not fine-grained timestamps.
142 | RealtimeCoarse
143#endif
145 deriving (Eq, Enum, Generic, Read, Show, Typeable)
147-------------------------------------------------------------------------------
148-- Translate the Haskell "Clock" type to C
149-------------------------------------------------------------------------------
151#if HS_CLOCK_POSIX
152-- Posix systems (Linux and Mac OSX 10.12 and later)
153clockToPosixClockId :: Clock -> #{type clockid_t}
154clockToPosixClockId Monotonic = #const CLOCK_MONOTONIC
155clockToPosixClockId Realtime = #const CLOCK_REALTIME
156clockToPosixClockId ProcessCPUTime = #const CLOCK_PROCESS_CPUTIME_ID
157clockToPosixClockId ThreadCPUTime = #const CLOCK_THREAD_CPUTIME_ID
159#if defined(CLOCK_MONOTONIC_RAW)
160clockToPosixClockId MonotonicRaw = #const CLOCK_MONOTONIC_RAW
161#endif
163#if __linux__ && defined (CLOCK_MONOTONIC_COARSE)
164clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_COARSE
165#elif __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX)
166clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_RAW_APPROX
167#endif
169#if __linux__ && defined (CLOCK_REALTIME_COARSE)
170clockToPosixClockId RealtimeCoarse = #const CLOCK_REALTIME_COARSE
171#endif
173#if __linux__ && defined(CLOCK_BOOTTIME)
174clockToPosixClockId Uptime = #const CLOCK_BOOTTIME
175#elif __APPLE__ && defined(CLOCK_UPTIME_RAW)
176clockToPosixClockId Uptime = #const CLOCK_UPTIME_RAW
177#endif
179#elif HS_CLOCK_OSX
180-- Mac OSX versions prior to 10.12
181#include <time.h>
182#include <mach/clock.h>
184clockToOSXClockId :: Clock -> #{type clock_id_t}
185clockToOSXClockId Monotonic = #const SYSTEM_CLOCK
186clockToOSXClockId Realtime = #const CALENDAR_CLOCK
187clockToOSXClockId ProcessCPUTime = #const SYSTEM_CLOCK
188clockToOSXClockId ThreadCPUTime = #const SYSTEM_CLOCK
189#elif HS_CLOCK_GHCJS
190-- XXX need to implement a monotonic clock for JS using performance.now()
191clockToJSClockId :: Clock -> CInt
192clockToJSClockId Monotonic = 0
193clockToJSClockId Realtime = 0
194#endif
196-------------------------------------------------------------------------------
197-- Clock time
198-------------------------------------------------------------------------------
200{-# INLINE getTimeWith #-}
201getTimeWith :: (Ptr TimeSpec -> IO ()) -> IO AbsTime
202getTimeWith f = do
203 t <- alloca (\ptr -> f ptr >> peek ptr)
204 return $ AbsTime t
206#if HS_CLOCK_GHCJS
208foreign import ccall unsafe "time.h clock_gettime_js"
209 clock_gettime_js :: CInt -> Ptr TimeSpec -> IO CInt
211{-# INLINABLE getTime #-}
212getTime :: Clock -> IO AbsTime
213getTime clock =
214 getTimeWith (throwErrnoIfMinus1_ "clock_gettime" .
215 clock_gettime_js (clockToJSClockId clock))
217#elif HS_CLOCK_POSIX
219foreign import ccall unsafe "time.h clock_gettime"
220 clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO CInt
222{-# INLINABLE getTime #-}
223getTime :: Clock -> IO AbsTime
224getTime clock =
225 getTimeWith (throwErrnoIfMinus1_ "clock_gettime" .
226 clock_gettime (clockToPosixClockId clock))
228#elif HS_CLOCK_OSX
230-- XXX perform error checks inside c implementation
231foreign import ccall
232 clock_gettime_darwin :: #{type clock_id_t} -> Ptr TimeSpec -> IO ()
234{-# INLINABLE getTime #-}
235getTime :: Clock -> IO AbsTime
236getTime clock = getTimeWith $ clock_gettime_darwin (clockToOSXClockId clock)
238#elif HS_CLOCK_WINDOWS
240-- XXX perform error checks inside c implementation
241foreign import ccall clock_gettime_win32_monotonic :: Ptr TimeSpec -> IO ()
242foreign import ccall clock_gettime_win32_realtime :: Ptr TimeSpec -> IO ()
243foreign import ccall clock_gettime_win32_processtime :: Ptr TimeSpec -> IO ()
244foreign import ccall clock_gettime_win32_threadtime :: Ptr TimeSpec -> IO ()
246{-# INLINABLE getTime #-}
247getTime :: Clock -> IO AbsTime
248getTime Monotonic = getTimeWith $ clock_gettime_win32_monotonic
249getTime Realtime = getTimeWith $ clock_gettime_win32_realtime
250getTime ProcessCPUTime = getTimeWith $ clock_gettime_win32_processtime
251getTime ThreadCPUTime = getTimeWith $ clock_gettime_win32_threadtime
252#endif