[commit: ghc] wip/T9732: In pattern synonym matchers, support unboxed continuation results. (6b68c8c)
git at git.haskell.org
git at git.haskell.org
Thu Nov 6 13:11:01 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T9732
Link : http://ghc.haskell.org/trac/ghc/changeset/6b68c8ccbb08e815b281f4f5ed139311c1e04e27/ghc
>---------------------------------------------------------------
commit 6b68c8ccbb08e815b281f4f5ed139311c1e04e27
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Sat Nov 1 11:10:56 2014 +0800
In pattern synonym matchers, support unboxed continuation 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.
>---------------------------------------------------------------
6b68c8ccbb08e815b281f4f5ed139311c1e04e27
compiler/deSugar/DsUtils.lhs | 4 +++-
compiler/typecheck/TcPatSyn.lhs | 19 ++++++++++++-------
testsuite/.gitignore | 1 +
testsuite/tests/patsyn/should_run/all.T | 1 +
testsuite/tests/patsyn/should_run/match-unboxed.hs | 21 +++++++++++++++++++++
.../should_run/match-unboxed.stdout} | 2 ++
6 files changed, 40 insertions(+), 8 deletions(-)
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index a269374..d36e4c9 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 (patSynArgs psyn) 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..56342f0 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 <- 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
@@ -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
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index ce5c2c2..2423e15 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/all.T b/testsuite/tests/patsyn/should_run/all.T
index b3c6b74..442dd43 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('match-unboxed', 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 0000000..ec6de0c
--- /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/array/should_run/arr020.stdout b/testsuite/tests/patsyn/should_run/match-unboxed.stdout
similarity index 50%
copy from testsuite/tests/array/should_run/arr020.stdout
copy to testsuite/tests/patsyn/should_run/match-unboxed.stdout
index daaac9e..da4a47e 100644
--- a/testsuite/tests/array/should_run/arr020.stdout
+++ b/testsuite/tests/patsyn/should_run/match-unboxed.stdout
@@ -1,2 +1,4 @@
42
+44
42
+44
More information about the ghc-commits
mailing list