Call Arity test case: Check what happens with unboxed lets

4 files changed, 37 insertions, 0 deletions

diff --git a/testsuite/tests/callarity/should_run/Makefile b/testsuite/tests/callarity/should_run/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/callarity/should_run/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/callarity/should_run/StrictLet.hs b/testsuite/tests/callarity/should_run/StrictLet.hs
new file mode 100644
index 0000000000..bae0183f74
--- /dev/null
+++ b/testsuite/tests/callarity/should_run/StrictLet.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE MagicHash #-}
+
+{-
+If the (unboxed, hence strict) "let thunk =" would survive to the CallArity
+stage, it might yield wrong results (eta-expanding thunk and hence "cond" would
+be called multiple times).
+
+It does not actually happen (CallArity sees a "case"), so this test just
+safe-guards against future changes here.
+-}
+
+import Debug.Trace
+import GHC.Exts
+import System.Environment
+
+cond :: Int# -> Bool
+cond x = trace ("cond called with " ++ show (I# x)) True
+{-# NOINLINE cond #-}
+
+
+bar (I# x) =
+    let go n = let x = thunk n
+               in case n of
+                    100# -> I# x
+                    _    -> go (n +# 1#)
+    in go x
+  where thunk = if cond x then \x -> (x +# 1#) else \x -> (x -# 1#)
+
+
+main = do
+    args <- getArgs
+    bar (length args) `seq` return ()
diff --git a/testsuite/tests/callarity/should_run/StrictLet.stderr b/testsuite/tests/callarity/should_run/StrictLet.stderr
new file mode 100644
index 0000000000..4387bc0b28
--- /dev/null
+++ b/testsuite/tests/callarity/should_run/StrictLet.stderr
@@ -0,0 +1 @@
+cond called with 0
diff --git a/testsuite/tests/callarity/should_run/all.T b/testsuite/tests/callarity/should_run/all.T
new file mode 100644
index 0000000000..571448c327
--- /dev/null
+++ b/testsuite/tests/callarity/should_run/all.T
@@ -0,0 +1 @@
+test('StrictLet', [], compile_and_run, [''])