diff options
| author | Tom Sydney Kerckhove <syd@fpcomplete.com> | 2017-10-18 16:27:56 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-10-19 16:40:09 -0400 |
| commit | 13758c6cfec1cfc8211d8c549ab69ee269f15b1e (patch) | |
| tree | 30710631aae61ac115e4aac6f54d1f5f869feb7b | |
| parent | 1ba28510e0731d91fcab560269c4ed5950d5e458 (diff) | |
| download | haskell-13758c6cfec1cfc8211d8c549ab69ee269f15b1e.tar.gz | |
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
| -rw-r--r-- | libraries/base/tests/all.T | 1 | ||||
| -rw-r--r-- | libraries/base/tests/timeout-accurate-pure.hs | 28 | ||||
| -rw-r--r-- | libraries/base/tests/timeout-accurate-pure.stdout | 2 |
3 files changed, 31 insertions, 0 deletions
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 9055bd5b45..a1eba6a465 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -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', diff --git a/libraries/base/tests/timeout-accurate-pure.hs b/libraries/base/tests/timeout-accurate-pure.hs new file mode 100644 index 0000000000..a59e785a01 --- /dev/null +++ b/libraries/base/tests/timeout-accurate-pure.hs @@ -0,0 +1,28 @@ +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) diff --git a/libraries/base/tests/timeout-accurate-pure.stdout b/libraries/base/tests/timeout-accurate-pure.stdout new file mode 100644 index 0000000000..90f4a4c7e8 --- /dev/null +++ b/libraries/base/tests/timeout-accurate-pure.stdout @@ -0,0 +1,2 @@ +delta > 0: True +delta < legroom: True |