diff --git a/quasar.cabal b/quasar.cabal index 631185b4c0c4b5a2e607cdcf210e5001b99f7280..1ceaeea1d384d5f9a66ac2b780ced269b1582383 100644 --- a/quasar.cabal +++ b/quasar.cabal @@ -98,6 +98,7 @@ library Quasar.Subscribable Quasar.Timer Quasar.Timer.PosixTimer + Quasar.Timer.TimerFd Quasar.Utils.Exceptions Quasar.Utils.ExtraT hs-source-dirs: diff --git a/src/Quasar/Timer/PosixTimer.hsc b/src/Quasar/Timer/PosixTimer.hsc index 74c1e0d60b064b784e19a91a3f17b7ac02753cff..efc461f010a34d05d957293e52b28ca24ebb12a2 100644 --- a/src/Quasar/Timer/PosixTimer.hsc +++ b/src/Quasar/Timer/PosixTimer.hsc @@ -2,9 +2,12 @@ module Quasar.Timer.PosixTimer ( ClockId(..), + toCClockId, TimerSetTimeMode(..), CTimeSpec(..), + defaultCTimeSpec, CITimerSpec(..), + defaultCITimerSpec, newPosixTimer, newUnmanagedPosixTimer, setPosixTimer, diff --git a/src/Quasar/Timer/TimerFd.hs b/src/Quasar/Timer/TimerFd.hs new file mode 100644 index 0000000000000000000000000000000000000000..7921259c80710bdba689b2876b456a53fe6c23bb --- /dev/null +++ b/src/Quasar/Timer/TimerFd.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CApiFFI #-} + +module Quasar.Timer.TimerFd ( + TimerFd, + newTimerFd, + setTimer, + setInterval, + disarm, +) where + +import Control.Concurrent +import Control.Monad.Catch +import Foreign +import Foreign.C +import GHC.Conc (closeFdWith) +import GHC.IO.Handle.FD +import Quasar.Awaitable +import Quasar.Async +import Quasar.Disposable +import Quasar.Prelude +import Quasar.ResourceManager +import Quasar.Timer.PosixTimer +import System.IO +import System.Posix.Types + + +foreign import capi "sys/timerfd.h timerfd_create" + c_timerfd_create :: CClockId -> CInt -> IO TimerFd + +foreign import capi "sys/timerfd.h timerfd_settime" + c_timerfd_settime :: TimerFd -> CInt -> Ptr CITimerSpec -> Ptr CITimerSpec -> IO CInt + +foreign import capi "unistd.h read" + c_timerfd_read :: TimerFd -> Ptr Word64 -> CSize -> IO CInt + +foreign import capi "unistd.h close" + c_timerfd_close :: TimerFd -> IO CInt + +foreign import capi "sys/timerfd.h value TFD_CLOEXEC" + c_TFD_CLOEXEC :: CInt + +newtype TimerFd = TimerFd Fd + deriving stock (Eq, Show) + deriving newtype Num + +newTimerFd :: MonadResourceManager m => ClockId -> IO () -> m TimerFd +newTimerFd clockId callback = mask_ do + timer <- liftIO $ runInBoundThread do + throwErrnoIfMinus1 "timerfd_create" do + c_timerfd_create (toCClockId clockId) c_TFD_CLOEXEC + + workerTask <- async $ liftIO $ worker timer + registerAsyncDisposeAction do + await $ isDisposed workerTask + timerFdClose timer + + pure timer + + where + worker :: TimerFd -> IO () + worker timer@(TimerFd fd) = forever do + -- Block until timer is expired using the GHC runtime. + -- The thread will be unblocked with an `AsyncCancelled`-Exception, so + -- (contrary to the documentation) `closeFdWith` should not be necessary + -- when closing the fd. + threadWaitRead fd + elapsed <- timerFdRead timer + traceShowIO elapsed + callback + + +setTimer :: TimerFd -> TimerSetTimeMode -> CTimeSpec -> IO () +setTimer timer mode timeSpec = setInterval timer mode itspec + where + itspec = defaultCITimerSpec { + it_value = timeSpec + } + +setInterval :: TimerFd -> TimerSetTimeMode -> CITimerSpec -> IO () +setInterval timer mode iTimerSpec = do + alloca \newValue -> do + poke newValue iTimerSpec + throwErrnoIfMinus1_ "timer_settime" do + c_timerfd_settime timer 0 newValue nullPtr + +disarm :: TimerFd -> IO () +disarm timer = setInterval timer TimeRelative defaultCITimerSpec + + +timerFdRead :: TimerFd -> IO Word64 +timerFdRead timer = do + alloca \ptr -> do + throwErrnoIfMinus1 "timerfd_read" do + c_timerfd_read timer ptr 8 + peek ptr + +timerFdClose :: TimerFd -> IO () +timerFdClose timer = throwErrnoIfMinus1_ "timerfd_close" $ c_timerfd_close timer