From 5723262f616ac02ddf637f6ff480a599c737ea0d Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 2 Dec 2010 12:35:47 +0000 Subject: [PATCH] Re-jig simplifySuperClass (again) This fixes the current loop in T3731, and will fix other reported loops. The loops show up when we are generating evidence for superclasses in an instance declaration. The trick is to make the "self" dictionary simplifySuperClass depend *explicitly* on the superclass we are currently trying to build. See Note [Dependencies in self dictionaries] in TcSimplify. That in turn means that EvDFunApp needs a dependency-list, used when chasing dependencies in isGoodRecEv. --- compiler/deSugar/DsBinds.lhs | 18 +++---- compiler/hsSyn/HsBinds.lhs | 8 +-- compiler/typecheck/TcCanonical.lhs | 4 -- compiler/typecheck/TcHsSyn.lhs | 4 +- compiler/typecheck/TcInstDcls.lhs | 4 +- compiler/typecheck/TcInteract.lhs | 32 ++---------- compiler/typecheck/TcSMonad.lhs | 23 ++++----- compiler/typecheck/TcSimplify.lhs | 97 +++++++++++++++++++++++++++++------- compiler/typecheck/TcType.lhs | 4 -- 9 files changed, 110 insertions(+), 84 deletions(-) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 48fad92..d7a88c0 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -230,11 +230,11 @@ dsEvBinds bs = return (map dsEvGroup sccs) mk_node b@(EvBind var term) = (b, var, free_vars_of term) free_vars_of :: EvTerm -> [EvVar] - free_vars_of (EvId v) = [v] - free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co) - free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co) - free_vars_of (EvDFunApp _ _ vs) = vs - free_vars_of (EvSuperClass d _) = [d] + free_vars_of (EvId v) = [v] + free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co) + free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co) + free_vars_of (EvDFunApp _ _ vs _) = vs + free_vars_of (EvSuperClass d _) = [d] dsEvGroup :: SCC EvBind -> DsEvBind dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n))) @@ -261,10 +261,10 @@ dsEvGroup (CyclicSCC bs) ds_pair (EvBind v r) = (v, dsEvTerm r) dsEvTerm :: EvTerm -> CoreExpr -dsEvTerm (EvId v) = Var v -dsEvTerm (EvCast v co) = Cast (Var v) co -dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars -dsEvTerm (EvCoercion co) = Type co +dsEvTerm (EvId v) = Var v +dsEvTerm (EvCast v co) = Cast (Var v) co +dsEvTerm (EvDFunApp df tys vars _deps) = Var df `mkTyApps` tys `mkVarApps` vars +dsEvTerm (EvCoercion co) = Type co dsEvTerm (EvSuperClass d n) = ASSERT( isClassPred (classSCTheta cls !! n) ) -- We can only select *dictionary* superclasses diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index da247c2..0a4769d 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -447,7 +447,10 @@ data EvTerm | EvCast EvVar Coercion -- d |> co | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvVar] + [Type] [EvVar] + [EvVar] -- The dependencies, which is generally a bigger list than + -- the arguments of the dfun. + -- See Note [Dependencies in self dictionaries] in TcSimplify | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and -- dictionaries, even though the former have no @@ -574,8 +577,7 @@ instance Outputable EvTerm where ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co ppr (EvCoercion co) = ppr co ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) - ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys - , ppr ts ] + ppr (EvDFunApp df tys ts deps) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts, ppr deps ] \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 9c7bba9..b9edd5f 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -317,10 +317,6 @@ happen. newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS CanonicalCts -- Returns superclasses, see Note [Adding superclasses] newSCWorkFromFlavored ev orig_flavor cls xis - | Given loc <- orig_flavor -- Very important! - , NoScSkol <- ctLocOrigin loc - = return emptyCCan - | otherwise = do { let (tyvars, sc_theta, _, _) = classBigSig cls sc_theta1 = substTheta (zipTopTvSubst tyvars xis) sc_theta ; sc_vars <- zipWithM inst_one sc_theta1 [0..] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 3d6c491..5367f8f 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1033,10 +1033,10 @@ zonkEvTerm env (EvCast v co) = ASSERT( isId v) do { co' <- zonkTcTypeToType env co ; return (EvCast (zonkIdOcc env v) co') } zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) -zonkEvTerm env (EvDFunApp df tys tms) +zonkEvTerm env (EvDFunApp df tys tms _deps) -- Ignore the dependencies = do { tys' <- zonkTcTypeToTypes env tys ; let tms' = map (zonkEvVarOcc env) tms - ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } + ; return (EvDFunApp (zonkIdOcc env df) tys' tms' _deps) } zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 4e40be3..dd7424a 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -616,7 +616,9 @@ tc_inst_decl2 dfun_id inst_binds -- to use in each method binding -- Why? See Note [Subtle interaction of recursion and overlap] ; let self_ev_bind = EvBind self_dict $ - EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars + EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars [] + -- Empty dependencies [], since it only + -- depends on "given" things -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index b49ec65..e1ea65f 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1875,33 +1875,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,11 +1900,12 @@ 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] - ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) } + ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars ev_vars) } + -- NB: All the dependencies are ev_vars } } \end{code} diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index a45f9a5..85b5847 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -11,7 +11,7 @@ module TcSMonad ( mkWantedConstraints, deCanonicaliseWanted, makeGivens, makeSolvedByInst, - CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst, + CtFlavor (..), isWanted, isGiven, isDerived, isGivenCt, isWantedCt, pprFlavorArising, isFlexiTcsTv, @@ -300,9 +300,10 @@ data CtFlavor -- these wanteds | Wanted WantedLoc -- We have no evidence bindings for this constraint. -data DerivedOrig = DerSC | DerInst +data DerivedOrig = DerSC | DerInst | DerSelf -- Deriveds are either superclasses of other wanteds or deriveds, or partially --- solved wanteds from instances. +-- solved wanteds from instances, or 'self' dictionaries containing yet wanted +-- superclasses. instance Outputable CtFlavor where ppr (Given _) = ptext (sLit "[Given]") @@ -321,14 +322,6 @@ isDerived :: CtFlavor -> Bool isDerived (Derived {}) = True isDerived _ = False -isDerivedSC :: CtFlavor -> Bool -isDerivedSC (Derived _ DerSC) = True -isDerivedSC _ = False - -isDerivedByInst :: CtFlavor -> Bool -isDerivedByInst (Derived _ DerInst) = True -isDerivedByInst _ = False - pprFlavorArising :: CtFlavor -> SDoc pprFlavorArising (Derived wl _) = pprArisingAt wl pprFlavorArising (Wanted wl) = pprArisingAt wl @@ -909,9 +902,11 @@ isGoodRecEv ev_var wv chase_ev assocs trg curr_grav visited (EvCoercion co) = chase_co assocs trg curr_grav visited co - chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars) - = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars - ; return (comb_chase_res Nothing chase_results) } + chase_ev assocs trg curr_grav visited (EvDFunApp _ _ _ev_vars ev_deps) + = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_deps + -- Notice that we chase the ev_deps and not the ev_vars + -- See Note [Dependencies in self dictionaries] in TcSimplify + ; return (comb_chase_res Nothing chase_results) } chase_co assocs trg curr_grav visited co = -- Look for all the coercion variables in the coercion diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index f6b9ed2..0da5eec 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -33,6 +33,7 @@ import BasicTypes ( RuleName ) import Data.List ( partition ) import Outputable import FastString +import Control.Monad ( unless ) \end{code} @@ -440,8 +441,7 @@ over implicit parameters. See the predicate isFreeWhenInferring. *********************************************************************************** When constructing evidence for superclasses in an instance declaration, - * we MUST have the "self" dictionary available, but - * we must NOT have its superclasses derived from "self" + * we MUST have the "self" dictionary available Moreover, we must *completely* solve the constraints right now, not wrap them in an implication constraint to solve later. Why? @@ -461,25 +461,86 @@ Now, if there is some *other* top-level constraint solved looking like foo :: Ord [Int] foo = scsel dCInt -we must not solve the (Ord [Int]) wanted from foo!! +we must not solve the (Ord [Int]) wanted from foo! + +Note [Dependencies in self dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Moreover, notice that when solving for a superclass, we record the dependency of +self on the superclass. This is because this dependency is not evident in the +EvBind of the self dictionary, which only involves a call to a DFun. Example: + +class A a => C a +instance B a => C a + +When we check the instance declaration, we pass in a self dictionary that is merely + self = dfun b +But we will be asked to solve that from: + [Given] d : B a + [Derived] self : C a +We can show: + [Wanted] sc : A a +The problem is that self *depends* on the sc variable, but that is not apparent in +the binding self = dfun b. So we record the extra dependency, using the evidence bind: + EvBind self (EvDFunApp dfun [b] [b,sc]) +It is these dependencies that are the ''true'' dependencies in an EvDFunApp, and those +that we must chase in function isGoodRecEv (in TcSMonad) \begin{code} -simplifySuperClass :: EvVar -- The "self" dictionary - -> WantedConstraints - -> TcM () -simplifySuperClass self wanteds - = do { wanteds <- mapBagM zonkWanted wanteds - ; loc <- getCtLoc NoScSkol - ; ((unsolved_flats,unsolved_impls), frozen_errors, ev_binds) +simplifySuperClass :: [TyVar] + -> [EvVar] -- givens + -> EvVar -- the superclass we must solve for + -> EvBind -- the 'self' evidence bind + -> TcM TcEvBinds +-- Post: +-- ev_binds <- simplifySuperClasses tvs inst_givens sc_dict self_ev_bind +-- Then: +-- 1) ev_binds already contains self_ev_bind +-- 2) if successful then ev_binds contains binding for +-- the wanted superclass, sc_dict +simplifySuperClass tvs inst_givens sc_dict (EvBind self_dict self_ev) + = do { giv_loc <- getCtLoc InstSkol -- For the inst_givens + ; want_loc <- getCtLoc ScOrigin -- As wanted/derived (for the superclass and self) + ; lcl_env <- getLclTypeEnv + + -- Record the dependency of self_dict to sc_dict, see Note [Dependencies in self dictionaries] + ; let wanted = unitBag $ WcEvVar $ WantedEvVar sc_dict want_loc + self_ev_with_dep + = case self_ev of + EvDFunApp df tys insts deps -> EvDFunApp df tys insts (sc_dict:deps) + _ -> panic "Self-dictionary not EvDFunApp!" + + -- And solve for it + ; ((unsolved_flats, unsolved_implics), frozen_errors, ev_binds) <- runTcS SimplCheck NoUntouchables $ - do { can_self <- canGivens loc [self] - ; let inert = foldlBag updInertSet emptyInert can_self - -- No need for solveInteract; we know it's inert - - ; solveWanteds inert wanteds } - - ; ASSERT2( isEmptyBag ev_binds, ppr ev_binds ) - reportUnsolved (unsolved_flats,unsolved_impls) frozen_errors } + do { -- Record a binding for self_dict that *depends on sc_dict* + -- And canonicalise self_dict (which adds its superclasses) + -- with a Derived origin, which in turn triggers the + -- goodRecEv recursive-evidence check + ; setEvBind self_dict self_ev_with_dep + ; can_selfs <- mkCanonical (Derived want_loc DerSelf) self_dict + + -- The rest is just like solveImplication + ; can_inst_givens <- mkCanonicals (Given giv_loc) inst_givens + ; inert <- solveInteract emptyInert $ + can_inst_givens `andCCan` can_selfs + ; solveWanteds inert wanted } + + -- For error reporting, conjure up a fake implication, + -- so that we get decent error messages + ; let implic = Implic { ic_untch = NoUntouchables + , ic_env = lcl_env + , ic_skols = mkVarSet tvs + , ic_given = inst_givens + , ic_wanted = mapBag WcEvVar unsolved_flats + , ic_scoped = panic "super1" + , ic_binds = panic "super2" + , ic_loc = giv_loc } + ; ASSERT (isEmptyBag unsolved_implics) -- Impossible to have any implications! + unless (isEmptyBag unsolved_flats) $ + reportUnsolved (emptyBag, unitBag implic) frozen_errors + + ; return (EvBinds ev_binds) } \end{code} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index d4a4b82..b2da9f0 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -339,9 +339,6 @@ data SkolemInfo | RuntimeUnkSkol -- a type variable used to represent an unknown -- runtime type (used in the GHCi debugger) - | NoScSkol -- Used for the "self" superclass when solving - -- superclasses; don't generate superclasses of me - | UnkSkol -- Unhelpful info (until I improve it) ------------------------------------- @@ -461,7 +458,6 @@ pprSkolInfo (IPSkol ips) = ptext (sLit "the implicit-parameter bindings for") <+> pprWithCommas ppr ips pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls) pprSkolInfo InstSkol = ptext (sLit "the instance declaration") -pprSkolInfo NoScSkol = ptext (sLit "the instance declaration (self)") pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration") pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name) pprSkolInfo ArrowSkol = ptext (sLit "the arrow form") -- 1.7.10.4