[commit: ghc] master: Added a test for 'timeout' to be accurate. (13758c6)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/13758c6cfec1cfc8211d8c549ab69ee269f15b1e/ghc

>---------------------------------------------------------------

commit 13758c6cfec1cfc8211d8c549ab69ee269f15b1e
Author: Tom Sydney Kerckhove <syd at fpcomplete.com>
Date:   Wed Oct 18 16:27:56 2017 -0400

    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


>---------------------------------------------------------------

13758c6cfec1cfc8211d8c549ab69ee269f15b1e
 libraries/base/tests/all.T                        |  1 +
 libraries/base/tests/timeout-accurate-pure.hs     | 28 +++++++++++++++++++++++
 libraries/base/tests/timeout-accurate-pure.stdout |  2 ++
 3 files changed, 31 insertions(+)

diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 9055bd5..a1eba6a 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 0000000..a59e785
--- /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 0000000..90f4a4c
--- /dev/null
+++ b/libraries/base/tests/timeout-accurate-pure.stdout
@@ -0,0 +1,2 @@
+delta > 0: True
+delta < legroom: True