Timing out computations

A problem that frequently arises is that of constructing an IO action which terminates after a given period of time, regardless of whether it has finished the computation it was intended to perform. There are a variety of ways in which this can be accomplished.

One implementation for various efficient timeout combinators can be found in HAppS.Util.TimeOut (GPL licenced).

One way is to consider the more general problem of executing a number of competing actions in parallel, and returning the result of the first to be finished its task, an interesting problem in and of itself.

What we do is to create an initially empty MVar, spawn threads for each of the competing computations, and have them all compete to execute their action and then put the result into the MVar. In the main thread we try to take from the MVar, which blocks until one of the threads completes its task. We then kill all of the threads, and return the winning result.

import Control.Concurrent

compete :: [IO a] -> IO a
compete actions = do
    mvar <- newEmptyMVar
    tids <- mapM (\action -> forkIO $ action >>= putMVar mvar) actions
    result <- takeMVar mvar
    mapM_ killThread tids
    return result

In order to implement the timeout, we just have two processes compete: the one to attempt, with its result wrapped in the Just constructor, and one which waits the specified time (in microseconds) and then returns Nothing.

timeout :: Int -> IO a -> IO (Maybe a)
timeout usec action = compete [fmap Just action, threadDelay usec >> return Nothing]

A related problem is that of iterating a pure function for as many steps as possible until a given time limit passes, and returning the last computed result afterward. One can achieve this again using threads as follows:

import Control.Concurrent
import Control.Exception

timeoutIterate msec f x = do
    mvar <- newMVar x
    let loop = do
           x <- takeMVar mvar
           evaluate (f x) >>= putMVar mvar
           loop
    thread <- forkIO loop
    threadDelay msec
    u <- takeMVar mvar
    killThread thread
    return u

Without threads, using getClockTime to check if enough time has passed, it looks like this:

import Control.Exception
import System.Time

getClockTimeMS = do
    (TOD s p) <- getClockTime
    return $ fromIntegral (s * 1000 + p `div` 10^6)

timeoutIterate' msec f x = do
    t <- getClockTimeMS
    y <- evaluate (f x)
    t' <- getClockTimeMS
    timeoutIterate (msec - (t' - t)) f y

Note that in both cases, the use of evaluate is important to ensure that all of the evaluation actually occurs in the given timeframe and not lazily afterward.

(The above example doesn't seem likely to work, how about this instead:)

-- microseconds
getClockTimeMS = do
    (TOD s p) <- getClockTime
    return $ fromIntegral (s * 1000000 + p `div` 10^6)
 
timeoutIterate msec f x = do
  t <- getClockTimeMS
  timeoutIterate' (t + msec) f x

timeoutIterate' fin f x = do
  t <- getClockTimeMS
  if t > fin then
      return x
    else 
      do y <- evaluate (f x)
         t' <- getClockTimeMS
         timeoutIterate' fin f y