[commit: ghc] master: Add a second regression test for #13536 (ddc0591)

[git at git.haskell.org]

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

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

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

commit ddc05912565aedd6ef46236906fa06cdb3e5e06c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Mon Apr 10 11:21:52 2017 -0400

    Add a second regression test for #13536
    
    which counts allocations instead of observing recomputation directly.


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

ddc05912565aedd6ef46236906fa06cdb3e5e06c
 testsuite/tests/simplStg/should_run/T13536a.hs     | 28 ++++++++++++++++++++++
 .../tests/simplStg/should_run/T13536a.stdout       |  0
 testsuite/tests/simplStg/should_run/all.T          |  9 +++++++
 3 files changed, 37 insertions(+)

diff --git a/testsuite/tests/simplStg/should_run/T13536a.hs b/testsuite/tests/simplStg/should_run/T13536a.hs
new file mode 100644
index 0000000..118c4c9
--- /dev/null
+++ b/testsuite/tests/simplStg/should_run/T13536a.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TypeFamilies #-}
+module Main where
+
+main :: IO ()
+main = do
+  let f :: (Bool, Bool) -> (Bool, Bool) -> (Bool, Bool)
+      f (True, False) (False, False) = (False, True)
+      f _ _ = (True, False)
+      ((i, b), v) = ((False,True),[(False,True),(False,False),(True,True),(True,False),(False,False),(False,True),(True,True),(True,True),(False,True),(True,False),(False,False),(True,True),(True,True),(False,False),(False,False),(False,True),(True,False),(True,False),(True,True),(True,True),(False,True),(True,False),(True,False),(True,True),(False,False),(True,True),(False,False),(True,False),(False,True),(True,True)])
+  print $ foldlTest f (i, b) v
+
+type FoldlTest a = (a -> a -> a) -> a -> [a] -> Bool
+
+foldlTest :: FoldlTest (Bool, Bool)
+foldlTest f (i, b) v =
+  foldl f (i, b) v == foldl (\x -> f (unmodel x)) (i, b) v
+
+class TestData a where
+  type Model a
+  unmodel :: Model a -> a
+
+instance TestData Bool where
+  type Model Bool = Bool
+  unmodel = id
+
+instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where
+  type Model (a,b) = (Model a, Model b)
+  unmodel (a,b) = (unmodel a, unmodel b)
diff --git a/libraries/base/tests/IO/IOError002.stdout b/testsuite/tests/simplStg/should_run/T13536a.stdout
similarity index 100%
copy from libraries/base/tests/IO/IOError002.stdout
copy to testsuite/tests/simplStg/should_run/T13536a.stdout
diff --git a/testsuite/tests/simplStg/should_run/all.T b/testsuite/tests/simplStg/should_run/all.T
index b24da84..d3aa937 100644
--- a/testsuite/tests/simplStg/should_run/all.T
+++ b/testsuite/tests/simplStg/should_run/all.T
@@ -11,3 +11,12 @@ setTestOpts(f)
 
 test('T9291', normal, compile_and_run, [''])
 test('T13536', normal, compile_and_run, [''])
+
+test('T13536a',
+    [stats_num_field('bytes allocated',
+                    [ (wordsize(64), 86664, 5) ]),
+                    # 2017-04-10     86664 -- 25769889696 if broken
+     only_ways(['optasm'])],
+    compile_and_run,
+    [''])
+