Commit 13758c6c authored by Tom Sydney Kerckhove's avatar Tom Sydney Kerckhove Committed by Ben Gamari

Added a test for 'timeout' to be accurate.

This is the first in a series of regression tests prompted by
https://ghc.haskell.org/trac/ghc/ticket/8684 and D4011, D4012, D4041

Test Plan: This _is_ a test.

Reviewers: nh2, austin, hvr, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #8684

Differential Revision: https://phabricator.haskell.org/D4074
parent 1ba28510
......@@ -190,6 +190,7 @@ test('T8089',
[exit_code(99), run_timeout_multiplier(0.01)],
compile_and_run, [''])
test('T8684', expect_broken(8684), compile_and_run, [''])
test('timeout-accurate-pure', normal, compile_and_run, [''])
test('T9826',normal, compile_and_run,[''])
test('T9848',
[ stats_num_field('bytes allocated',
......
import Control.Concurrent
import Control.Monad
import GHC.Clock
import System.IO
import System.Timeout
ack :: Integer -> Integer -> Integer
ack 0 n = n + 1
ack m 0 = ack (m - 1) 1
ack m n = ack (m - 1) (ack m (n - 1))
main :: IO ()
main = do
let microsecondsPerSecond = 1000 * 1000
let timeToSpend = 1 * microsecondsPerSecond -- One second in microseconds
start <- getMonotonicTimeNSec
timeout timeToSpend $
-- Something that is guaranteed not to be done in 'timeToSpend'
print $ ack 4 2
end <- getMonotonicTimeNSec
let timeSpentNano = fromIntegral $ end - start -- in nanoseconds
let nanosecondsPerMicrosecond = 1000
let timeToSpendNano = timeToSpend * nanosecondsPerMicrosecond
let legRoom = 1 * 1000 * nanosecondsPerMicrosecond -- Nanoseconds
let delta = timeSpentNano - timeToSpendNano
-- We can never wait for a shorter amount of time than specified
putStrLn $ "delta > 0: " ++ show (delta > 0)
putStrLn $ "delta < legroom: " ++ show (delta < legRoom)
delta > 0: True
delta < legroom: True
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment