In pattern synonym matchers, support unboxed continuation results (fixes #9783).

This requires ensuring the continuations have arguments by adding a dummy
Void# argument when needed. This is so that matching on a pattern synonym
is lazy even when the result is unboxed, e.g.

    pattern P = ()
    f P = 0#

In this case, without dummy arguments, the generated matcher's type would be

   $mP :: forall (r :: ?). () -> r -> r -> r

which is called in `f` at type `() -> Int# -> Int# -> Int#`,
so it would be strict, in particular, in the failure continuation
of `patError`.

We work around this by making sure both continuations have arguments:

  $mP :: forall (r :: ?). () -> (Void# -> r) -> (Void# -> r) -> r

Of course, if `P` (and thus, the success continuation) has any arguments,
we are only adding the extra dummy argument to the failure continuation.

7 files changed, 61 insertions, 22 deletions

diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 2081b5af84..9cc7c39abf 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -76,17 +76,22 @@ For each pattern synonym, we generate a single matcher function which
 implements the actual matching. For the above example, the matcher
 will have type:
 
-        $mP :: forall r t. (Eq t, Num t)
+        $mP :: forall (r :: ?) t. (Eq t, Num t)
             => T (Maybe t)
             -> (forall b. (Show (Maybe t), Ord b) => b -> r)
-            -> r
+            -> (Void# -> r)
             -> r
 
 with the following implementation:
 
         $mP @r @t $dEq $dNum scrut cont fail = case scrut of
             MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
-            _                                 -> fail
+            _                                 -> fail Void#
+
+The extra Void# argument for the failure continuation is needed so that
+it is lazy even when the result type is unboxed. For the same reason,
+if the pattern has no arguments, an extra Void# argument is added
+to the success continuation as well.
 
 For *bidirectional* pattern synonyms, we also generate a single wrapper
 function which implements the pattern synonym in an expression
@@ -130,11 +135,19 @@ data PatSyn
 
         -- See Note [Matchers and wrappers for pattern synonyms]
         psMatcher     :: Id,
-             -- Matcher function, of type
-             --   forall r univ_tvs. req_theta
-             --                   => res_ty
-             --                   -> (forall ex_tvs. prov_theta -> arg_tys -> r)
-             --                   -> r -> r
+            -- Matcher function. If psArgs is empty, then it has type
+             --   forall (r :: ?) univ_tvs. req_theta
+             --                       => res_ty
+             --                       -> (forall ex_tvs. prov_theta -> Void# -> r)
+             --                       -> (Void# -> r)
+             --                       -> r
+             --
+             -- Otherwise:
+             --   forall (r :: ?) univ_tvs. req_theta
+             --                       => res_ty
+             --                       -> (forall ex_tvs. prov_theta -> arg_tys -> r)
+             --                       -> (Void# -> r)
+             --                       -> r
 
         psWrapper     :: Maybe Id
              -- Nothing  => uni-directional pattern synonym
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index a269374bed..b0fe24a0fb 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -348,7 +348,7 @@ mkPatSynCase var ty alt fail = do
     matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
     let MatchResult _ mkCont = match_result
     cont <- mkCoreLams bndrs <$> mkCont fail
-    return $ mkCoreAppsDs matcher [Var var, cont, fail]
+    return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, make_unstrict fail]
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
@@ -356,6 +356,11 @@ mkPatSynCase var ty alt fail = do
                alt_result = match_result} = alt
     matcher = patSynMatcher psyn
 
+    -- See Note [Matchers and wrappers for pattern synonyms] in PatSyns
+    -- on these extra Void# arguments
+    ensure_unstrict = if null (patSynArgs psyn) then make_unstrict else id
+    make_unstrict = Lam voidArgId
+
 mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
 mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
 mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index d27ab4fa8a..7dd2e33fd4 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -24,12 +24,12 @@ import Outputable
 import FastString
 import Var
 import Id
-import IdInfo( IdDetails( VanillaId ) )
 import TcBinds
 import BasicTypes
 import TcSimplify
 import TcType
 import VarSet
+import MkId
 #if __GLASGOW_HASKELL__ < 709
 import Data.Monoid
 #endif
@@ -129,25 +129,29 @@ tcPatSynMatcher :: Located Name
                 -> TcM (Id, LHsBinds Id)
 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
 tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
-  = do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind
+  = do { res_tv <- do
+              { uniq <- newUnique
+              ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
+              ; return $ mkTcTyVar tv_name openTypeKind (SkolemTv False) }
        ; matcher_name <- newImplicitBinder name mkMatcherOcc
        ; let res_ty = TyVarTy res_tv
+             cont_args = if null args then [voidPrimId] else args
              cont_ty = mkSigmaTy ex_tvs prov_theta $
-                       mkFunTys (map varType args) res_ty
+                       mkFunTys (map varType cont_args) res_ty
+             fail_ty = mkFunTy voidPrimTy res_ty
 
-       ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
+       ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
-             matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma
+             matcher_id = mkVanillaGlobal matcher_name matcher_sigma
 
        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
        ; let matcher_lid = L loc matcher_id
 
        ; scrutinee <- mkId "scrut" pat_ty
        ; cont <- mkId "cont" cont_ty
-       ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ args)
-       ; fail <- mkId "fail" res_ty
-       ; let fail' = nlHsVar fail
-
+       ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ cont_args)
+       ; fail <- mkId "fail" fail_ty
+       ; let fail' = nlHsApps fail [nlHsVar voidPrimId]
 
        ; let args = map nlVarPat [scrutinee, cont, fail]
              lwpat = noLoc $ WildPat pat_ty
@@ -190,9 +194,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
 
        ; return (matcher_id, matcher_bind) }
   where
-    mkId s ty = do
-        name <- newName . mkVarOccFS . fsLit $ s
-        return $ mkLocalId name ty
+    mkId s ty = mkSysLocalM (fsLit s) ty
 
 isBidirectional :: HsPatSynDir a -> Bool
 isBidirectional Unidirectional = False
@@ -248,7 +250,7 @@ mkPatSynWrapperId (L _ name) args univ_tvs ex_tvs theta pat_ty
              wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau
 
        ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
-       ; return $ mkExportedLocalId VanillaId wrapper_name wrapper_sigma }
+       ; return $ mkVanillaGlobal wrapper_name wrapper_sigma }
 
 mkPatSynWrapper :: Id
                 -> HsBind Name
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 231897c101..3a5d81654a 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1097,6 +1097,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/patsyn/should_run/ex-prov
 /tests/patsyn/should_run/ex-prov-run
 /tests/patsyn/should_run/match
+/tests/patsyn/should_run/match-unboxed
 /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_run/T9783.hs b/testsuite/tests/patsyn/should_run/T9783.hs
new file mode 100644
index 0000000000..daef96032b
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/T9783.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module Main where
+
+import GHC.Base
+
+pattern P1 <- 0
+pattern P2 <- 1
+
+f :: Int -> Int#
+f P1 = 42#
+f P2 = 44#
+
+main = do
+    print $ I# (f 0)
+    print $ I# (f 1)
diff --git a/testsuite/tests/patsyn/should_run/T9783.stdout b/testsuite/tests/patsyn/should_run/T9783.stdout
new file mode 100644
index 0000000000..c26b130d29
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/T9783.stdout
@@ -0,0 +1,2 @@
+42
+44
diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T
index b3c6b74461..9c3f16b0ea 100644
--- a/testsuite/tests/patsyn/should_run/all.T
+++ b/testsuite/tests/patsyn/should_run/all.T
@@ -3,3 +3,4 @@ test('match', normal, compile_and_run, [''])
 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, [''])