[commit: ghc] wip/impredicativity: Track monomorphism of variables in environment and implement approximation. (88275a7)
git at git.haskell.org
git at git.haskell.org
Tue Jun 23 11:31:39 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/impredicativity
Link : http://ghc.haskell.org/trac/ghc/changeset/88275a7b29d9deb113e06c7ec9f9a198949504d1/ghc
>---------------------------------------------------------------
commit 88275a7b29d9deb113e06c7ec9f9a198949504d1
Author: Alejandro Serrano <trupill at gmail.com>
Date: Tue Jun 23 13:28:46 2015 +0200
Track monomorphism of variables in environment and implement approximation.
- The code in TcPat has been changed to tag (term) varibles introduced in the
environment with an expected type of a (type) variable. This is later used
in TcExpr to decide whether to emit an equality or instantiation constraint
when that (term) variable is found.
- Implement approximation of InstanceOf constraints by a System FC-type
with the least amount of polymorphism.
>---------------------------------------------------------------
88275a7b29d9deb113e06c7ec9f9a198949504d1
compiler/typecheck/TcBinds.hs | 2 +-
compiler/typecheck/TcCanonical.hs | 2 +-
compiler/typecheck/TcPat.hs | 13 +++++++++---
compiler/typecheck/TcSimplify.hs | 43 +++++++++++++++++++++++++++++++--------
4 files changed, 46 insertions(+), 14 deletions(-)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index c00bd8f..a818919 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -387,7 +387,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
- ; let uids1 = map (\x -> (x, TcIdUnrestricted)) ids1
+ ; let uids1 = map (\x -> (x, TcIdMonomorphic)) ids1
; (binds2, thing) <- tcExtendLetEnv top_lvl uids1 $
go sccs
; return (binds1 `unionBags` binds2, thing) }
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 0756e6f..5c7363c 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -1671,7 +1671,7 @@ can_instance_of (CInstanceOfCan { cc_ev = ev, cc_lhs = lhs, cc_rhs = rhs })
do { (qvars, q, ty) <- splitInst lhs
-- generate new constraints
; new_ev_qs <- mapM (newWantedEvVarNC loc) q
- ; let eq = mkTcEqPredRole Nominal ty rhs
+ ; let eq = mkTcEqPred ty rhs
; new_ev_ty <- newWantedEvVarNC loc eq
-- compute the evidence for the instantiation
; let qvars' = map TyVarTy qvars
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 1540a92..88e6f65 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -483,7 +483,7 @@ tc_pat :: PatEnv
tc_pat penv (VarPat name) pat_ty thing_inside
= do { (co, id) <- tcPatBndr penv name pat_ty
- ; res <- tcExtendIdEnv1 name id TcIdUnrestricted thing_inside
+ ; res <- tcExtendIdEnv1 name id (chooseInstFlavor pat_ty) thing_inside
; return (mkHsWrapPatCo co (VarPat id) pat_ty, res) }
tc_pat penv (ParPat pat) pat_ty thing_inside
@@ -520,7 +520,7 @@ tc_pat _ (WildPat _) pat_ty thing_inside
tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
= do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
- ; (pat', res) <- tcExtendIdEnv1 name bndr_id TcIdUnrestricted $
+ ; (pat', res) <- tcExtendIdEnv1 name bndr_id (chooseInstFlavor pat_ty) $
tc_lpat pat (idType bndr_id) penv thing_inside
-- NB: if we do inference on:
-- \ (y@(x::forall a. a->a)) = e
@@ -657,7 +657,7 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) ge minus) pat_ty thing_inside
; icls <- tcLookupClass integralClassName
; instStupidTheta orig [mkClassPred icls [pat_ty']]
- ; res <- tcExtendIdEnv1 name bndr_id TcIdUnrestricted thing_inside
+ ; res <- tcExtendIdEnv1 name bndr_id (chooseInstFlavor pat_ty) thing_inside
; return (mkHsWrapPatCo co pat' pat_ty, res) }
tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut
@@ -672,6 +672,13 @@ unifyPatType actual_ty expected_ty
= do { coi <- unifyType actual_ty expected_ty
; return (mkTcSymCo coi) }
+chooseInstFlavor :: TcSigmaType -> TcIdFlavor
+chooseInstFlavor ty
+ -- if type is a variable, we need to add a monomorphic
+ -- flag for the environment
+ | Just _ <- tcGetTyVar_maybe ty = TcIdMonomorphic
+ | otherwise = TcIdUnrestricted
+
{-
Note [Hopping the LIE in lazy patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 5b35437..cef26dc 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -444,8 +444,9 @@ simplifyInfer rhs_tclvl apply_mr name_taus wanteds
-- NB: must include derived errors in this test,
-- hence "incl_derivs"
- else do { let quant_cand = approximateWC wanted_transformed
- meta_tvs = filter isMetaTyVar (varSetElems (tyVarsOfCts quant_cand))
+ else do { quant_cand <- runTcSWithEvBinds null_ev_binds_var $ approximateWC wanted_transformed
+ ; traceTc "simplifyInfer/quant_cand = " (ppr quant_cand)
+ ; let meta_tvs = filter isMetaTyVar (varSetElems (tyVarsOfCts quant_cand))
; gbl_tvs <- tcGetGlobalTyVars
-- Miminise quant_cand. We are not interested in any evidence
-- produced, because we are going to simplify wanted_transformed
@@ -1294,10 +1295,13 @@ defaultTyVar the_tv
| otherwise = return the_tv -- The common case
-approximateWC :: WantedConstraints -> Cts
+approximateWC :: WantedConstraints -> TcS Cts
+approximateWC = fmap andManyCts . mapM instantiateWC . bagToList . approximateWC_
+
+approximateWC_ :: WantedConstraints -> Cts
-- Postcondition: Wanted or Derived Cts
-- See Note [ApproximateWC]
-approximateWC wc
+approximateWC_ wc
= float_wc emptyVarSet wc
where
float_wc :: TcTyVarSet -> WantedConstraints -> Cts
@@ -1327,6 +1331,20 @@ approximateWC wc
do_bag :: (a -> Bag c) -> Bag a -> Bag c
do_bag f = foldrBag (unionBags.f) emptyBag
+instantiateWC :: Ct -> TcS Cts
+instantiateWC ct
+ | isWantedCt ct, InstanceOfPred lhs rhs <- classifyPredType (ctPred ct)
+ = do { let loc = ctLoc ct
+ ; (_qvars, q, ty) <- splitInst lhs
+ ; new_ev_qs <- mapM (newWantedEvVarNC loc) q
+ ; let eq = mkTcEqPred ty rhs
+ ; new_ev_ty <- newWantedEvVarNC loc eq
+ ; return $ consCts
+ (mkNonCanonical new_ev_ty)
+ (listToBag (map mkNonCanonical new_ev_qs)) }
+ | otherwise = return (singleCt ct)
+
+
{-
Note [ApproximateWC]
~~~~~~~~~~~~~~~~~~~~
@@ -1660,7 +1678,7 @@ applyDefaultingRules wanteds
= do { info@(default_tys, _) <- getDefaultInfo
; wanteds <- TcS.zonkWC wanteds
- ; let groups = findDefaultableGroups info wanteds
+ ; groups <- findDefaultableGroups info wanteds
; traceTcS "applyDefaultingRules {" $
vcat [ text "wanteds =" <+> ppr wanteds
@@ -1673,12 +1691,20 @@ applyDefaultingRules wanteds
; return (or something_happeneds) }
-findDefaultableGroups
+findDefaultableGroups :: ([Type], (Bool,Bool))
+ -> WantedConstraints
+ -> TcS [(TyVar, [Ct])]
+findDefaultableGroups info wanteds
+ = do { simples <- approximateWC wanteds
+ ; return (findDefaultableGroups_ info simples) }
+
+findDefaultableGroups_
:: ( [Type]
, (Bool,Bool) ) -- (Overloaded strings, extended default rules)
- -> WantedConstraints -- Unsolved (wanted or derived)
+ -- -> WantedConstraints -- Unsolved (wanted or derived)
+ -> Cts
-> [(TyVar, [Ct])]
-findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
+findDefaultableGroups_ (default_tys, (ovl_strings, extended_defaults)) {-wanteds-} simples
| null default_tys
= []
| otherwise
@@ -1687,7 +1713,6 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
, defaultable_tyvar tv
, defaultable_classes (map sndOf3 group) ]
where
- simples = approximateWC wanteds
(unaries, non_unaries) = partitionWith find_unary (bagToList simples)
unary_groups = equivClasses cmp_tv unaries
More information about the ghc-commits
mailing list