[commit: ghc] wip/T11731: Add a test case for #11731. (f5bab40)

[git at git.haskell.org]

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

On branch  : wip/T11731
Link       : http://ghc.haskell.org/trac/ghc/changeset/f5bab40a33141fec9bdc734dc086575dab84ff84/ghc

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

commit f5bab40a33141fec9bdc734dc086575dab84ff84
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Mar 30 12:55:10 2016 +0200

    Add a test case for #11731.


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

f5bab40a33141fec9bdc734dc086575dab84ff84
 testsuite/.gitignore                               |  1 +
 testsuite/tests/simplCore/should_run/T11731.hs     | 36 ++++++++++++++++++++++
 testsuite/tests/simplCore/should_run/T11731.stderr |  1 +
 testsuite/tests/simplCore/should_run/all.T         |  1 +
 4 files changed, 39 insertions(+)

diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 655e3da..e1f1822 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1475,6 +1475,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
 /tests/simplCore/should_run/T5997
 /tests/simplCore/should_run/T7101
 /tests/simplCore/should_run/T7924
+/tests/simplCore/should_run/T11731
 /tests/simplCore/should_run/T9128
 /tests/simplCore/should_run/T9390
 /tests/simplCore/should_run/runST
diff --git a/testsuite/tests/simplCore/should_run/T11731.hs b/testsuite/tests/simplCore/should_run/T11731.hs
new file mode 100644
index 0000000..e148507
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T11731.hs
@@ -0,0 +1,36 @@
+module Main (main ) where
+
+import Debug.Trace
+
+foo :: (a,b) -> a
+foo (x,y) = x
+{-# NOINLINE foo #-}
+
+wwMe :: Int -> (Int,Int) -> (Int, Int)
+wwMe 0 p =
+    let a = fst p
+        b = snd p
+        -- This ensure sharing of b, as seen by the demand analyzer
+
+    in foo p `seq`
+       -- This ensures that wwMe is strict in the tuple, but that the tuple
+       -- is preserved.
+       (b + a, a + b)
+
+wwMe n p = wwMe (n-1) (0,0)
+    -- ^ Make it recursive, so that it is attractive to worker-wrapper
+
+go :: Int -> IO ()
+go seed = do
+    let shareMeThunk = trace "Evaluated (should only happen once)" (seed + 1)
+        {-# NOINLINE shareMeThunk #-}
+        -- ^ This is the thunk that is wrongly evaluated twice.
+
+    let (x,y) = wwMe 0 (seed,shareMeThunk)
+
+    (x + y) `seq` return ()
+    -- ^ Use both components
+{-# NOINLINE go #-}
+
+main :: IO ()
+main = go 42
diff --git a/testsuite/tests/simplCore/should_run/T11731.stderr b/testsuite/tests/simplCore/should_run/T11731.stderr
new file mode 100644
index 0000000..8d1fc60
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T11731.stderr
@@ -0,0 +1 @@
+Evaluated (should only happen once)
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 9c15b0f..042c097 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -71,3 +71,4 @@ test('T9128', normal, compile_and_run, [''])
 test('T9390', normal, compile_and_run, [''])
 test('T10830', extra_run_opts('+RTS -K100k -RTS'), compile_and_run, [''])
 test('T11172', normal, compile_and_run, [''])
+test('T11731', expect_broken(11731), compile_and_run, ['-fspec-constr'])