Show testcase where demand analysis abortion code fails
authorJoachim Breitner <mail@joachim-breitner.de>
Thu, 7 Jul 2016 08:41:38 +0000 (10:41 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 7 Jul 2016 08:41:38 +0000 (10:41 +0200)
By making it believe that some deeply nested value is absent when it
really isn't. See #12368.

testsuite/tests/stranal/should_run/T12368.hs [new file with mode: 0644]
testsuite/tests/stranal/should_run/T12368.stderr [new file with mode: 0644]
testsuite/tests/stranal/should_run/all.T

diff --git a/testsuite/tests/stranal/should_run/T12368.hs b/testsuite/tests/stranal/should_run/T12368.hs
new file mode 100644 (file)
index 0000000..e830761
--- /dev/null
@@ -0,0 +1,27 @@
+-- If care is not taken when aborting a fixed-point iteration, wrong absentness
+-- information escapes
+
+-- Needs to be a product type
+data Stream = S Int Stream
+
+bar :: Int -> Stream -> Int
+bar n s = foo n s
+  where
+    foo :: Int -> Stream -> Int
+    foo 0 (S n s) = 0
+    foo i (S n s) = n + foo (i-1) s
+{-# NOINLINE bar #-}
+
+
+baz :: Int -> Stream -> Int
+baz 0 not_absent = 0
+baz 1 not_absent = baz 2 not_absent
+baz x not_absent = bar 1000 arg
+  where
+    arg = S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ not_absent
+
+bamf x = baz x (S x (error "This is good!"))
+{-# NOINLINE bamf #-}
+
+main :: IO ()
+main = bamf 10 `seq` return ()
diff --git a/testsuite/tests/stranal/should_run/T12368.stderr b/testsuite/tests/stranal/should_run/T12368.stderr
new file mode 100644 (file)
index 0000000..05025ac
--- /dev/null
@@ -0,0 +1,3 @@
+T12368: This is good!
+CallStack (from HasCallStack):
+  error, called at T12368.hs:24:22 in main:Main
index a4b550e..6846c82 100644 (file)
@@ -12,3 +12,4 @@ test('T10148', normal, compile_and_run, [''])
 test('T10218', normal, compile_and_run, [''])
 test('T11076', normal, multimod_compile_and_run, ['T11076.hs', 'T11076_prim.cmm'])
 test('T11555a', normal, compile_and_run, [''])
+test('T12368', [ exit_code(1), expect_broken(12368) ], compile_and_run, [''])