X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=5cbffdd872945f6a721ab93b75e1779c79f7201b;hb=cd2f5397bc1345fc37706168c268a8bd37af7f2f;hp=0e7acdd6761197638aaa013a88f2d4069865d9fe;hpb=c1e6031c54cda2c6f9fc107eb6cb04ab490f1fef;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 0e7acdd..5cbffdd 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -185,7 +185,7 @@ simplifyInfer :: Bool -- Apply monomorphism restriction TcEvBinds) -- ... binding these evidence variables simplifyInfer apply_mr tau_tvs wanted | isEmptyBag wanted -- Trivial case is quite common - = do { zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs) + = do { zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; qtvs <- zonkQuantifiedTyVars (varSetElems (zonked_tau_tvs `minusVarSet` gbl_tvs)) ; return (qtvs, [], emptyTcEvBinds) } @@ -198,26 +198,46 @@ simplifyInfer apply_mr tau_tvs wanted , ptext (sLit "tau_tvs =") <+> ppr tau_tvs ] - ; (simple_wanted, tc_binds) - <- simplifyAsMuchAsPossible SimplInfer zonked_wanted - + -- Make a guess at the quantified type variables + -- Then split the constraints on the baisis of those tyvars + -- to avoid unnecessarily simplifying a class constraint + -- See Note [Avoid unecessary constraint simplification] + ; gbl_tvs <- tcGetGlobalTyVars + ; zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs + ; let proto_qtvs = growWanteds gbl_tvs zonked_wanted $ + zonked_tau_tvs `minusVarSet` gbl_tvs + (perhaps_bound, surely_free) + = partitionBag (quantifyMeWC proto_qtvs) zonked_wanted + ; emitConstraints surely_free + ; traceTc "sinf" (ppr proto_qtvs $$ ppr perhaps_bound $$ ppr surely_free) + + -- Now simplify the possibly-bound constraints + ; (simplified_perhaps_bound, tc_binds) + <- simplifyAsMuchAsPossible SimplInfer perhaps_bound + + -- Sigh: must re-zonk because because simplifyAsMuchAsPossible + -- may have done some unification ; gbl_tvs <- tcGetGlobalTyVars - ; zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs) - ; zonked_simples <- mapBagM zonkWantedEvVar simple_wanted - ; let qtvs = findQuantifiedTyVars apply_mr zonked_simples zonked_tau_tvs gbl_tvs - (bound, free) | apply_mr = (emptyBag, zonked_simples) - | otherwise = partitionBag (quantifyMe qtvs) zonked_simples + ; zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs + ; zonked_simples <- mapBagM zonkWantedEvVar simplified_perhaps_bound + ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs + mr_qtvs = init_tvs `minusVarSet` constrained_tvs + constrained_tvs = tyVarsOfWantedEvVars zonked_simples + qtvs = growWantedEVs gbl_tvs zonked_simples init_tvs + (final_qtvs, (bound, free)) + | apply_mr = (mr_qtvs, (emptyBag, zonked_simples)) + | otherwise = (qtvs, partitionBag (quantifyMe qtvs) zonked_simples) ; traceTc "end simplifyInfer }" $ vcat [ ptext (sLit "apply_mr =") <+> ppr apply_mr , text "wanted = " <+> ppr zonked_wanted - , text "qtvs = " <+> ppr qtvs + , text "qtvs = " <+> ppr final_qtvs , text "free = " <+> ppr free , text "bound = " <+> ppr bound ] -- Turn the quantified meta-type variables into real type variables ; emitConstraints (mapBag WcEvVar free) - ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs) + ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems final_qtvs) ; let bound_evvars = bagToList $ mapBag wantedEvVarToVar bound ; return (qtvs_to_return, bound_evvars, EvBinds tc_binds) } @@ -308,25 +328,29 @@ approximateImplications impls \end{code} \begin{code} -findQuantifiedTyVars :: Bool -- Apply the MR - -> Bag WantedEvVar -- Simplified constraints from RHS - -> TyVarSet -- Free in tau-type of definition - -> TyVarSet -- Free in the envt - -> TyVarSet -- Quantify over these - -findQuantifiedTyVars apply_mr wanteds tau_tvs gbl_tvs - | isEmptyBag wanteds = init_tvs - | apply_mr = init_tvs `minusVarSet` constrained_tvs - | otherwise = fixVarSet mk_next init_tvs +growWantedEVs :: TyVarSet -> Bag WantedEvVar -> TyVarSet -> TyVarSet +growWanteds :: TyVarSet -> Bag WantedConstraint -> TyVarSet -> TyVarSet +growWanteds gbl_tvs ws tvs + | isEmptyBag ws = tvs + | otherwise = fixVarSet (\tvs -> foldrBag (growWanted gbl_tvs) tvs ws) tvs +growWantedEVs gbl_tvs ws tvs + | isEmptyBag ws = tvs + | otherwise = fixVarSet (\tvs -> foldrBag (growWantedEV gbl_tvs) tvs ws) tvs + +growWantedEV :: TyVarSet -> WantedEvVar -> TyVarSet -> TyVarSet +growWanted :: TyVarSet -> WantedConstraint -> TyVarSet -> TyVarSet +-- (growX gbls wanted tvs) grows a seed 'tvs' against the +-- X-constraint 'wanted', nuking the 'gbls' at each stage +growWantedEV gbl_tvs wev tvs + = tvs `unionVarSet` (ev_tvs `minusVarSet` gbl_tvs) where - init_tvs = tau_tvs `minusVarSet` gbl_tvs - mk_next tvs = foldrBag grow_one tvs wanteds - - grow_one wev tvs = tvs `unionVarSet` (extra_tvs `minusVarSet` gbl_tvs) - where - extra_tvs = growPredTyVars (wantedEvVarPred wev) tvs + ev_tvs = growPredTyVars (wantedEvVarPred wev) tvs - constrained_tvs = tyVarsOfWantedEvVars wanteds +growWanted gbl_tvs (WcEvVar wev) tvs + = growWantedEV gbl_tvs wev tvs +growWanted gbl_tvs (WcImplic implic) tvs + = foldrBag (growWanted (gbl_tvs `unionVarSet` ic_skols implic)) + tvs (ic_wanted implic) -------------------- quantifyMe :: TyVarSet -- Quantifying over these @@ -337,8 +361,32 @@ quantifyMe qtvs wev | otherwise = tyVarsOfPred pred `intersectsVarSet` qtvs where pred = wantedEvVarPred wev + +quantifyMeWC :: TyVarSet -> WantedConstraint -> Bool +quantifyMeWC qtvs (WcImplic implic) + = anyBag (quantifyMeWC (qtvs `minusVarSet` ic_skols implic)) (ic_wanted implic) +quantifyMeWC qtvs (WcEvVar wev) + = quantifyMe qtvs wev \end{code} +Note [Avoid unecessary constraint simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When inferring the type of a let-binding, with simplifyInfer, +try to avoid unnecessariliy simplifying class constraints. +Doing so aids sharing, but it also helps with delicate +situations like + instance C t => C [t] where .. + f :: C [t] => .... + f x = let g y = ...(constraint C [t])... + in ... +When inferring a type for 'g', we don't want to apply the +instance decl, because then we can't satisfy (C t). So we +just notice that g isn't quantified over 't' and partition +the contraints before simplifying. + +This only half-works, but then let-generalisation only half-works. + + Note [Inheriting implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: @@ -405,7 +453,7 @@ simplifySuperClass self wanteds ; (unsolved, ev_binds) <- runTcS SimplCheck emptyVarSet $ do { can_self <- canGivens loc [self] - ; let inert = foldlBag extendInertSet emptyInert can_self + ; let inert = foldlBag updInertSet emptyInert can_self -- No need for solveInteract; we know it's inert ; solveWanteds inert wanteds } @@ -512,7 +560,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted ; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds ; loc <- getCtLoc (RuleSkol name) ; rhs_binds1 <- simplifyCheck SimplCheck $ unitBag $ WcImplic $ - Implic { ic_env_tvs = emptyVarSet -- No untouchables + Implic { ic_untch = emptyVarSet -- No untouchables , ic_env = emptyNameEnv , ic_skols = mkVarSet tv_bndrs , ic_scoped = panic "emitImplication" @@ -642,12 +690,12 @@ solveImplication :: InertSet -- Given -- -- Precondition: everything is zonked by now solveImplication inert - imp@(Implic { ic_env_tvs = untch - , ic_binds = ev_binds - , ic_skols = skols - , ic_given = givens + imp@(Implic { ic_untch = untch + , ic_binds = ev_binds + , ic_skols = skols + , ic_given = givens , ic_wanted = wanteds - , ic_loc = loc }) + , ic_loc = loc }) = nestImplicTcS ev_binds untch $ do { traceTcS "solveImplication {" (ppr imp)