{-# LINE 1 "System/Time/Monotonic/Direct.hsc" #-} {-# LANGUAGE ExistentialQuantification #-} {-# LINE 2 "System/Time/Monotonic/Direct.hsc" #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | -- Module: System.Time.Monotonic.Direct -- Copyright: (c) Joseph Adams 2012 -- License: BSD3 -- Maintainer: joeyadams3.14159@gmail.com -- Portability: Tested on Linux and Windows -- -- This module provides more direct access to the system's monotonic clock, -- but provides less protection against wraparound. -- -- More specifically, in the higher-level "System.Time.Monotonic" API, -- 'System.Time.Monotonic.Clock' updates its internal disposition every time -- 'System.Time.Monotonic.clockGetTime' is called. The only way to get a -- wraparound issue with the higher-level API is to call -- 'System.Time.Monotonic.clockGetTime' very seldomly (e.g. less than once -- every 24.8 days, if @GetTickCount@ is being used). module System.Time.Monotonic.Direct ( getSystemClock, SomeSystemClock(..), SystemClock(..), -- * Implementation(s) -- | The set of definitions below is platform-dependent. {-# LINE 33 "System/Time/Monotonic/Direct.hsc" #-} systemClock_MONOTONIC, CTimeSpec, {-# LINE 36 "System/Time/Monotonic/Direct.hsc" #-} ) where import Data.Bits (isSigned) import Data.Int import Data.Time.Clock (DiffTime) import Data.Word import Foreign (Ptr, FunPtr, allocaBytes, nullFunPtr, peekByteOff) {-# LINE 48 "System/Time/Monotonic/Direct.hsc" #-} import Foreign.C {-# LINE 50 "System/Time/Monotonic/Direct.hsc" #-} {-# LINE 51 "System/Time/Monotonic/Direct.hsc" #-} -- | Existentially-quantified wrapper around 'SystemClock' data SomeSystemClock = forall time cumtime. SomeSystemClock (SystemClock time cumtime) instance Show SomeSystemClock where showsPrec d (SomeSystemClock sc) = showParen (d > 10) $ showString "SomeSystemClock " . showsPrec 11 (systemClockName sc) -- | A 'SystemClock' is a driver module used by 'System.Time.Monotonic.Clock' -- to access a particular implementation of monotonic time support. -- -- * @time@: Type of value returned by the system's time-getting function. -- -- * @cumtime@: Type for accumulating differences between consecutive(-ish) -- calls to 'systemClockGetTime', in case @time@ wraps around. -- The reason we don't simply use 'DiffTime' is this: if the implementation -- has to divide the result by a clock frequency, it could end up with a -- number that is not an integral number of picoseconds. Truncating to -- 'DiffTime' would lose precision, and that precision loss could add up, at -- least in theory. data SystemClock time cumtime = SystemClock { systemClockGetTime :: IO time , systemClockDiffTime :: time -> time -> cumtime -- ^ @systemClockDiffTime new old@ returns the amount of time that has -- elapsed between two calls to @systemClockGetTime@. -- -- >systemClockDiffTime new old = new - old -- -- This function should handle wraparound properly. Also, bear in mind -- that @new@ may be earlier than @old@. This can happen if multiple -- threads are accessing a 'System.Time.Monotonic.Clock' -- simultaneously. -- -- Lastly, @systemClockDiffTime@ should not truncate precision in -- conversion to cumtime. Otherwise, repeated calls to -- 'System.Time.Monotonic.clockGetTime' could degrade accuracy, due to -- lost precision adding up. , systemClockZeroCumTime :: cumtime -- ^ The number @0@. , systemClockAddCumTime :: cumtime -> cumtime -> cumtime -- ^ Add two @cumtime@ values. This should not overflow or lose -- precision. , systemClockCumToDiff :: cumtime -> DiffTime -- ^ Convert a cumulative total of 'systemClockDiffTime' results to -- 'DiffTime'. This may truncate precision if it needs to. , systemClockName :: String -- ^ Label identifying this clock, like -- @\"clock_gettime(CLOCK_MONOTONIC)\"@ or -- @\"GetTickCount\"@. This label is used for the 'Show' -- instances of 'SystemClock' and 'SomeSystemClock', and for -- 'System.Time.Monotonic.clockDriverName'. } instance Show (SystemClock time cumtime) where showsPrec d sc = showParen (d > 10) $ showString "SystemClock " . showsPrec 11 (systemClockName sc) -- | Return a module used for accessing the system's monotonic clock. The -- reason this is an 'IO' action, rather than simply a 'SystemClock' value, is -- that the implementation may need to make a system call to determine what -- monotonic time source to use, and how to use it. getSystemClock :: IO SomeSystemClock {-# LINE 125 "System/Time/Monotonic/Direct.hsc" #-} getSystemClock = return $ SomeSystemClock systemClock_MONOTONIC {-# LINE 128 "System/Time/Monotonic/Direct.hsc" #-} {-# LINE 240 "System/Time/Monotonic/Direct.hsc" #-} type Time_t = Int32 {-# LINE 242 "System/Time/Monotonic/Direct.hsc" #-} data CTimeSpec = CTimeSpec { tv_sec :: !Time_t -- ^ seconds , tv_nsec :: !CLong -- ^ nanoseconds. 1 second = 10^9 nanoseconds } deriving Show diffCTimeSpec :: CTimeSpec -> CTimeSpec -> DiffTime diffCTimeSpec a b = diffCTime (tv_sec a) (tv_sec b) + fromIntegral (tv_nsec a - tv_nsec b) / 1000000000 diffCTime :: Time_t -> Time_t -> DiffTime diffCTime a b | isSigned a = fromIntegral (a - b) | otherwise = error "System.Time.Monotonic.Direct: time_t is unsigned" -- time_t is supposed to be signed on POSIX systems. -- If a is earlier than b, unsigned subtraction will produce an -- enormous result. peekCTimeSpec :: Ptr CTimeSpec -> IO CTimeSpec peekCTimeSpec ptr = do sec <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr {-# LINE 267 "System/Time/Monotonic/Direct.hsc" #-} nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr {-# LINE 268 "System/Time/Monotonic/Direct.hsc" #-} return CTimeSpec { tv_sec = sec , tv_nsec = nsec } -- | Uses @clock_gettime@ with @CLOCK_MONOTONIC@. -- -- /Warning:/ on Linux, this clock stops when the computer is suspended. -- See <http://lwn.net/Articles/434239/>. systemClock_MONOTONIC :: SystemClock CTimeSpec DiffTime systemClock_MONOTONIC = SystemClock { systemClockGetTime = clock_gettime 1 {-# LINE 280 "System/Time/Monotonic/Direct.hsc" #-} , systemClockDiffTime = diffCTimeSpec , systemClockZeroCumTime = 0 , systemClockAddCumTime = (+) , systemClockCumToDiff = id , systemClockName = "clock_gettime(CLOCK_MONOTONIC)" } -- CLOCK_MONOTONIC_RAW is more reliable, but requires -- a recent kernel and glibc. -- -- -- | @clock_gettime(CLOCK_MONOTONIC_RAW)@ -- systemClock_MONOTONIC_RAW :: SystemClock CTimeSpec -- systemClock_MONOTONIC_RAW = -- SystemClock -- { systemClockGetTime = clock_gettime #{const CLOCK_MONOTONIC_RAW} -- , systemClockDiffTime = diffCTimeSpec -- , systemClockAddCumTime = (+) -- , systemClockCumToDiff = id -- , systemClockName = "clock_gettime(CLOCK_MONOTONIC_RAW)" -- } clock_gettime :: Int32 -> IO CTimeSpec {-# LINE 302 "System/Time/Monotonic/Direct.hsc" #-} clock_gettime clk_id = allocaBytes (8) $ \ptr -> do {-# LINE 304 "System/Time/Monotonic/Direct.hsc" #-} throwErrnoIfMinus1_ "clock_gettime" $ c_clock_gettime clk_id ptr peekCTimeSpec ptr foreign import ccall "time.h clock_gettime" c_clock_gettime :: Int32 {-# LINE 310 "System/Time/Monotonic/Direct.hsc" #-} -> Ptr CTimeSpec -> IO CInt {-# LINE 314 "System/Time/Monotonic/Direct.hsc" #-}