[commit: testsuite] master: Test Trac #7865 (b6454e2)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/testsuite

On branch  : master

https://github.com/ghc/testsuite/commit/b6454e2ae9949a3f407bc37583b7e0695ab1046d

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

commit b6454e2ae9949a3f407bc37583b7e0695ab1046d
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri May 3 11:43:57 2013 +0100

    Test Trac #7865

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

 tests/simplCore/should_compile/Makefile     |    4 +++
 tests/simplCore/should_compile/T7865.hs     |   29 +++++++++++++++++++++++++++
 tests/simplCore/should_compile/T7865.stdout |    4 +++
 tests/simplCore/should_compile/all.T        |    1 +
 4 files changed, 38 insertions(+), 0 deletions(-)

diff --git a/tests/simplCore/should_compile/Makefile b/tests/simplCore/should_compile/Makefile
index 215ed40..d87a211 100644
--- a/tests/simplCore/should_compile/Makefile
+++ b/tests/simplCore/should_compile/Makefile
@@ -2,6 +2,10 @@ TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
 
+T7865:
+	$(RM) -f T7865.o T7865.hi 
+	'$(TEST_HC)' $(TEST_HC_OPTS) -dsuppress-uniques -O2 -c -ddump-simpl T7865.hs | grep expensive
+
 T3055:
 	$(RM) -f T3055.o T3055.hi T3055.simpl
 	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c T3055.hs -ddump-simpl > T3055.simpl
diff --git a/tests/simplCore/should_compile/T7865.hs b/tests/simplCore/should_compile/T7865.hs
new file mode 100644
index 0000000..3ce5be7
--- /dev/null
+++ b/tests/simplCore/should_compile/T7865.hs
@@ -0,0 +1,29 @@
+module T7865 where
+
+-- Our very expensive operation that we don't want to perform more than once
+-- Don't inline it so we can see exactly where it's called in the core
+{-# NOINLINE expensive #-}
+expensive :: Int -> Int
+expensive x = x * 100000
+
+-- SpecConstr this function:
+recursive :: [Int] -> (Int,Int) -> (Int,Int)
+recursive list acc
+ = case list of
+   []     -> acc
+   (x:xs) ->
+     -- Our expensive tuple:
+     -- The case is here mainly so that the expensive let isn't floated out before SpecConstr.
+     let a'    = case xs of
+                 [] -> acc
+                 (_:_) -> (let b = expensive x in (b * 2), x)
+         -- Use the expensive value once and recurse.
+         -- We recurse with (_:_:_) so that a specialisation is made for that pattern,
+         -- which simplifies the case xs above. This exposes the expensive let.
+         (p,q) = case a' of (p',q') -> recursive (x:x:xs) (q',p')
+
+         -- Use the expensive value again.
+         -- Our problem is that this shows up as a separate let-binding for expensive, instead of reusing
+         -- the already computed value from above.
+     in  (p + fst a', q + snd a')
+
diff --git a/tests/simplCore/should_compile/T7865.stdout b/tests/simplCore/should_compile/T7865.stdout
new file mode 100644
index 0000000..2fa5b9a
--- /dev/null
+++ b/tests/simplCore/should_compile/T7865.stdout
@@ -0,0 +1,4 @@
+T7865.expensive [InlPrag=NOINLINE]
+T7865.expensive =
+        case T7865.expensive sc3 of _ { GHC.Types.I# x ->
+                (case T7865.expensive x of _ { GHC.Types.I# x1 ->
diff --git a/tests/simplCore/should_compile/all.T b/tests/simplCore/should_compile/all.T
index 8c33ab1..c953346 100644
--- a/tests/simplCore/should_compile/all.T
+++ b/tests/simplCore/should_compile/all.T
@@ -165,3 +165,4 @@ test('T7796',
      run_command,
      ['$MAKE -s --no-print-directory T7796'])
 test('T5550', normal, compile, [''])
+test('T7865', normal, run_command, ['$MAKE -s --no-print-directory T7865'])