[commit: ghc] wip/T9732: In pattern synonym matchers, support unboxed results. (f48362b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T9732
Link       : http://ghc.haskell.org/trac/ghc/changeset/f48362b961227778759c1baab66ce910abd2c400/ghc

>---------------------------------------------------------------

commit f48362b961227778759c1baab66ce910abd2c400
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sat Nov 1 11:10:56 2014 +0800

    In pattern synonym matchers, support unboxed results.
    
    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.


>---------------------------------------------------------------

f48362b961227778759c1baab66ce910abd2c400
 compiler/deSugar/DsUtils.lhs    |  4 +++-
 compiler/typecheck/TcPatSyn.lhs | 19 ++++++++++++-------
 2 files changed, 15 insertions(+), 8 deletions(-)

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index a269374..7e6ac43 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -348,13 +348,15 @@ 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,
                alt_wrapper = wrapper,
                alt_result = match_result} = alt
     matcher = patSynMatcher psyn
+    ensure_unstrict = if null bndrs then make_unstrict else id
+    make_unstrict = Lam voidArgId
 
 mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
 mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index 9b2b511..633abe2 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -30,6 +30,7 @@ import BasicTypes
 import TcSimplify
 import TcType
 import VarSet
+import MkId
 #if __GLASGOW_HASKELL__ < 709
 import Data.Monoid
 #endif
@@ -124,13 +125,18 @@ 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 <- zonkQuantifiedTyVar =<< newFlexiTyVar openTypeKind
+         -- Zonking entails kind defaulting, which turns res_tv :: ? into res_tv :: *.
+         -- But here, we really do mean res_tv :: ?, so we reset it.
+       ; res_tv <- return $ setTyVarKind res_tv openTypeKind
        ; 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
 
@@ -139,10 +145,9 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
 
        ; 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