[commit: ghc] wip/T9732: In pattern synonym matchers, support unboxed continuation results. (1567a8f)
git at git.haskell.org
git at git.haskell.org
Thu Nov 6 13:14:12 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T9732
Link : http://ghc.haskell.org/trac/ghc/changeset/1567a8f87303f1833ebf1eb253b3add974bc4ae3/ghc
>---------------------------------------------------------------
commit 1567a8f87303f1833ebf1eb253b3add974bc4ae3
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.
>---------------------------------------------------------------
1567a8f87303f1833ebf1eb253b3add974bc4ae3
compiler/basicTypes/PatSyn.lhs | 18 ++++++++++----
compiler/deSugar/DsUtils.lhs | 4 +++-
compiler/typecheck/TcPatSyn.lhs | 28 ++++++++++++----------
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 ++
7 files changed, 56 insertions(+), 19 deletions(-)
diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 2081b5a..1b78dac 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -130,11 +130,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 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..2372a1b 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
@@ -124,25 +124,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
@@ -185,9 +189,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
@@ -243,7 +245,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 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