module System.Posix.Timer (
Clock(..),
monotonicClock,
realtimeClock,
processTimeClock,
threadTimeClock,
getProcClock,
getClockResolution,
getClockTime,
setClockTime,
clockSleep,
clockSleepAbs,
TimeSpec,
timeSpecSeconds,
timeSpecNanoseconds,
mkTimeSpec,
timeSpecV,
timeSpecToNum,
timeSpecToInt64,
ITimerSpec(..),
Timer,
createTimer,
configureTimer,
timerTimeLeft,
timerOverrunCnt,
destroyTimer
) where
import Data.Int
import Data.Word
import Data.Ratio (numerator)
import Foreign.Storable (Storable(..))
import Foreign.Ptr (Ptr, WordPtr, nullPtr, castPtr)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Marshal.Utils (with)
import Foreign.C.Types (CInt, CULong, CTime)
import Foreign.C.Error (getErrno, eINTR, throwErrno, throwErrnoIfMinus1,
throwErrnoIfMinus1_)
import System.Posix.Types (ProcessID)
import System.Posix.Signals (Signal)
import Unsafe.Coerce (unsafeCoerce)
nsPerSecond :: Num a => a
nsPerSecond = 1000000000
newtype Clock = Clock Int32 deriving (Eq, Ord, Show, Storable)
monotonicClock :: Clock
monotonicClock = Clock 1
realtimeClock :: Clock
realtimeClock = Clock 0
processTimeClock :: Clock
processTimeClock = Clock 2
threadTimeClock :: Clock
threadTimeClock = Clock 3
data TimeSpec = TimeSpec { timeSpecSeconds :: CTime
, timeSpecNanoseconds :: CULong
} deriving (Eq, Show)
mkTimeSpec :: CTime -> CULong -> TimeSpec
mkTimeSpec seconds nanoseconds =
case nanoseconds of
ns | ns >= nsPerSecond ->
TimeSpec (seconds + (fromIntegral q)) r
where (q, r) = ns `quotRem` nsPerSecond
_ -> TimeSpec seconds nanoseconds
timeSpecV :: TimeSpec -> (CTime, CULong)
timeSpecV (TimeSpec s ns) = (s, ns)
timeSpecToNum :: Num a => TimeSpec -> a
timeSpecToNum = fromInteger . numerator . toRational
timeSpecToInt64 :: TimeSpec -> Int64
timeSpecToInt64 (TimeSpec s ns) =
let ns64 = fromIntegral ns in
(unsafeCoerce s :: Int64) * nsPerSecond +
if s >= 0 then ns64 else ns64
instance Ord TimeSpec where
(TimeSpec s1 ns1) `compare` (TimeSpec s2 ns2) =
case s1 `compare` s2 of
EQ -> ns1 `compare` ns2
x -> x
instance Bounded TimeSpec where
minBound = TimeSpec (fromIntegral (minBound :: Int32)) 0
maxBound = TimeSpec (fromIntegral (maxBound :: Int32))
(nsPerSecond 1)
instance Num TimeSpec where
(TimeSpec s1 ns1) * (TimeSpec s2 ns2) =
mkTimeSpec (s1 * s2 * nsPerSecond +
s1 * (fromIntegral ns2) + s2 * (fromIntegral ns1) +
(fromIntegral q)) $ fromIntegral r
where (q, r) = ((fromIntegral ns1 :: Word64) *
(fromIntegral ns2 :: Word64)) `quotRem` nsPerSecond
(TimeSpec s1 ns1) + (TimeSpec s2 ns2) = mkTimeSpec (s1 + s2) (ns1 + ns2)
(TimeSpec s1 ns1) (TimeSpec s2 ns2) =
if ns1 < ns2 then TimeSpec (s1 s2 1) (nsPerSecond ns2 + ns1)
else TimeSpec (s1 s2) (ns1 ns2)
negate (TimeSpec s ns) = mkTimeSpec ((s) 1) (nsPerSecond ns)
abs ts@(TimeSpec s _) = if s >= 0 then ts else negate ts
signum (TimeSpec s _) =
TimeSpec 0 (if s < 0 then 1 else (if s == 0 then 0 else nsPerSecond 1))
fromInteger i = TimeSpec (fromInteger s) (fromInteger ns)
where (s, ns) = i `divMod` nsPerSecond
instance Real TimeSpec where
toRational (TimeSpec s ns) =
let rns = toRational ns in
toRational s * nsPerSecond + if s >= 0 then rns else rns
instance Storable TimeSpec where
alignment _ = 4
sizeOf _ = (8)
peek p = do
seconds <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
nanoseconds <- (\hsc_ptr -> peekByteOff hsc_ptr 4) p
return $ TimeSpec seconds nanoseconds
poke p (TimeSpec seconds nanoseconds) = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p seconds
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p nanoseconds
data ITimerSpec = ITimerSpec { iTimerSpecInterval :: !TimeSpec
, iTimerSpecValue :: !TimeSpec
} deriving (Eq, Show)
instance Storable ITimerSpec where
alignment _ = 4
sizeOf _ = (16)
peek p = do
interval <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
value <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
return $ ITimerSpec interval value
poke p (ITimerSpec interval value) = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p interval
(\hsc_ptr -> pokeByteOff hsc_ptr 8) p value
newtype Timer = Timer Word32 deriving (Eq, Ord, Show, Storable)
getProcClock :: ProcessID -> IO Clock
getProcClock pid = do
alloca $ \p -> do
throwErrnoIfMinus1_ "getProcClock" $ c_clock_getcpuclockid pid p
peek p
getClockResolution :: Clock -> IO TimeSpec
getClockResolution clock = do
alloca $ \p -> do
throwErrnoIfMinus1_ "getClockResolution" $ c_clock_getres clock p
peek p
getClockTime :: Clock -> IO TimeSpec
getClockTime clock = do
alloca $ \p -> do
throwErrnoIfMinus1_ "getClockTime" $ c_clock_gettime clock p
peek p
setClockTime :: Clock -> TimeSpec -> IO ()
setClockTime clock ts =
with ts $ throwErrnoIfMinus1_ "setClockTime" . c_clock_settime clock
clockSleep :: Clock -> TimeSpec -> IO TimeSpec
clockSleep clock ts =
with ts $ \pTs ->
alloca $ \pLeft -> do
result <- c_clock_nanosleep clock 0 pTs pLeft
if result == 0
then return 0
else do
errno <- getErrno
if errno == eINTR
then peek pLeft
else throwErrno "clockSleep"
clockSleepAbs :: Clock -> TimeSpec -> IO ()
clockSleepAbs clock ts =
with ts $ \p ->
throwErrnoIfMinus1_ "clockSleepAbs" $
c_clock_nanosleep clock 1 p nullPtr
createTimer :: Clock
-> Maybe (Signal, WordPtr)
-> IO Timer
createTimer clock sigEvent = do
alloca $ \pTimer -> do
throwErrnoIfMinus1_ "createTimer" $
case sigEvent of
Just (signal, ud) -> do
allocaBytes (64) $ \pEv -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 8) pEv
(0 :: CInt)
(\hsc_ptr -> pokeByteOff hsc_ptr 4) pEv signal
(\hsc_ptr -> pokeByteOff hsc_ptr 0) pEv ud
c_timer_create clock (castPtr $ (pEv :: Ptr Word8)) pTimer
Nothing ->
c_timer_create clock nullPtr pTimer
peek pTimer
configureTimer :: Timer
-> Bool
-> TimeSpec
-> TimeSpec
-> IO (TimeSpec, TimeSpec)
configureTimer timer absolute value interval =
with (ITimerSpec interval value) $ \pNew ->
alloca $ \pOld -> do
throwErrnoIfMinus1_ "configureTimer" $
c_timer_settime timer
(if absolute then 1 else 0) pNew pOld
(ITimerSpec oldInterval oldValue) <- peek pOld
return (oldValue, oldInterval)
timerTimeLeft :: Timer -> IO (TimeSpec, TimeSpec)
timerTimeLeft timer = do
alloca $ \p -> do
throwErrnoIfMinus1_ "timerTimeLeft" $ c_timer_gettime timer p
(ITimerSpec interval value) <- peek p
return (value, interval)
timerOverrunCnt :: Timer -> IO CInt
timerOverrunCnt timer =
throwErrnoIfMinus1 "timerOverrunCnt" $ c_timer_getoverrun timer
destroyTimer :: Timer -> IO ()
destroyTimer timer = throwErrnoIfMinus1_ "deleteTimer" $ c_timer_delete timer
foreign import ccall unsafe "clock_getcpuclockid"
c_clock_getcpuclockid :: ProcessID -> Ptr Clock -> IO CInt
foreign import ccall unsafe "clock_getres"
c_clock_getres :: Clock -> Ptr TimeSpec -> IO CInt
foreign import ccall unsafe "clock_gettime"
c_clock_gettime :: Clock -> Ptr TimeSpec -> IO CInt
foreign import ccall unsafe "clock_settime"
c_clock_settime :: Clock -> Ptr TimeSpec -> IO CInt
foreign import ccall unsafe "clock_nanosleep"
c_clock_nanosleep :: Clock -> CInt -> Ptr TimeSpec -> Ptr TimeSpec -> IO CInt
foreign import ccall unsafe "timer_create"
c_timer_create :: Clock -> Ptr () -> Ptr Timer -> IO CInt
foreign import ccall unsafe "timer_settime"
c_timer_settime ::
Timer -> CInt -> Ptr ITimerSpec -> Ptr ITimerSpec -> IO CInt
foreign import ccall unsafe "timer_gettime"
c_timer_gettime :: Timer -> Ptr ITimerSpec -> IO CInt
foreign import ccall unsafe "timer_getoverrun"
c_timer_getoverrun :: Timer -> IO CInt
foreign import ccall unsafe "timer_delete"
c_timer_delete :: Timer -> IO CInt