Fix #13233 by checking for lev-poly primops

The implementation plan is all in Note [Detecting forced eta expansion]
in DsExpr.

Test Plan: ./validate, codeGen/should_fail/T13233

Reviewers: simonpj, austin, bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #13233

Differential Revision: https://phabricator.haskell.org/D3490

5 files changed, 52 insertions, 13 deletions

diff --git a/testsuite/tests/codeGen/should_compile/T13233.hs b/testsuite/tests/codeGen/should_compile/T13233.hs
deleted file mode 100644
index bb79856d3b..0000000000
--- a/testsuite/tests/codeGen/should_compile/T13233.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeInType #-}
-{-# LANGUAGE UnboxedTuples #-}
-module Bug where
-
-import GHC.Exts (TYPE)
-
-class Foo (a :: TYPE rep) where
-  bar :: forall (b :: TYPE rep2). (a -> a -> b) -> a -> a -> b
-
-baz :: forall (a :: TYPE rep). Foo a => a -> a -> (# a, a #)
-baz = bar (#,#)
diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T
index a73a9d65cf..6ae4e1cb4e 100644
--- a/testsuite/tests/codeGen/should_compile/all.T
+++ b/testsuite/tests/codeGen/should_compile/all.T
@@ -35,4 +35,3 @@ test('T10667', [ when((arch('powerpc64') or arch('powerpc64le')),
      compile, ['-g'])
 test('T12115', normal, compile, [''])
 test('T12355', normal, compile, [''])
-test('T13233', expect_broken(13233), compile, [''])
diff --git a/testsuite/tests/codeGen/should_fail/T13233.hs b/testsuite/tests/codeGen/should_fail/T13233.hs
new file mode 100644
index 0000000000..fa5a37b046
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/T13233.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MagicHash #-}
+module Bug where
+
+import GHC.Exts (TYPE, RuntimeRep, Weak#, State#, RealWorld, mkWeak# )
+
+class Foo (a :: TYPE rep) where
+  bar :: forall (b :: TYPE rep2). (a -> a -> b) -> a -> a -> b
+
+baz :: forall (a :: TYPE rep). Foo a => a -> a -> (# a, a #)
+baz = bar (#,#)
+
+obscure :: (forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep)
+                   (a :: TYPE rep1) (b :: TYPE rep2).
+                   a -> b -> (# a, b #)) -> ()
+obscure _ = ()
+
+quux :: ()
+quux = obscure (#,#)
+
+primop :: forall (rep :: RuntimeRep) (a :: TYPE rep) b c.
+          a -> b -> (State# RealWorld -> (# State# RealWorld, c #))
+       -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+primop = mkWeak#
diff --git a/testsuite/tests/codeGen/should_fail/T13233.stderr b/testsuite/tests/codeGen/should_fail/T13233.stderr
new file mode 100644
index 0000000000..2d167cf5f7
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/T13233.stderr
@@ -0,0 +1,24 @@
+
+T13233.hs:14:11: error:
+    Cannot use primitive with levity-polymorphic arguments:
+      GHC.Prim.(#,#) :: a -> a -> (# a, a #)
+    Levity polymorphic arguments:
+      a :: TYPE rep
+      a :: TYPE rep
+
+T13233.hs:22:16: error:
+    Cannot use primitive with levity-polymorphic arguments:
+      GHC.Prim.(#,#) :: forall (a :: TYPE rep1) (b :: TYPE rep2).
+                        a -> b -> (# a, b #)
+    Levity polymorphic arguments:
+      a :: TYPE rep1
+      b :: TYPE rep2
+
+T13233.hs:27:10: error:
+    Cannot use primitive with levity-polymorphic arguments:
+      mkWeak# :: a
+                 -> b
+                 -> (State# RealWorld -> (# State# RealWorld, c #))
+                 -> State# RealWorld
+                 -> (# State# RealWorld, Weak# b #)
+    Levity polymorphic arguments: a :: TYPE rep
diff --git a/testsuite/tests/codeGen/should_fail/all.T b/testsuite/tests/codeGen/should_fail/all.T
index 7e25b5f693..1fe2141caf 100644
--- a/testsuite/tests/codeGen/should_fail/all.T
+++ b/testsuite/tests/codeGen/should_fail/all.T
@@ -3,3 +3,4 @@
 # Only the LLVM code generator consistently forces the alignment of
 # memcpy operations
 test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, [''])
+test('T13233', normal, compile_fail, [''])