Вычислить как можно больше списка за фиксированное время

Я хочу написать функцию, которая занимает лимит времени (в секундах) и список, и вычисляет как можно больше элементов списка в течение срока.

Моя первая попытка состояла в том, чтобы сначала написать следующую функцию, которая умножает время на чистое вычисление и возвращает время, прошедшее с результатом:

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)

Затем я могу определить функцию, которую я хочу в терминах:

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)

Это не совсем правильно. Даже игнорируя ошибки синхронизации и ошибки с плавающей запятой, этот подход никогда не останавливает вычисление элемента списка после его запуска, а это означает, что он может (и фактически нормально) превышать его временные ограничения.

Если бы вместо этого у меня была функция, которая могла бы провести короткую проверку, если бы она заняла слишком много времени:

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

тогда я мог бы написать нужную мне функцию:

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)

Мои вопросы:

Как написать timeOut?
Есть ли лучший способ написать функцию timeLimited, например, такую, которая не страдает от накопленной ошибки с плавающей запятой из суммирования разностей во времени несколько раз?

Ответ 1

Вот пример, который я смог приготовить, используя некоторые из приведенных выше предложений. Я не проводил огромное количество тестов, чтобы обеспечить прекращение работы, когда закончится таймер, но на основе документов для timeout это должно работать все вещи, не использующие 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:)

Теперь попробуем попробовать что-то дорогое:

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]

Скомпилированный и запущенный с time, он работает (очевидно, есть некоторая надстройка вне временной части, но я нахожусь примерно в 100 мс:

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

Кроме того, что-то примечание об этом подходе; так как я включаю всю операцию запуска вычислений и нажимаю их на твар внутри одного вызова timeout, некоторое время здесь, скорее всего, теряется при создании структуры возврата, хотя я предполагаю (если ваши вычисления являются дорогостоящими) он не будет учитываться или многое из вашего общего времени.

Обновление

Теперь, когда у меня было время подумать об этом, из-за ленивости Haskell, я не на 100% уверен, что примечание выше (о времени, затрачиваемом на создание структуры возврата), верно; в любом случае, дайте мне знать, если это недостаточно точно для того, что вы пытаетесь выполнить.

Ответ 2

Вы можете реализовать timeOut с типом, который вы указали с помощью timeOut и evaluate. Он выглядит примерно так (я пропустил часть, которая вычисляет, сколько осталось времени - используйте getCurrentTime или аналогичный для этого):

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

Если вы хотите больше форсировать, чем просто нормальную форму с слабой головой, вы можете называть это аргументом уже seq'd, например. timeoutPure (deepseq v) вместо timeoutPure v.

Ответ 3

Я бы использовал два потока вместе с TVars и создавал исключение (которое заставляет каждую текущую транзакцию откатываться) в потоке вычислений, когда таймаут был достигнут:

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

В этом примере вам (может быть) нужно немного изменить значение forceIntoTVar, чтобы, например, узлы списка представляют собой НЕ вычисление внутри атомной транзакции, но сначала вычисляются, а затем выполняется атомарная транзакция, чтобы переместить их в список.

В любом случае, когда возникает исключение, текущая транзакция откатывается или текущее вычисление останавливается до того, как результат будет передан в список, и это то, что вы хотите.

Что вам нужно учитывать, так это то, что, когда отдельные вычисления для подготовки node работают с высокой частотой, этот пример, вероятно, очень дорог по сравнению с использованием STM.