= 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
-- 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
-- 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
\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
; 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]