Use monotonic time in Event/Manager.hs.
[packages/base.git] / GHC / Event / Clock.hsc
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface, CApiFFI #-}
3
4 module GHC.Event.Clock (getMonotonicTime) where
5
6 #include "HsBase.h"
7
8 import Foreign
9 import Foreign.C.Error (throwErrnoIfMinus1_)
10 import Foreign.C.Types
11 import GHC.Base
12 import GHC.Err
13 import GHC.Num
14 import GHC.Real
15
16 -- TODO: Implement this for Windows.
17
18 -- | Return monotonic time in seconds, since some unspecified starting point
19 getMonotonicTime :: IO Double
20
21 ------------------------------------------------------------------------
22 -- FFI binding
23
24 #if HAVE_CLOCK_GETTIME
25
26 getMonotonicTime = do
27     tv <- with (CTimespec 0 0) $ \tvptr -> do
28         throwErrnoIfMinus1_ "clock_gettime" (clock_gettime (#const CLOCK_ID) tvptr)
29         peek tvptr
30     let !t = realToFrac (sec tv) + realToFrac (nsec tv) / 1000000000.0
31     return t
32
33 data CTimespec = CTimespec
34     { sec  :: {-# UNPACK #-} !CTime
35     , nsec :: {-# UNPACK #-} !CLong
36     }
37
38 instance Storable CTimespec where
39     sizeOf _ = #size struct timespec
40     alignment _ = alignment (undefined :: CLong)
41
42     peek ptr = do
43         sec' <- #{peek struct timespec, tv_sec} ptr
44         nsec' <- #{peek struct timespec, tv_nsec} ptr
45         return $ CTimespec sec' nsec'
46
47     poke ptr tv = do
48         #{poke struct timespec, tv_sec} ptr (sec tv)
49         #{poke struct timespec, tv_nsec} ptr (nsec tv)
50
51 foreign import capi unsafe "HsBase.h clock_gettime" clock_gettime
52     :: Int -> Ptr CTimespec -> IO CInt
53
54 #else
55
56 getMonotonicTime = do
57     tv <- with (CTimeval 0 0) $ \tvptr -> do
58         throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr)
59         peek tvptr
60     let !t = realToFrac (sec tv) + realToFrac (usec tv) / 1000000.0
61     return t
62
63 data CTimeval = CTimeval
64     { sec  :: {-# UNPACK #-} !CTime
65     , usec :: {-# UNPACK #-} !CSUSeconds
66     }
67
68 instance Storable CTimeval where
69     sizeOf _ = #size struct timeval
70     alignment _ = alignment (undefined :: CLong)
71
72     peek ptr = do
73         sec' <- #{peek struct timeval, tv_sec} ptr
74         usec' <- #{peek struct timeval, tv_usec} ptr
75         return $ CTimeval sec' usec'
76
77     poke ptr tv = do
78         #{poke struct timeval, tv_sec} ptr (sec tv)
79         #{poke struct timeval, tv_usec} ptr (usec tv)
80
81 foreign import capi unsafe "HsBase.h gettimeofday" gettimeofday
82     :: Ptr CTimeval -> Ptr () -> IO CInt
83
84 #endif