Added a test for 'timeout' to be accurate.
authorTom Sydney Kerckhove <syd@fpcomplete.com>
Wed, 18 Oct 2017 20:27:56 +0000 (16:27 -0400)
committerBen Gamari <ben@smart-cactus.org>
Thu, 19 Oct 2017 20:40:09 +0000 (16:40 -0400)
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

libraries/base/tests/all.T
libraries/base/tests/timeout-accurate-pure.hs [new file with mode: 0644]
libraries/base/tests/timeout-accurate-pure.stdout [new file with mode: 0644]

index 9055bd5..a1eba6a 100644 (file)
@@ -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 (file)
index 0000000..a59e785
--- /dev/null
@@ -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 (file)
index 0000000..90f4a4c
--- /dev/null
@@ -0,0 +1,2 @@
+delta > 0: True
+delta < legroom: True