Commit 62f76a3c authored by dimitris@microsoft.com's avatar dimitris@microsoft.com
Browse files

Doing the smart canonicalization only if we are not simplifying a Rule LHS.

Also, same thing now applies for adding superclasses.
parent ef6d82a4
......@@ -247,8 +247,11 @@ canClass fl v cn tys
else setDictBind v' (EvCast v (mkSymCoercion dict_co))
; return v' }
-- Add the superclasses of this one here, See Note [Adding superclasses]
; sc_cts <- newSCWorkFromFlavored v_new fl cn xis
-- Add the superclasses of this one here, See Note [Adding superclasses].
-- But only if we are not simplifying the LHS of a rule.
; sctx <- getTcSContext
; sc_cts <- if simplEqsOnly sctx then return emptyCCan
else newSCWorkFromFlavored v_new fl cn xis
; return (sc_cts `andCCan` ccs `extendCCans` CDictCan { cc_id = v_new
, cc_flavor = fl
......
......@@ -402,15 +402,25 @@ React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canoni
solveInteract :: InertSet -> Bag (CtFlavor,EvVar) -> TcS InertSet
solveInteract inert ws
= do { dyn_flags <- getDynFlags
; can_ws <- foldlBagM (tryPreSolveAndCanon inert) emptyCCan 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 :: InertSet -> CanonicalCts -> (CtFlavor, EvVar) -> TcS CanonicalCts
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 is cts_acc (fl,ev_var)
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)
......
......@@ -460,6 +460,7 @@ data SimplContext
| SimplRuleLhs -- Inferring type of a RULE lhs
| SimplInteractive -- Inferring type at GHCi prompt
| SimplCheck -- Checking a type signature or RULE rhs
deriving Eq
instance Outputable SimplContext where
ppr SimplInfer = ptext (sLit "SimplInfer")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment