If pattern synonym is bidirectional and its type is some unboxed type T#,

generate a worker function of type Void# -> T#, and redirect the wrapper
(via a compulsory unfolding) to the worker. Fixes #9732.

11 files changed, 55 insertions, 0 deletions

diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 3a5d81654a..a07a376b26 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1098,6 +1098,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/patsyn/should_run/ex-prov-run
 /tests/patsyn/should_run/match
 /tests/patsyn/should_run/match-unboxed
+/tests/patsyn/should_run/unboxed-wrapper
 /tests/perf/compiler/T1969.comp.stats
 /tests/perf/compiler/T3064.comp.stats
 /tests/perf/compiler/T3294.comp.stats
diff --git a/testsuite/tests/patsyn/should_compile/T9732.hs b/testsuite/tests/patsyn/should_compile/T9732.hs
new file mode 100644
index 0000000000..7fd0515fcf
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T9732.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module ShouldCompile where
+
+pattern P = 0#
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 94950a1e74..55e3b83302 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -11,3 +11,4 @@ test('export', normal, compile, [''])
 test('T8966', normal, compile, [''])
 test('T9023', normal, compile, [''])
 test('unboxed-bind-bang', normal, compile, [''])
+test('T9732', normal, compile, [''])
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index ee5768c95c..b38776e9c3 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -8,3 +8,4 @@ test('T9161-2', normal, compile_fail, [''])
 test('T9705-1', normal, compile_fail, [''])
 test('T9705-2', normal, compile_fail, [''])
 test('unboxed-bind', normal, compile_fail, [''])
+test('unboxed-wrapper-naked', normal, compile_fail, [''])
diff --git a/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs
new file mode 100644
index 0000000000..6e7cc94391
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module ShouldFail where
+
+import GHC.Base
+
+pattern P1 = 42#
+
+x = P1
diff --git a/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr
new file mode 100644
index 0000000000..e8d89500a8
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr
@@ -0,0 +1,3 @@
+
+unboxed-wrapper-naked.hs:8:1:
+    Top-level bindings for unlifted types aren't allowed: x = P1
diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T
index 9c3f16b0ea..40ec3e3b4e 100644
--- a/testsuite/tests/patsyn/should_run/all.T
+++ b/testsuite/tests/patsyn/should_run/all.T
@@ -4,3 +4,5 @@ test('ex-prov-run', normal, compile_and_run, [''])
 test('bidir-explicit', normal, compile_and_run, [''])
 test('bidir-explicit-scope', normal, compile_and_run, [''])
 test('T9783', normal, compile_and_run, [''])
+test('match-unboxed', normal, compile_and_run, [''])
+test('unboxed-wrapper', normal, compile_and_run, [''])
diff --git a/testsuite/tests/patsyn/should_run/match-unboxed.hs b/testsuite/tests/patsyn/should_run/match-unboxed.hs
new file mode 100644
index 0000000000..ec6de0cd70
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/match-unboxed.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module Main where
+
+import GHC.Base
+
+pattern P1 <- 0#
+pattern P2 <- 1#
+
+f :: Int# -> Int#
+f P1 = 42#
+f P2 = 44#
+
+g :: Int# -> Int
+g P1 = 42
+g P2 = 44
+
+main = do
+    print $ I# (f 0#)
+    print $ I# (f 1#)
+    print $ g 0#
+    print $ g 1#
diff --git a/testsuite/tests/patsyn/should_run/match-unboxed.stdout b/testsuite/tests/patsyn/should_run/match-unboxed.stdout
new file mode 100644
index 0000000000..da4a47e1f3
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/match-unboxed.stdout
@@ -0,0 +1,4 @@
+42
+44
+42
+44
diff --git a/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs b/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs
new file mode 100644
index 0000000000..367c8ccebd
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module Main where
+
+import GHC.Base
+
+pattern P1 = 42#
+
+main = do
+    print $ I# P1
diff --git a/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout b/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout
new file mode 100644
index 0000000000..d81cc0710e
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout
@@ -0,0 +1 @@
+42