diff --git a/src/Quasar/Timer/PosixTimer.hsc b/src/Quasar/Timer/PosixTimer.hsc index 869c4e95823133181ae3b3cce410f6656ec327a1..74c1e0d60b064b784e19a91a3f17b7ac02753cff 100644 --- a/src/Quasar/Timer/PosixTimer.hsc +++ b/src/Quasar/Timer/PosixTimer.hsc @@ -1,9 +1,14 @@ {-# LANGUAGE CApiFFI #-} module Quasar.Timer.PosixTimer ( - CTimeSpec, - CITimerSpec, - boottime, + ClockId(..), + TimerSetTimeMode(..), + CTimeSpec(..), + CITimerSpec(..), + newPosixTimer, + newUnmanagedPosixTimer, + setPosixTimer, + setPosixIntervalTimer, ) where import Control.Concurrent @@ -11,6 +16,7 @@ import Foreign import Foreign.C import Quasar.Disposable import Quasar.Prelude +import Quasar.ResourceManager import System.Posix.Types #include <signal.h> @@ -36,6 +42,51 @@ foreign import ccall "wrapper" type SigevNotifyFunction = (Ptr Void -> IO ()) +data ClockId + = Realtime + | Monotonic + | ProcessCputime + | ThreadCputime + | Boottime + | RealtimeAlarm + | BoottimeAlarm + | Tai + +toCClockId :: ClockId -> CClockId +toCClockId Realtime = c_CLOCK_REALTIME +toCClockId Monotonic = c_CLOCK_MONOTONIC +toCClockId ProcessCputime = c_CLOCK_PROCESS_CPUTIME_ID +toCClockId ThreadCputime = c_CLOCK_THREAD_CPUTIME_ID +toCClockId Boottime = c_CLOCK_BOOTTIME +toCClockId RealtimeAlarm = c_CLOCK_REALTIME_ALARM +toCClockId BoottimeAlarm = c_CLOCK_BOOTTIME_ALARM +toCClockId Tai = c_CLOCK_TAI + +foreign import capi "time.h value CLOCK_REALTIME" + c_CLOCK_REALTIME :: CClockId + +foreign import capi "time.h value CLOCK_MONOTONIC" + c_CLOCK_MONOTONIC :: CClockId + +foreign import capi "time.h value CLOCK_PROCESS_CPUTIME_ID" + c_CLOCK_PROCESS_CPUTIME_ID :: CClockId + +foreign import capi "time.h value CLOCK_THREAD_CPUTIME_ID" + c_CLOCK_THREAD_CPUTIME_ID :: CClockId + +foreign import capi "time.h value CLOCK_BOOTTIME" + c_CLOCK_BOOTTIME :: CClockId + +foreign import capi "time.h value CLOCK_REALTIME_ALARM" + c_CLOCK_REALTIME_ALARM :: CClockId + +foreign import capi "time.h value CLOCK_BOOTTIME_ALARM" + c_CLOCK_BOOTTIME_ALARM :: CClockId + +foreign import capi "time.h value CLOCK_TAI" + c_CLOCK_TAI :: CClockId + + data {-# CTYPE "struct timespec" #-} CTimeSpec = CTimeSpec { tv_sec :: CTime, @@ -81,9 +132,6 @@ instance Storable CITimerSpec where defaultCITimerSpec :: CITimerSpec defaultCITimerSpec = CITimerSpec defaultCTimeSpec defaultCTimeSpec -foreign import capi "time.h value CLOCK_BOOTTIME" - c_CLOCK_BOOTTIME :: CClockId - foreign import capi "time.h timer_create" c_timer_create :: CClockId -> Ptr CSigEvent -> Ptr CTimer -> IO CInt @@ -94,17 +142,30 @@ foreign import capi "time.h timer_settime" foreign import capi "time.h timer_delete" c_timer_delete :: CTimer -> IO CInt +foreign import capi "time.h value TIMER_ABSTIME" + c_TIMER_ABSTIME :: CInt + +data TimerSetTimeMode = TimeRelative | TimeAbsolute + +toCSetTimeFlags :: TimerSetTimeMode -> CInt +toCSetTimeFlags TimeRelative = 0 +toCSetTimeFlags TimeAbsolute = c_TIMER_ABSTIME + data PosixTimer = PosixTimer { ctimer :: CTimer, - callbackPtr :: (FunPtr SigevNotifyFunction) + disposable :: Disposable } instance IsDisposable PosixTimer where - toDisposable = undefined + toDisposable = disposable -newUnmanagedPosixTimer :: CClockId -> IO () -> IO PosixTimer +newPosixTimer :: MonadResourceManager m => ClockId -> IO () -> m PosixTimer +newPosixTimer clockId callback = registerNewResource do + liftIO $ newUnmanagedPosixTimer clockId callback + +newUnmanagedPosixTimer :: ClockId -> IO () -> IO PosixTimer newUnmanagedPosixTimer clockId callback = runInBoundThread do callbackPtr <- mkSigevNotifyFunction (const callback) @@ -112,51 +173,33 @@ newUnmanagedPosixTimer clockId callback = runInBoundThread do alloca \sigevent -> do poke sigevent $ CSigEventThreadCallback callbackPtr throwErrnoIfMinus1_ "timer_create" do - c_timer_create c_CLOCK_BOOTTIME sigevent ctimerPtr + c_timer_create (toCClockId clockId) sigevent ctimerPtr peek ctimerPtr - pure $ PosixTimer { ctimer, callbackPtr } + disposable <- newDisposable (delete ctimer callbackPtr) -setPosixTimer :: PosixTimer -> Maybe CTimeSpec -> IO () -setPosixTimer PosixTimer{ctimer} timeSpec = do - alloca \newValue -> do - poke newValue $ defaultCITimerSpec { - it_value = fromMaybe defaultCTimeSpec timeSpec + pure $ PosixTimer { ctimer, disposable } + where + delete :: CTimer -> FunPtr SigevNotifyFunction -> IO () + delete ctimer callbackPtr = do + c_timer_delete ctimer + -- "The treatment of any pending signal generated by the deleted timer is unspecified." + freeHaskellFunPtr callbackPtr + + +setPosixTimer :: PosixTimer -> TimerSetTimeMode -> CTimeSpec -> IO () +setPosixTimer timer mode timeSpec = setPosixIntervalTimer timer mode itspec + where + itspec = defaultCITimerSpec { + it_value = timeSpec } - throwErrnoIfMinus1_ "timer_settime" do - c_timer_settime ctimer 0 newValue nullPtr -setPosixIntervalTimer :: PosixTimer -> CITimerSpec -> IO () -setPosixIntervalTimer PosixTimer{ctimer} iTimerSpec = do +setPosixIntervalTimer :: PosixTimer -> TimerSetTimeMode -> CITimerSpec -> IO () +setPosixIntervalTimer PosixTimer{ctimer} mode iTimerSpec = do alloca \newValue -> do poke newValue iTimerSpec throwErrnoIfMinus1_ "timer_settime" do - c_timer_settime ctimer 0 newValue nullPtr - - - - -boottime :: IO () -boottime = runInBoundThread do - - callbackPtr <- mkSigevNotifyFunction callback + c_timer_settime ctimer (toCSetTimeFlags mode) newValue nullPtr - ctimer <- alloca \ctimerPtr -> do - alloca \sigevent -> do - poke sigevent $ CSigEventThreadCallback callbackPtr - throwErrnoIfMinus1_ "timer_create" do - c_timer_create c_CLOCK_BOOTTIME sigevent ctimerPtr - peek ctimerPtr - - alloca \newValue -> do - poke newValue oneSecond - throwErrnoIfMinus1_ "timer_settime" do - c_timer_settime ctimer 0 newValue nullPtr - where - oneSecond = defaultCITimerSpec { - it_value = defaultCTimeSpec { - tv_sec = 1 - } - } - callback :: Ptr Void -> IO () - callback _ = traceIO "callback" +disarmPosixTimer :: PosixTimer -> IO () +disarmPosixTimer timer = setPosixIntervalTimer timer TimeRelative defaultCITimerSpec