X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInteract.lhs;h=30b1ae1924f34f35c89dfc861c20ed99c361f1ee;hb=e491aa14a33502ade10049611d9fb79bab8360fc;hp=c04fd0f93503707342830e1e05ce86b1d8220503;hpb=5688fe994cff4cc70b717918bdbccaaf5236f3af;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index c04fd0f..30b1ae1 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -187,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 @@ -397,11 +399,72 @@ 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 - } + ; sctx <- getTcSContext + + ; traceTcS "solveInteract, before clever canonicalization:" $ + ppr (mapBag (\(ct,ev) -> (ct,evVarPred ev)) ws) + + ; can_ws <- foldlBagM (tryPreSolveAndCanon sctx inert) emptyCCan ws + + ; traceTcS "solveInteract, after clever canonicalization:" $ + ppr can_ws + + ; solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) inert can_ws } + +tryPreSolveAndCanon :: SimplContext -> 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 sctx is cts_acc (fl,ev_var) + | ClassP clas tys <- evVarPred ev_var + , not $ simplEqsOnly sctx -- And we *can* discharge constraints from other constraints + = 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 @@ -840,9 +903,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 @@ -1875,33 +1938,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 - --} - data LookupInstResult = NoInstance @@ -1927,7 +1963,7 @@ 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]