X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInteract.lhs;h=aeb78d832c38c84a5f9829e42e7cdf76860009d0;hb=ef6d82a4e1d4ba4884c322be85cff291e017f0e6;hp=44e8479d339fedaffed24a1969ac87a445ef78f9;hpb=c80364f8e4681b34e974f5df36ecdacec7cd9cd8;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 44e8479..aeb78d8 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1,6 +1,6 @@ \begin{code} module TcInteract ( - solveInteract, AtomicInert, + solveInteract, AtomicInert, tyVarsOfInert, InertSet, emptyInert, updInertSet, extractUnsolved, solveOne, foldISEqCts ) where @@ -36,7 +36,7 @@ import TcSMonad import Bag import qualified Data.Map as Map -import Control.Monad( zipWithM, unless ) +import Control.Monad( unless ) import FastString ( sLit ) import DynFlags \end{code} @@ -134,6 +134,14 @@ data InertSet -- and reside either in the worklist or in the inerts } +tyVarsOfInert :: InertSet -> TcTyVarSet +tyVarsOfInert (IS { inert_eqs = eqs + , inert_dicts = dictmap + , inert_ips = ipmap + , inert_funeqs = funeqmap }) = tyVarsOfCanonicals cts + where cts = eqs `andCCan` cCanMapToBag dictmap + `andCCan` cCanMapToBag ipmap `andCCan` cCanMapToBag funeqmap + type FDImprovement = (PredType,PredType) type FDImprovements = [(PredType,PredType)] @@ -179,6 +187,8 @@ foldISEqCts k z IS { inert_eqs = eqs } = Bag.foldlBag k z eqs extractUnsolved :: InertSet -> (InertSet, CanonicalCts) +-- Postcondition: the canonical cts returnd are the very same as the +-- WantedEvVars in their canonical form. extractUnsolved is@(IS {inert_eqs = eqs}) = let is_solved = is { inert_eqs = solved_eqs , inert_dicts = solved_dicts @@ -389,11 +399,62 @@ React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canoni -- returning an extended inert set. -- -- See Note [Touchables and givens]. -solveInteract :: InertSet -> CanonicalCts -> TcS InertSet +solveInteract :: InertSet -> Bag (CtFlavor,EvVar) -> TcS InertSet solveInteract inert ws = do { dyn_flags <- getDynFlags - ; solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) inert ws - } + ; can_ws <- foldlBagM (tryPreSolveAndCanon inert) emptyCCan ws + ; solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) inert can_ws } + +tryPreSolveAndCanon :: InertSet -> CanonicalCts -> (CtFlavor, EvVar) -> TcS CanonicalCts +-- Checks if this constraint can be immediately solved from a constraint in the +-- inert set or in the previously encountered CanonicalCts and only then +-- canonicalise it. See Note [Avoiding the superclass explosion] +tryPreSolveAndCanon is cts_acc (fl,ev_var) + | ClassP clas tys <- evVarPred ev_var + = do { let (relevant_inert_dicts,_) = getRelevantCts clas (inert_dicts is) + ; b <- dischargeFromCans (cts_acc `unionBags` relevant_inert_dicts) + (fl,ev_var,clas,tys) + ; extra_cts <- if b then return emptyCCan else mkCanonical fl ev_var + ; return (cts_acc `unionBags` extra_cts) } + | otherwise + = do { extra_cts <- mkCanonical fl ev_var + ; return (cts_acc `unionBags` extra_cts) } + +dischargeFromCans :: CanonicalCts -> (CtFlavor,EvVar,Class,[Type]) -> TcS Bool +dischargeFromCans cans (fl,ev,clas,tys) + = Bag.foldlBagM discharge_ct False cans + where discharge_ct :: Bool -> CanonicalCt -> TcS Bool + discharge_ct True _ct = return True + discharge_ct False (CDictCan { cc_id = ev1, cc_flavor = fl1 + , cc_class = clas1, cc_tyargs = tys1 }) + | clas1 == clas + , (and $ zipWith tcEqType tys tys1) + , fl1 `canSolve` fl + = setEvBind ev (EvId ev1) >> return True + discharge_ct False _ct = return False +\end{code} + +Note [Avoiding the superclass explosion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider the example: + f = [(0,1,0,1,0)] +We have 5 wanted (Num alpha) constraints. If we simply try to canonicalize and add them +in our worklist, we will also get all of their superclasses as Derived, hence we will +have an inert set that contains 5*n constraints, where n is the number of superclasses +of of Num. That is bad for the additional reason that we keep *all* the Derived, even +for identical class constraints (for reasons related to recursive dictionaries). + +Instead, what we do with tryPreSolveAndCanon, is when we encounter a new constraint, +such as the second (Num alpha) above we very quickly see if it can be immediately +discharged by a class constraint in our inert set or the previous canonicals. If so, +we add nothing to the returned canonical constraints. + +For our particular example this will reduce the size of the inert set that we use from +5*n to just n. And hence the number of all possible interactions that we have to look +through is significantly smaller! + +\begin{code} solveOne :: InertSet -> WorkItem -> TcS InertSet solveOne inerts workItem = do { dyn_flags <- getDynFlags @@ -832,9 +893,9 @@ interactWithInert fdimprs inert workitem -- We don't have to do this for givens, as we fully know the evidence for them. ; rec_ev_ok <- case (cc_flavor inert, cc_flavor workitem) of - (Wanted loc, Derived {}) -> isGoodRecEv work_ev (WantedEvVar inert_ev loc) - (Derived {}, Wanted loc) -> isGoodRecEv inert_ev (WantedEvVar work_ev loc) - _ -> return True + (Wanted {}, Derived {}) -> isGoodRecEv work_ev inert_ev + (Derived {}, Wanted {}) -> isGoodRecEv inert_ev work_ev + _ -> return True ; if is_allowed && rec_ev_ok then doInteractWithInert fdimprs inert workitem @@ -889,23 +950,18 @@ doInteractWithInert _fdimprs (CDictCan { cc_id = dv, cc_flavor = wfl, cc_class = cl, cc_tyargs = xis }) | ifl `canRewrite` wfl , tv `elemVarSet` tyVarsOfTypes xis - = if isDerivedSC wfl then - mkIRStop KeepInert $ emptyWorkList -- See Note [Adding Derived Superclasses] - else do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,wfl,cl,xis) + = do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,wfl,cl,xis) -- Continue with rewritten Dictionary because we can only be in the -- interactWithEqsStage, so the dictionary is inert. - ; mkIRContinue rewritten_dict KeepInert emptyWorkList } + ; mkIRContinue rewritten_dict KeepInert emptyWorkList } doInteractWithInert _fdimprs (CDictCan { cc_id = dv, cc_flavor = ifl, cc_class = cl, cc_tyargs = xis }) workItem@(CTyEqCan { cc_id = cv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi }) | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfTypes xis - = if isDerivedSC ifl then - mkIRContinue workItem DropInert emptyWorkList -- No need to do any rewriting, - -- see Note [Adding Derived Superclasses] - else do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,ifl,cl,xis) - ; mkIRContinue workItem DropInert (workListFromCCan rewritten_dict) } + = do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,ifl,cl,xis) + ; mkIRContinue workItem DropInert (workListFromCCan rewritten_dict) } -- Class constraint and given equality: use the equality to rewrite -- the class constraint. @@ -1561,20 +1617,17 @@ allowedTopReaction _ _ = True doTopReact :: WorkItem -> TcS TopInteractResult --- The work item does not react with the inert set, --- so try interaction with top-level instances +-- The work item does not react with the inert set, so try interaction with top-level instances +-- NB: The place to add superclasses in *not* in doTopReact stage. Instead superclasses are +-- added in the worklist as part of the canonicalisation process. +-- See Note [Adding superclasses] in TcCanonical. --- Given dictionary; just add superclasses +-- Given dictionary -- See Note [Given constraint that matches an instance declaration] -doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Given loc - , cc_class = cls, cc_tyargs = xis }) - = do { sc_work <- newGivenSCWork dv loc cls xis - ; return $ SomeTopInt sc_work (ContinueWith workItem) } +doTopReact (CDictCan { cc_flavor = Given {} }) + = return NoTopInt -- NB: Superclasses already added since it's canonical --- Derived dictionary --- Do not add any further derived superclasses; their --- full transitive closure has already been added. --- But do look for functional dependencies +-- Derived dictionary: just look for functional dependencies doTopReact workItem@(CDictCan { cc_flavor = Derived loc _ , cc_class = cls, cc_tyargs = xis }) = do { fd_work <- findClassFunDeps cls xis loc @@ -1582,7 +1635,7 @@ doTopReact workItem@(CDictCan { cc_flavor = Derived loc _ return NoTopInt else return $ SomeTopInt { tir_new_work = fd_work , tir_new_inert = ContinueWith workItem } } - +-- Wanted dictionary doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Wanted loc , cc_class = cls, cc_tyargs = xis }) = do { -- See Note [MATCHING-SYNONYMS] @@ -1592,22 +1645,13 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Wanted loc do { traceTcS "doTopReact/ no class instance for" (ppr dv) ; fd_work <- findClassFunDeps cls xis loc ; if isEmptyWorkList fd_work then - do { sc_work <- newDerivedSCWork dv loc cls xis - -- See Note [Adding Derived Superclasses] - -- NB: workItem is inert, but it isn't solved - -- keep it as inert, although it's not solved - -- because we have now reacted all its - -- top-level fundep-induced equalities! - ; return $ SomeTopInt - { tir_new_work = fd_work `unionWorkLists` sc_work - , tir_new_inert = ContinueWith workItem } } - - else -- More fundep work produced, don't do any superclass stuff, - -- just thow him back in the worklist, which will prioritize - -- the solution of fd equalities + return $ SomeTopInt + { tir_new_work = emptyWorkList + , tir_new_inert = ContinueWith workItem } + else -- More fundep work produced, just thow him back in the + -- worklist to prioritize the solution of fd equalities return $ SomeTopInt - { tir_new_work = fd_work `unionWorkLists` - workListFromCCan workItem + { tir_new_work = fd_work `unionWorkLists` workListFromCCan workItem , tir_new_inert = Stop } } GenInst wtvs ev_term -> -- Solved @@ -1620,17 +1664,15 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Wanted loc ; if null wtvs -- Solved in one step and no new wanted work produced. -- i.e we directly matched a top-level instance - -- No point in caching this in 'inert', nor in adding superclasses + -- No point in caching this in 'inert' then return $ SomeTopInt { tir_new_work = emptyWorkList , tir_new_inert = Stop } -- Solved and new wanted work produced, you may cache the - -- (tentatively solved) dictionary as Derived and its superclasses + -- (tentatively solved) dictionary as Derived else do { let solved = makeSolvedByInst workItem - ; sc_work <- newDerivedSCWork dv loc cls xis - -- See Note [Adding Derived Superclasses] ; return $ SomeTopInt - { tir_new_work = inst_work `unionWorkLists` sc_work + { tir_new_work = inst_work , tir_new_inert = ContinueWith solved } } } } @@ -1683,64 +1725,6 @@ findClassFunDeps cls xis loc ; canWanteds wevvars } \end{code} -Note [Adding Derived Superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, we want to be able to add derived superclasses of -unsolved wanteds, and wanteds that have been partially being solved -via an instance. This is important to be able to simplify the inferred -constraints more (and to allow for recursive dictionaries, less -importantly). Example: - -Inferred wanted constraint is (Eq a, Ord a), but we'd only like to -quantify over Ord a, hence we would like to be able to add the -superclass of Ord a as Derived and use it to solve the wanted Eq a. - -Hence we will add Derived superclasses in the following two cases: - (1) When we meet an unsolved wanted in top-level reactions - (2) When we partially solve a wanted in top-level reactions using an instance decl. - -At that point, we have two options: - (1) Add transitively add *ALL* of the superclasses of the Derived - (2) Add only the immediate ones, but whenever we meet a Derived in - the future, add its own superclasses as Derived. - -Option (2) is terrible, because deriveds may be rewritten or kicked -out of the inert set, which will result in slightly rewritten -superclasses being reintroduced in the worklist and the inert set. Eg: - - class C a => B a - instance Foo a => B [a] - -Original constraints: -[Wanted] d : B [a] -[Given] co : a ~ Int - -We apply the instance to the wanted and put it and its superclasses as -as Deriveds in the inerts: - -[Derived] d : B [a] -[Derived] (sel d) : C [a] - -The work is now: -[Given] co : a ~ Int -[Wanted] d' : Foo a - -Now, suppose that we interact the Derived with the Given equality, and -kick him out of the inert, the next time around a superclass C [Int] -will be produced -- but we already *have* C [a] in the inerts which -will anyway get rewritten to C [Int]. - -So we choose (1), and *never* introduce any more superclass work from -Deriveds. This enables yet another optimisation: If we ever meet an -equality that can rewrite a Derived, if that Derived is a superclass -derived (like C [a] above), i.e. not a partially solved one (like B -[a]) above, we may simply completely *discard* that Derived. The -reason is because somewhere in the inert lies the original wanted, or -partially solved constraint that gave rise to that superclass, and -that constraint *will* be kicked out, and *will* result in the -rewritten superclass to be added in the inerts later on, anyway. - - Note [FunDep and implicit parameter reactions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1944,40 +1928,6 @@ NB: The desugarer needs be more clever to deal with equalities \begin{code} -newGivenSCWork :: EvVar -> GivenLoc -> Class -> [Xi] -> TcS WorkList -newGivenSCWork ev loc cls xis - | NoScSkol <- ctLocOrigin loc -- Very important! - = return emptyWorkList - | otherwise - = newImmSCWorkFromFlavored ev (Given loc) cls xis >>= return - -newDerivedSCWork :: EvVar -> WantedLoc -> Class -> [Xi] -> TcS WorkList -newDerivedSCWork ev loc cls xis - = do { ims <- newImmSCWorkFromFlavored ev flavor cls xis - ; rec_sc_work ims } - where - rec_sc_work :: CanonicalCts -> TcS CanonicalCts - rec_sc_work cts - = do { bg <- mapBagM (\c -> do { ims <- imm_sc_work c - ; recs_ims <- rec_sc_work ims - ; return $ consBag c recs_ims }) cts - ; return $ concatBag bg } - imm_sc_work (CDictCan { cc_id = dv, cc_flavor = fl, cc_class = cls, cc_tyargs = xis }) - = newImmSCWorkFromFlavored dv fl cls xis - imm_sc_work _ct = return emptyCCan - - flavor = Derived loc DerSC - -newImmSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS WorkList --- Returns immediate superclasses -newImmSCWorkFromFlavored ev flavor cls xis - = do { let (tyvars, sc_theta, _, _) = classBigSig cls - sc_theta1 = substTheta (zipTopTvSubst tyvars xis) sc_theta - ; sc_vars <- zipWithM inst_one sc_theta1 [0..] - ; mkCanonicals flavor sc_vars } - where - inst_one pred n = newGivOrDerEvVar pred (EvSuperClass ev n) - data LookupInstResult = NoInstance @@ -2003,11 +1953,12 @@ matchClassInst clas tys loc ; tys <- instDFunTypes mb_inst_tys ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys) ; if null theta then - return (GenInst [] (EvDFunApp dfun_id tys [])) + return (GenInst [] (EvDFunApp dfun_id tys [] [])) else do { ev_vars <- instDFunConstraints theta ; let wevs = [WantedEvVar w loc | w <- ev_vars] - ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) } + ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars ev_vars) } + -- NB: All the dependencies are ev_vars } } \end{code}