X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=853e2c491ef16c4e072da8d667218cfbfba2f72d;hb=162c7e780267c73495fb245a873f7e3b8431471b;hp=5cbffdd872945f6a721ab93b75e1779c79f7201b;hpb=cd2f5397bc1345fc37706168c268a8bd37af7f2f;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 5cbffdd..853e2c4 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -18,6 +18,8 @@ import TcInteract import Inst import Var import VarSet +import VarEnv ( varEnvElts ) + import Name import NameEnv ( emptyNameEnv ) import Bag @@ -208,8 +210,12 @@ simplifyInfer apply_mr tau_tvs 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) + ; traceTc "sinf" $ vcat + [ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound + , ptext (sLit "surely_free =") <+> ppr surely_free + ] -- Now simplify the possibly-bound constraints ; (simplified_perhaps_bound, tc_binds) @@ -247,7 +253,7 @@ simplifyAsMuchAsPossible :: SimplContext -> WantedConstraints -- We use this function when inferring the type of a function -- The wanted constraints are already zonked simplifyAsMuchAsPossible ctxt wanteds - = do { let untch = emptyVarSet + = do { let untch = NoUntouchables -- We allow ourselves to unify environment -- variables; hence *no untouchables* @@ -337,20 +343,28 @@ growWantedEVs gbl_tvs ws tvs | isEmptyBag ws = tvs | otherwise = fixVarSet (\tvs -> foldrBag (growWantedEV gbl_tvs) tvs ws) tvs +growEvVar :: TyVarSet -> EvVar -> TyVarSet -> TyVarSet 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 + +growEvVar gbl_tvs ev tvs = tvs `unionVarSet` (ev_tvs `minusVarSet` gbl_tvs) where - ev_tvs = growPredTyVars (wantedEvVarPred wev) tvs + ev_tvs = growPredTyVars (evVarPred ev) tvs + +growWantedEV gbl_tvs wev tvs = growEvVar gbl_tvs (wantedEvVarToVar wev) tvs 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) + = foldrBag (growWanted inner_gbl_tvs) + (foldr (growEvVar inner_gbl_tvs) tvs (ic_given implic)) + -- Must grow over inner givens too + (ic_wanted implic) + where + inner_gbl_tvs = gbl_tvs `unionVarSet` ic_skols implic -------------------- quantifyMe :: TyVarSet -- Quantifying over these @@ -363,8 +377,13 @@ quantifyMe qtvs wev pred = wantedEvVarPred wev quantifyMeWC :: TyVarSet -> WantedConstraint -> Bool +-- False => we can *definitely* float the WantedConstraint out quantifyMeWC qtvs (WcImplic implic) - = anyBag (quantifyMeWC (qtvs `minusVarSet` ic_skols implic)) (ic_wanted implic) + = (tyVarsOfEvVars (ic_given implic) `intersectsVarSet` inner_qtvs) + || anyBag (quantifyMeWC inner_qtvs) (ic_wanted implic) + where + inner_qtvs = qtvs `minusVarSet` ic_skols implic + quantifyMeWC qtvs (WcEvVar wev) = quantifyMe qtvs wev \end{code} @@ -451,7 +470,7 @@ simplifySuperClass self wanteds = do { wanteds <- mapBagM zonkWanted wanteds ; loc <- getCtLoc NoScSkol ; (unsolved, ev_binds) - <- runTcS SimplCheck emptyVarSet $ + <- runTcS SimplCheck NoUntouchables $ do { can_self <- canGivens loc [self] ; let inert = foldlBag updInertSet emptyInert can_self -- No need for solveInteract; we know it's inert @@ -560,7 +579,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_untch = emptyVarSet -- No untouchables + Implic { ic_untch = NoUntouchables , ic_env = emptyNameEnv , ic_skols = mkVarSet tv_bndrs , ic_scoped = panic "emitImplication" @@ -604,7 +623,7 @@ simplifyCheck ctxt wanteds ; traceTc "simplifyCheck {" (vcat [ ptext (sLit "wanted =") <+> ppr wanteds ]) - ; (unsolved, ev_binds) <- runTcS ctxt emptyVarSet $ + ; (unsolved, ev_binds) <- runTcS ctxt NoUntouchables $ solveWanteds emptyInert wanteds ; traceTc "simplifyCheck }" $ @@ -629,10 +648,13 @@ solveWanteds inert wanteds , text "inert =" <+> ppr inert ] ; (unsolved_flats, unsolved_implics) <- simpl_loop 1 can_flats implic_wanteds + ; bb <- getTcEvBindsBag ; traceTcS "solveWanteds }" $ vcat [ text "wanteds =" <+> ppr wanteds , text "unsolved_flats =" <+> ppr unsolved_flats - , text "unsolved_implics =" <+> ppr unsolved_implics ] + , text "unsolved_implics =" <+> ppr unsolved_implics + , text "current evbinds =" <+> vcat (map ppr (varEnvElts bb)) + ] ; return (unsolved_flats, unsolved_implics) } where simpl_loop :: Int @@ -697,6 +719,10 @@ solveImplication inert , ic_wanted = wanteds , ic_loc = loc }) = nestImplicTcS ev_binds untch $ + recoverTcS (return (emptyBag, emptyBag)) $ + -- Recover from nested failures. Even the top level is + -- just a bunch of implications, so failing at the first + -- one is bad do { traceTcS "solveImplication {" (ppr imp) -- Solve flat givens @@ -801,13 +827,13 @@ applyDefaultingRules inert wanteds | isEmptyBag wanteds = return emptyBag | otherwise - = do { untch <- getUntouchablesTcS + = do { untch <- getUntouchables ; tv_cts <- mapM (defaultTyVar untch) $ - varSetElems (tyVarsOfCanonicals wanteds) + varSetElems (tyVarsOfCDicts wanteds) ; info@(_, default_tys, _) <- getDefaultInfo ; let groups = findDefaultableGroups info untch wanteds - ; deflt_cts <- mapM (disambigGroup default_tys untch inert) groups + ; deflt_cts <- mapM (disambigGroup default_tys inert) groups ; traceTcS "deflt2" (vcat [ text "Tyvar defaults =" <+> ppr tv_cts , text "Type defaults =" <+> ppr deflt_cts]) @@ -815,7 +841,7 @@ applyDefaultingRules inert wanteds ; return (unionManyBags deflt_cts `andCCan` unionManyBags tv_cts) } ------------------ -defaultTyVar :: TcTyVarSet -> TcTyVar -> TcS CanonicalCts +defaultTyVar :: Untouchables -> TcTyVar -> TcS CanonicalCts -- defaultTyVar is used on any un-instantiated meta type variables to -- default the kind of ? and ?? etc to *. This is important to ensure -- that instance declarations match. For example consider @@ -831,10 +857,9 @@ defaultTyVar :: TcTyVarSet -> TcTyVar -> TcS CanonicalCts -- whatever, because the type-class defaulting rules have yet to run. defaultTyVar untch the_tv - | isMetaTyVar the_tv - , not (the_tv `elemVarSet` untch) + | isTouchableMetaTyVar_InRange untch the_tv , not (k `eqKind` default_k) - = do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k + = do { (ev, better_ty) <- TcSMonad.newKindConstraint the_tv default_k ; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk -- 'DefaultOrigin' is strictly the declaration, but it's convenient wanted_eq = CTyEqCan { cc_id = ev @@ -855,7 +880,7 @@ findDefaultableGroups :: ( SimplContext , [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> TcTyVarSet -- Untouchable + -> Untouchables -- Untouchable -> CanonicalCts -- Unsolved -> [[(CanonicalCt,TcTyVar)]] findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) @@ -882,7 +907,7 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) is_defaultable_group ds@((_,tv):_) = isTyConableTyVar tv -- Note [Avoiding spurious errors] && not (tv `elemVarSet` bad_tvs) - && not (tv `elemVarSet` untch) -- Non untouchable + && isTouchableMetaTyVar_InRange untch tv && defaultable_classes [cc_class cc | (cc,_) <- ds] is_defaultable_group [] = panic "defaultable_group" @@ -904,15 +929,14 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) ------------------------------ disambigGroup :: [Type] -- The default types - -> TcTyVarSet -- Untouchables -> InertSet -- Given inert -> [(CanonicalCt, TcTyVar)] -- All classes of the form (C a) -- sharing same type variable -> TcS CanonicalCts -disambigGroup [] _inert _untch _grp +disambigGroup [] _inert _grp = return emptyBag -disambigGroup (default_ty:default_tys) untch inert group +disambigGroup (default_ty:default_tys) inert group = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty) ; ev <- newGivOrDerCoVar (mkTyVarTy the_tv) default_ty default_ty -- Refl -- We know this equality is canonical, @@ -922,7 +946,7 @@ disambigGroup (default_ty:default_tys) untch inert group , cc_tyvar = the_tv , cc_rhs = default_ty } - ; success <- tryTcS (extendVarSet untch the_tv) $ + ; success <- tryTcS $ do { given_inert <- solveOne inert given_eq ; final_inert <- solveInteract given_inert (listToBag wanteds) ; let (_, unsolved) = extractUnsolved final_inert @@ -936,7 +960,7 @@ disambigGroup (default_ty:default_tys) untch inert group ; return (unitBag given_eq) } False -> -- Failure: try with the next type do { traceTcS "disambigGoup succeeded" (ppr default_ty) - ; disambigGroup default_tys untch inert group } } + ; disambigGroup default_tys inert group } } where ((the_ct,the_tv):_) = group wanteds = map fst group