Fix recursive superclasses (again). Fixes Trac #4809.

[ghc-hetmet.git] / compiler / typecheck / TcInteract.lhs

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index b49ec65..30b1ae1 100644 (file)
--- 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
@@ -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]