Commit 5723262f authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent fbb99e83
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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..]
......
......@@ -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
......
......@@ -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]
......
......@@ -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}
......@@ -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
......
......@@ -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}
......
......@@ -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")
......
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