import Bag
import qualified Data.Map as Map
-import Control.Monad( zipWithM, unless )
+import Control.Monad( unless )
import FastString ( sLit )
import DynFlags
\end{code}
= 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
(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.
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
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]
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
; 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 } }
} }
; 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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
; 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]
projects / ghc-hetmet.git / blobdiff