How to reduce the time deviation when using threads?

Question

Here is the attempt to make a simple piece of code, that would get the current time and hypothetically trigger a function when time is right.

{-# LANGUAGE BlockArguments, NumericUnderscores #-}

module Main where

import Control.Concurrent
import Control.Monad (forever, forM, void)
import Data.Time.Clock

main :: IO ()
main = forever do
    forkIO writer
    threadDelay 1_000_000

writer :: IO ()
writer = print =<< getCurrentTime

And is get this:

2021-12-13 09:22:08.7632491 UTC
2021-12-13 09:22:09.7687358 UTC
2021-12-13 09:22:10.7756821 UTC
2021-12-13 09:22:11.7772306 UTC
2021-12-13 09:22:12.7954329 UTC
2021-12-13 09:22:13.8096189 UTC
2021-12-13 09:22:14.8218579 UTC
2021-12-13 09:22:15.826626 UTC
2021-12-13 09:22:16.8291541 UTC
2021-12-13 09:22:17.8358406 UTC
2021-12-13 09:22:18.8468617 UTC
2021-12-13 09:22:19.8490381 UTC
2021-12-13 09:22:20.859682 UTC
2021-12-13 09:22:21.868705 UTC
2021-12-13 09:22:22.88392 UTC
2021-12-13 09:22:23.8893969 UTC
2021-12-13 09:22:24.8940725 UTC
2021-12-13 09:22:25.9026013 UTC
2021-12-13 09:22:26.9181843 UTC
2021-12-13 09:22:27.920115 UTC
2021-12-13 09:22:28.9214061 UTC
2021-12-13 09:22:29.9236218 UTC
2021-12-13 09:22:30.9320501 UTC
2021-12-13 09:22:31.9359116 UTC
2021-12-13 09:22:32.9381218 UTC
2021-12-13 09:22:33.9541171 UTC
2021-12-13 09:22:34.9639691 UTC
2021-12-13 09:22:35.9767943 UTC
2021-12-13 09:22:36.9909998 UTC
2021-12-13 09:22:38.0016628 UTC
2021-12-13 09:22:39.0029746 UTC
2021-12-13 09:22:40.01921 UTC
2021-12-13 09:22:41.0337936 UTC
2021-12-13 09:22:42.0369494 UTC
2021-12-13 09:22:43.0403321 UTC
2021-12-13 09:22:44.0426835 UTC
2021-12-13 09:22:45.0468416 UTC
2021-12-13 09:22:46.0503551 UTC
2021-12-13 09:22:47.0557148 UTC
2021-12-13 09:22:48.066979 UTC
2021-12-13 09:22:49.0723431 UTC

As you might have noticed, the differences are not exact and faults in the timedif can be crucial in my case. Any ways to improve this?

Tried the option when a different thread takes the print function, but makes little difference in the long run.

Thank you!

Answer 1

Now, here's an answer to your original question. The secret is that instead of always waiting for a second between events, you should keep track of a trigger time, always increment it by a second, and wait whatever amount of time is needed to get to the next trigger time. It's actually similar to my other answer in many respects:

{-# LANGUAGE NumericUnderscores #-}

module Main where

import Control.Concurrent
import Control.Monad
import Data.Time

main :: IO ()
main = everySecond =<< getCurrentTime

everySecond :: UTCTime -> IO ()
everySecond tick = do
  forkIO writer
  -- next tick in one second
  let nexttick = addUTCTime (secondsToNominalDiffTime 1) tick
  now <- getCurrentTime
  let wait = nominalDiffTimeToSeconds (diffUTCTime nexttick now)
  threadDelay $ ceiling (wait * 1_000_000)
  everySecond nexttick

writer :: IO ()
writer = print =<< getCurrentTime

Sample output:

2021-12-13 21:16:53.316687476 UTC
2021-12-13 21:16:54.318070692 UTC
2021-12-13 21:16:55.31821399 UTC
2021-12-13 21:16:56.318432887 UTC
2021-12-13 21:16:57.318432582 UTC
2021-12-13 21:16:58.318648861 UTC
2021-12-13 21:16:59.317988137 UTC
2021-12-13 21:17:00.318367675 UTC
2021-12-13 21:17:01.318565036 UTC
2021-12-13 21:17:02.317856019 UTC
2021-12-13 21:17:03.318285608 UTC
2021-12-13 21:17:04.318508451 UTC
2021-12-13 21:17:05.318487069 UTC
2021-12-13 21:17:06.318435325 UTC
2021-12-13 21:17:07.318504691 UTC
2021-12-13 21:17:08.318591666 UTC
2021-12-13 21:17:09.317797443 UTC
2021-12-13 21:17:10.317732578 UTC
2021-12-13 21:17:11.318100396 UTC
2021-12-13 21:17:12.318535002 UTC
2021-12-13 21:17:13.318008916 UTC
2021-12-13 21:17:14.317803441 UTC
2021-12-13 21:17:15.318220664 UTC
2021-12-13 21:17:16.318558786 UTC
2021-12-13 21:17:17.31793816 UTC
2021-12-13 21:17:18.322564881 UTC
2021-12-13 21:17:19.318923334 UTC
2021-12-13 21:17:20.318293808 UTC

Answer 2

Not quite an answer to your question, but if you want to write a program to trigger events at specific times, a more robust design is:

1. Sort the list of (time,event) pairs by time
2. Sleep for the difference between the first event time in the list and the current time
3. When you wake up, get/update the current time, and execute and remove from the front of the list all events whose time has "expired" (i.e., event time on or before the current time).
4. If the list is still non-empty, jump to step 2.

This avoids the need to poll every second (which maybe isn't a big deal, but still...) and avoids the possibility that events will be missed because you woke up later than expected.

An example program follows. (This program relies on threadDelay treating negative numbers the same as zero, in case the events take a long time to run, and the actual time overruns the first unexpired event.)

{-# LANGUAGE NumericUnderscores #-}

import Data.List
import Data.Time
import Control.Concurrent

data Event = Event
  { eventTime :: UTCTime
  , eventAction :: IO ()
  }

runEvents :: [Event] -> IO ()
runEvents = go . sortOn eventTime
  where go [] = return ()  -- no more events
        go events@(Event firstTime _ : _) = do
          now <- getCurrentTime
          let wait = nominalDiffTimeToSeconds (diffUTCTime firstTime now)
          threadDelay $ ceiling (wait * 1_000_000)
          now' <- getCurrentTime
          let (a, b) = span (expiredAsOf now') events
          mapM eventAction a  -- run the expired events
          go b  -- wait for the rest

        expiredAsOf t e = eventTime e <= t

main = do
  -- some example events
  now <- getCurrentTime
  let afterSeconds = flip addUTCTime now . secondsToNominalDiffTime
      evts = [ Event (afterSeconds 3) (putStrLn "3 seconds")
             , Event (afterSeconds 6) (putStrLn "6 seconds action # 1")
             , Event (afterSeconds 6) (putStrLn "6 seconds action # 2")
             , Event (afterSeconds 7) (putStrLn "Done after 7 seconds")
             ]
  runEvents evts