Update base for new Safe Haskell design
[ghc.git] / libraries / base / GHC / Event / Clock.hsc
1 {-# LANGUAGE Unsafe #-}
2 {-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface #-}
3
4 module GHC.Event.Clock (getCurrentTime) where
5
6 #include <sys/time.h>
7
8 import Foreign (Ptr, Storable(..), nullPtr, with)
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 the current time, in seconds since Jan. 1, 1970.
19 getCurrentTime :: IO Double
20 getCurrentTime = do
21     tv <- with (CTimeval 0 0) $ \tvptr -> do
22         throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr)
23         peek tvptr
24     let !t = realToFrac (sec tv) + realToFrac (usec tv) / 1000000.0
25     return t
26
27 ------------------------------------------------------------------------
28 -- FFI binding
29
30 data CTimeval = CTimeval
31     { sec  :: {-# UNPACK #-} !CTime
32     , usec :: {-# UNPACK #-} !CSUSeconds
33     }
34
35 instance Storable CTimeval where
36     sizeOf _ = #size struct timeval
37     alignment _ = alignment (undefined :: CLong)
38
39     peek ptr = do
40         sec' <- #{peek struct timeval, tv_sec} ptr
41         usec' <- #{peek struct timeval, tv_usec} ptr
42         return $ CTimeval sec' usec'
43
44     poke ptr tv = do
45         #{poke struct timeval, tv_sec} ptr (sec tv)
46         #{poke struct timeval, tv_usec} ptr (usec tv)
47
48 foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday
49     :: Ptr CTimeval -> Ptr () -> IO CInt