[commit: ghc] wip/T9732: In PatSyn matchers for unlifted result types, add an extra Void# argument to both cont and fail continuations, so that they are not needlessly strict. (9f8b67e)

[git at git.haskell.org]

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

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

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

commit 9f8b67ea4e57b958a95de876d1ee713c99e8d687
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Thu Oct 30 23:38:24 2014 +0800

    In PatSyn matchers for unlifted result types, add an extra Void# argument
    to both cont and fail continuations, so that they are not needlessly strict.


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

9f8b67ea4e57b958a95de876d1ee713c99e8d687
 compiler/deSugar/DsUtils.lhs    |  7 +++++--
 compiler/typecheck/TcPatSyn.lhs | 13 ++++++++-----
 2 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 503e88c..61fdbca 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -348,13 +348,16 @@ 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, make_unstrict cont, make_unstrict fail]
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
                alt_wrapper = wrapper,
                alt_result = match_result} = alt
-    matcher = patSynMatcher (isUnLiftedType ty) psyn
+    is_unlifted = isUnLiftedType ty
+    matcher = patSynMatcher is_unlifted psyn
+    make_unstrict | is_unlifted = Lam voidArgId
+                  | otherwise = id
 
 mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
 mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index a7ac763..68667d7 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -27,6 +27,7 @@ import Id
 import IdInfo( IdDetails( VanillaId ) )
 import TcBinds
 import BasicTypes
+import MkId
 import TcSimplify
 import TcType
 import VarSet
@@ -130,13 +131,15 @@ tcPatSynMatcher :: Located Name
 tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty unlifted
   = do { let res_kind = if unlifted then unliftedTypeKind
                         else liftedTypeKind
+             dummy_args = if unlifted then [voidPrimId] else []
        ; res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar res_kind
        ; matcher_name <- newImplicitBinder name (if unlifted then mkMatcherUnlOcc else mkMatcherOcc)
        ; let res_ty = TyVarTy res_tv
              cont_ty = mkSigmaTy ex_tvs prov_theta $
-                       mkFunTys (map varType args) res_ty
+                       mkFunTys (map varType (dummy_args ++ args)) res_ty
+             fail_ty = mkFunTys (map varType dummy_args) 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
 
@@ -145,9 +148,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 ++ dummy_args ++ args)
+       ; fail <- mkId "fail" fail_ty
+       ; let fail' = nlHsApps fail $ map nlHsVar dummy_args
 
 
        ; let args = map nlVarPat [scrutinee, cont, fail]