From 8a03d5a178cd63c01b8dedd6c58f302a1635ff61 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Thu, 20 Jun 2019 13:40:13 -0400
Subject: [PATCH] testsuite: Add test for #16846
---
testsuite/tests/codeGen/should_run/T16846.hs | 37 +++++++++++++++++++
.../tests/codeGen/should_run/T16846.stderr | 4 ++
testsuite/tests/codeGen/should_run/all.T | 1 +
3 files changed, 42 insertions(+)
create mode 100644 testsuite/tests/codeGen/should_run/T16846.hs
create mode 100644 testsuite/tests/codeGen/should_run/T16846.stderr
diff --git a/testsuite/tests/codeGen/should_run/T16846.hs b/testsuite/tests/codeGen/should_run/T16846.hs
new file mode 100644
index 000000000000..af961fe68187
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T16846.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Main (main) where
+
+import Control.Concurrent.STM
+
+data Free f a = Pure a | Free (f (Free f a))
+
+data SuspendF a
+ = forall r. StepSTM (STM r)
+ | forall r. StepIO (IO r)
+
+effect :: STM a -> Free SuspendF a
+effect a = Free $ StepSTM a
+
+io :: IO a -> Free SuspendF a
+io a = Free $ StepIO a
+
+comb :: [Free SuspendF a] -> Free SuspendF a
+comb vs = io $ do
+ _ <- mapM go vs
+ undefined
+
+go :: Free SuspendF a -> IO (STM ())
+go (Free (StepIO a)) = a >>= \_ -> go $ Pure undefined
+go (Free (StepSTM a)) = pure $ a >>= \_ -> pure ()
+go (Pure _) = pure $ pure ()
+
+runWidget :: Free SuspendF a -> IO a
+runWidget w = case w of
+ Free (StepIO io) -> do
+ _ <- io
+ undefined
+
+-- Uncommenting this hid the original bug.
+--main :: IO ()
+main = runWidget $ comb $ replicate 10000000 (effect retry)
diff --git a/testsuite/tests/codeGen/should_run/T16846.stderr b/testsuite/tests/codeGen/should_run/T16846.stderr
new file mode 100644
index 000000000000..f737c83af025
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T16846.stderr
@@ -0,0 +1,4 @@
+T16846: Prelude.undefined
+CallStack (from HasCallStack):
+ error, called at libraries/base/GHC/Err.hs:80:14 in base:GHC.Err
+ undefined, called at T16846.hs:22:3 in main:Main
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 535ca8651e1f..20ac9cc59e26 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -197,3 +197,4 @@ test('T15892',
compile_and_run, ['-O'])
test('T16617', normal, compile_and_run, [''])
test('T16449_2', exit_code(0), compile_and_run, [''])
+test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, [''])
--
GitLab