Compute as much of a list as possible in a fixed time

Question

I want to write a function that takes a time limit (in seconds) and a list, and computes as many elements of the list as possible within the time limit.

My first attempt was to first write the following function, which times a pure computation and returns the time elapsed along with the result:

import Control.DeepSeq
import System.CPUTime

type Time = Double

timed :: (NFData a) => a -> IO (a, Time)
timed x = do t1 <- getCPUTime
             r  <- return $!! x
             t2 <- getCPUTime
             let diff = fromIntegral (t2 - t1) / 10^12
             return (r, diff)

I can then define the function I want in terms of this:

timeLimited :: (NFData a) => Time -> [a] -> IO [a]
timeLimited remaining []     = return []
timeLimited remaining (x:xs) = if remaining < 0
    then return []
    else do
        (y,t) <- timed x
        ys    <- timeLimited (remaining - t) xs
        return (y:ys)

This isn't quite right though. Even ignoring timing errors and floating point errors, this approach never stops the computation of an element of the list once it has started, which means that it can (and in fact, normally will) overrun its time limit.

If instead I had a function that could short-circuit evaluation if it had taken too long:

timeOut :: Time -> a -> IO (Maybe (a,t))
timeOut = undefined

then I could write the function that I really want:

timeLimited' :: Time -> [a] -> IO [a]
timeLimited' remaining []     = return []
timeLimited' remaining (x:xs) = do
    result <- timeOut remaining x
    case result of
        Nothing    -> return []
        Just (y,t) -> do
            ys <- timeLimited' (remaining - t) xs
            return (y:ys)

My questions are:

1. How do I write timeOut?
2. Is there a better way to write the function timeLimited, for example, one that doesn't suffer from accumulated floating point error from adding up time differences multiple times?

Answer 1

Here's an example I was able to cook up using some of the suggestions above. I've not done huge amounts of testing to ensure work is cut off exactly when the timer runs out, but based on the docs for timeout, this should work for all things not using FFI.

import Control.Concurrent.STM import Control.DeepSeq import System.Timeout  type Time = Int  -- | Compute as many items of a list in given timeframe (microseconds) --   This is done by running a function that computes (with `force`) --   list items and pushed them onto a `TVar [a]`.  When the requested time --   expires, ghc will terminate the execution of `forceIntoTVar`, and we'll --   return what has been pushed onto the tvar. timeLimited :: (NFData a) => Time -> [a] -> IO [a] timeLimited t xs = do     v <- newTVarIO []     _ <- timeout t (forceIntoTVar xs v)     readTVarIO v   -- | Force computed values into given tvar forceIntoTVar :: (NFData a) => [a] -> TVar [a] -> IO [()] forceIntoTVar xs v = mapM (atomically . modifyTVar v . forceCons) xs  -- | Returns function that does actual computation and cons' to tvar value forceCons :: (NFData a) => a -> [a] -> [a] forceCons x = (force x:) 

Now let's try it on something costly:

main = do     xs <- timeLimited 100000 expensiveThing   -- run for 100 milliseconds     print $ length $ xs  -- how many did we get?  -- | Some high-cost computation expensiveThing :: [Integer] expensiveThing = sieve [2..]   where       sieve (p:xs) = p : sieve [x|x <- xs, x `mod` p > 0] 

Compiled and run with time, it seems to work (obviously there is some overhead outside the timed portion, but I'm at roughly 100ms:

$ time ./timeLimited 1234 ./timeLimited  0.10s user 0.01s system 97% cpu 0.112 total 

Also, something to note about this approach; since I'm enclosing the entire operation of running the computations and pushing them onto the tvar inside one call to timeout, some time here is likely lost in creating the return structure, though I'm assuming (if your computations are costly) it won't account or much of your overall time.

Update

Now that I've had some time to think about it, due to Haskell's laziness, I'm not 100% positive the note above (about time-spent creating the return structure) is correct; either way, let me know if this is not precise enough for what you are trying to accomplish.

Answer 2

You can implement timeOut with the type you gave using timeout and evaluate. It looks something like this (I've omitted the part that computes how much time is left -- use getCurrentTime or similar for that):

timeoutPure :: Int -> a -> IO (Maybe a)
timeoutPure t a = timeout t (evaluate a)

If you want more forcing than just weak-head normal form, you can call this with an already-seq'd argument, e.g. timeoutPure (deepseq v) instead of timeoutPure v.

Answer 3

I would use two threads together with TVars and raise an exception (that causes every ongoing transaction to be rolled back) in the computation thread when the timeout has been reached:

forceIntoTVar :: (NFData a) => [a] -> TVar [a] -> IO [()]
forceIntoTVar xs v = mapM (atomically . modifyTVar v . forceCons) xs

-- | Returns function that does actual computation and cons' to tvar value
forceCons :: (NFData a) => a -> [a] -> [a]
forceCons x = (force x:)

main = do

  v <- newTVarIO []
  tID <- forkIO $ forceIntoTVar args v
  threadDelay 200
  killThread tID
  readTVarIO v 

In this example you (may) need to adjust forceIntoTVar a bit so that e.g. the list nodes are NOT computet inside the atomic transaction but first computed and then a atomic transaction is started to cons them onto the list.

In any case, when the exception is raised the ongoing transaction is rolled back or the ongoing computation is stopped before the result is consed to the list and that is what you want.

What you need to consider is that when the individual computations to prepare a node run with high frequency then this example is probably very costly compared to not using STM.