{-# LANGUAGE ExistentialQuantification #-}
{-# 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.
#if mingw32_HOST_OS
systemClock_GetTickCount,
systemClock_GetTickCount64,
systemClock_QueryPerformanceCounter,
#else
systemClock_MONOTONIC,
CTimeSpec,
#endif
) where
import Data.Bits (isSigned)
import Data.Int
import Data.Time.Clock (DiffTime)
import Data.Word
import Foreign (Ptr, FunPtr, allocaBytes, nullFunPtr, peekByteOff)
#if mingw32_HOST_OS
import Data.Ratio ((%))
#include <Windows.h>
#else
import Foreign.C
#include <time.h>
#endif
-- | Existentially-quantified wrapper around 'SystemClock'
data SomeSystemClock = forall time. SomeSystemClock (SystemClock time)
instance Show SomeSystemClock where
showsPrec d (SomeSystemClock sc)
= showParen (d > 10)
$ showString "SomeSystemClock "
. showsPrec 11 (systemClockName sc)
data SystemClock time = SystemClock
{ systemClockGetTime :: IO time
, systemClockDiffTime :: time -> time -> DiffTime
-- ^ @systemClockDiffTime new old@ returns the amount of time that has
-- elapsed between two calls to @systemClockGetTime@.
--
-- 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.
, 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) 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
#if mingw32_HOST_OS
getSystemClock = do
m <- systemClock_GetTickCount64
case m of
Just gtc64 -> return $ SomeSystemClock gtc64
Nothing -> return $ SomeSystemClock systemClock_GetTickCount
#else
getSystemClock =
return $ SomeSystemClock systemClock_MONOTONIC
#endif
#if mingw32_HOST_OS
diffMSec32 :: Word32 -> Word32 -> DiffTime
diffMSec32 a b = fromIntegral (fromIntegral (a - b :: Word32) :: Int32) / 1000
-- Do the subtraction modulo 2^32, to handle wraparound properly.
-- However, convert it from unsigned to signed, to avoid
-- a bogus result if a is earlier than b.
diffMSec64 :: Word64 -> Word64 -> DiffTime
diffMSec64 a b = fromIntegral (fromIntegral (a - b :: Word64) :: Int64) / 1000
-- | Use @GetTickCount@. This is the default on Windows when @GetTickCount64@
-- is not available.
--
-- @GetTickCount@ has a 49.7 day wraparound, due to the type of the return
-- value (milliseconds as an unsigned 32-bit integer).
systemClock_GetTickCount :: SystemClock Word32
systemClock_GetTickCount =
SystemClock
{ systemClockGetTime = c_GetTickCount
, systemClockDiffTime = diffMSec32
, systemClockName = "GetTickCount"
}
foreign import stdcall "Windows.h GetTickCount"
c_GetTickCount :: IO #{type DWORD}
-- | Uses @GetTickCount64@, which was introduced in Windows Vista and
-- Windows Server 2008. This function tests, at runtime, if @GetTickCount64@
-- is available.
systemClock_GetTickCount64 :: IO (Maybe (SystemClock Word64))
systemClock_GetTickCount64 = do
fun <- system_time_monotonic_load_GetTickCount64
if fun == nullFunPtr
then return Nothing
else return $ Just $ clock $ mkGetTickCount64 fun
where
clock getTickCount64 =
SystemClock
{ systemClockGetTime = getTickCount64
, systemClockDiffTime = diffMSec64
, systemClockName = "GetTickCount64"
}
type C_GetTickCount64 = IO #{type ULONGLONG}
-- Defined in cbits/dll.c
foreign import ccall
system_time_monotonic_load_GetTickCount64 :: IO (FunPtr C_GetTickCount64)
foreign import stdcall "dynamic"
mkGetTickCount64 :: FunPtr C_GetTickCount64 -> C_GetTickCount64
qpcDiffTime :: Int64 -> Int64 -> Int64 -> DiffTime
qpcDiffTime freq new old =
fromRational $ fromIntegral (new - old) % fromIntegral freq
-- | Uses @QueryPerformanceCounter@. This is not the default because it is
-- less reliable in the long run than @GetTickCount@, and it stops when the
-- computer is put in suspend mode.
systemClock_QueryPerformanceCounter :: IO (Maybe (SystemClock Int64))
systemClock_QueryPerformanceCounter = do
mfreq <- callQP c_QueryPerformanceFrequency
case mfreq of
Nothing -> return Nothing
Just 0 -> return Nothing -- Shouldn't happen; just a safeguard to
-- prevent zero denominator in 'qpcDiffTime'.
Just freq -> return $ Just SystemClock
{ systemClockGetTime = do
m <- callQP c_QueryPerformanceCounter
case m of
Just t -> return t
Nothing -> fail "QueryPerformanceCounter failed,\
\ even though QueryPerformanceFrequency\
\ succeeded earlier"
, systemClockDiffTime = qpcDiffTime freq
, systemClockName = "QueryPerformanceCounter"
}
callQP :: QPFunc -> IO (Maybe Int64)
callQP qpfunc =
allocaBytes #{size LARGE_INTEGER} $ \ptr -> do
ok <- qpfunc ptr
if ok /= 0
then do
n <- #{peek LARGE_INTEGER, QuadPart} ptr
return (Just n)
else return Nothing
type QPFunc = Ptr Int64 -> IO #{type BOOL}
foreign import stdcall "Windows.h QueryPerformanceFrequency"
c_QueryPerformanceFrequency :: QPFunc
foreign import stdcall "Windows.h QueryPerformanceCounter"
c_QueryPerformanceCounter :: QPFunc
#else
type Time_t = #{type time_t}
data CTimeSpec = CTimeSpec
{ tv_sec :: !Time_t
-- ^ seconds
, tv_nsec :: !CLong
-- ^ nanoseconds. 1 second = 10^9 nanoseconds
}
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 <- #{peek struct timespec, tv_sec} ptr
nsec <- #{peek struct timespec, tv_nsec} ptr
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
systemClock_MONOTONIC =
SystemClock
{ systemClockGetTime = clock_gettime #{const CLOCK_MONOTONIC}
, systemClockDiffTime = diffCTimeSpec
, 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
-- , systemClockName = "clock_gettime(CLOCK_MONOTONIC_RAW)"
-- }
clock_gettime :: #{type clockid_t} -> IO CTimeSpec
clock_gettime clk_id =
allocaBytes #{size struct timespec} $ \ptr -> do
throwErrnoIfMinus1_ "clock_gettime" $
c_clock_gettime clk_id ptr
peekCTimeSpec ptr
foreign import ccall "time.h clock_gettime"
c_clock_gettime :: #{type clockid_t}
-> Ptr CTimeSpec
-> IO CInt
#endif