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