From: simonpj Date: Wed, 9 Mar 2005 14:27:03 +0000 (+0000) Subject: [project @ 2005-03-09 14:26:56 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~932 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=aca101dd54968a1da6decc86716f5d0fdb2fd989 [project @ 2005-03-09 14:26:56 by simonpj] Fix the superclass translation for instance decls Merge to STABLE There is a long-standing difficulty whereby it's surprisingly easy to accidentally generate an entirely-bogus recursive dictionary when generating the definitions for the superclasses of an instance decl. The problem arises because the default story is that whenever we add a constraint to our pile of solved constraints, we automatically add all its superclasses. But that is simply wrong when we are trying to generate superclasses. Solution: do no auto-superclass addition when solving the superclass constraints of an instance declaration. I think should fix it once and for all. tcrun021, tcrun033 are test cases tcrun033 showed up the bug; thanks to Simon Foster and Ralf Laemmel. --- diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index f75d1d3..3d3ea8b 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -12,7 +12,7 @@ module Inst ( tidyInsts, tidyMoreInsts, - newDictsFromOld, newDicts, newDictsAtLoc, cloneDict, + newDicts, newDictAtLoc, newDictsAtLoc, cloneDict, newOverloadedLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, tcInstClassOp, tcInstCall, tcInstStupidTheta, @@ -22,7 +22,7 @@ module Inst ( ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, instLoc, getDictClassTys, dictPred, - lookupInst, LookupInstResult(..), + lookupInst, LookupInstResult(..), lookupPred, tcExtendLocalInstEnv, tcGetInstEnvs, isDict, isClassDict, isMethod, @@ -228,21 +228,20 @@ cloneDict :: Inst -> TcM Inst cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq -> returnM (Dict (setNameUnique nm uniq) ty loc) -newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst] -newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta +newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst +newDictAtLoc inst_loc pred + = do { uniq <- newUnique + ; return (mkDict inst_loc uniq pred) } --- Local function, similar to newDicts, --- but with slightly different interface -newDictsAtLoc :: InstLoc - -> TcThetaType - -> TcM [Inst] +newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst] newDictsAtLoc inst_loc theta = newUniqueSupply `thenM` \ us -> - returnM (zipWith mk_dict (uniqsFromSupply us) theta) + returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta) + +mkDict inst_loc uniq pred + = Dict name pred inst_loc where - mk_dict uniq pred = Dict (mkPredName uniq loc pred) - pred inst_loc - loc = instLocSrcLoc inst_loc + name = mkPredName uniq (instLocSrcLoc inst_loc) pred -- For vanilla implicit parameters, there is only one in scope -- at any time, so we used to use the name of the implicit parameter itself @@ -683,30 +682,13 @@ lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc) (HsVar (instToId method_inst))) rat_lit)) -- Dictionaries -lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) - = do { pkg_ie <- loadImportedInsts clas tys - -- Suck in any instance decls that may be relevant - ; tcg_env <- getGblEnv - ; dflags <- getDOpts - ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of { - ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ; - (matches, unifs) -> do - { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred, - text "matches" <+> ppr matches, - text "unifs" <+> ppr unifs]) - ; return NoInstance } } } - -- In the case of overlap (multiple matches) we report - -- NoInstance here. That has the effect of making the - -- context-simplifier return the dict as an irreducible one. - -- Then it'll be given to addNoInstanceErrs, which will do another - -- lookupInstEnv to get the detailed info about what went wrong. - -lookupInst (Dict _ _ _) = returnM NoInstance +lookupInst (Dict _ pred loc) + = do { mb_result <- lookupPred pred + ; case mb_result of { + Nothing -> return NoInstance ; + Just (tenv, dfun_id) -> do ------------------ -instantiate_dfun :: TvSubst -> DFunId -> TcPredType -> InstLoc -> TcM LookupInstResult -instantiate_dfun tenv dfun_id pred loc - = -- tenv is a substitution that instantiates the dfun_id + -- tenv is a substitution that instantiates the dfun_id -- to match the requested result type. -- -- We ASSUME that the dfun is quantified over the very same tyvars @@ -717,27 +699,19 @@ instantiate_dfun tenv dfun_id pred loc -- dfun :: forall a b. C a b, Ord b => D [a] -- We instantiate b to a flexi type variable -- it'll presumably -- become fixed later via functional dependencies - traceTc (text "lookupInst success" <+> - vcat [text "dict" <+> ppr pred, - text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_` - -- Record that this dfun is needed - record_dfun_usage dfun_id `thenM_` - - getStage `thenM` \ use_stage -> - checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) - (topIdLvl dfun_id) use_stage `thenM_` + { use_stage <- getStage + ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) + (topIdLvl dfun_id) use_stage -- It's possible that not all the tyvars are in -- the substitution, tenv. For example: -- instance C X a => D X where ... -- (presumably there's a functional dependency in class C) -- Hence the open_tvs to instantiate any un-substituted tyvars. - let - (tyvars, rho) = tcSplitForAllTys (idType dfun_id) - open_tvs = filter (`notElemTvSubst` tenv) tyvars - in - mappM tcInstTyVar open_tvs `thenM` \ open_tvs' -> - let + ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id) + open_tvs = filter (`notElemTvSubst` tenv) tyvars + ; open_tvs' <- mappM tcInstTyVar open_tvs + ; let tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs') -- Since the open_tvs' are freshly made, they cannot possibly be captured by -- any nested for-alls in rho. So the in-scope set is unchanged @@ -745,25 +719,57 @@ instantiate_dfun tenv dfun_id pred loc (theta, _) = tcSplitPhiTy dfun_rho ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) (map (substTyVar tenv') tyvars) - in - if null theta then + ; if null theta then returnM (SimpleInst ty_app) - else - newDictsAtLoc loc theta `thenM` \ dicts -> - let - rhs = mkHsDictApp ty_app (map instToId dicts) - in - returnM (GenInst dicts rhs) - -record_dfun_usage dfun_id = do - dflags <- getDOpts - let dfun_name = idName dfun_id - dfun_mod = nameModule dfun_name - if isInternalName dfun_name || not (isHomeModule dflags dfun_mod) - then return () -- internal, or in another package - else do tcg_env <- getGblEnv - updMutVar (tcg_inst_uses tcg_env) - (`addOneToNameSet` idName dfun_id) + else do + { dicts <- newDictsAtLoc loc theta + ; let rhs = mkHsDictApp ty_app (map instToId dicts) + ; returnM (GenInst dicts rhs) + }}}} + +--------------- +lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId)) +-- Look up a class constraint in the instance environment +lookupPred pred@(ClassP clas tys) + = do { pkg_ie <- loadImportedInsts clas tys + -- Suck in any instance decls that may be relevant + ; tcg_env <- getGblEnv + ; dflags <- getDOpts + ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of { + ([(tenv, (_,_,dfun_id))], []) + -> do { traceTc (text "lookupInst success" <+> + vcat [text "dict" <+> ppr pred, + text "witness" <+> ppr dfun_id + <+> ppr (idType dfun_id) ]) + -- Record that this dfun is needed + ; record_dfun_usage dfun_id + ; return (Just (tenv, dfun_id)) } ; + + (matches, unifs) + -> do { traceTc (text "lookupInst fail" <+> + vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches, + text "unifs" <+> ppr unifs]) + -- In the case of overlap (multiple matches) we report + -- NoInstance here. That has the effect of making the + -- context-simplifier return the dict as an irreducible one. + -- Then it'll be given to addNoInstanceErrs, which will do another + -- lookupInstEnv to get the detailed info about what went wrong. + ; return Nothing } + }} + +lookupPred ip_pred = return Nothing + +record_dfun_usage dfun_id + = do { dflags <- getDOpts + ; let dfun_name = idName dfun_id + dfun_mod = nameModule dfun_name + ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod) + then return () -- internal, or in another package + else do { tcg_env <- getGblEnv + ; updMutVar (tcg_inst_uses tcg_env) + (`addOneToNameSet` idName dfun_id) }} + tcGetInstEnvs :: TcM (InstEnv, InstEnv) -- Gets both the external-package inst-env diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index ff97a4b..c377261 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -26,7 +26,7 @@ import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv, ) import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) -import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) +import TcSimplify ( tcSimplifyCheck, tcSimplifySuperClasses ) import Type ( zipOpenTvSubst, substTheta, substTys ) import DataCon ( classDataCon ) import Class ( classBigSig ) @@ -338,7 +338,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. - ------------------ -- Typecheck the methods let -- These insts are in scope; quite a few, eh? avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts @@ -348,10 +347,15 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) op_items binds `thenM` \ (meth_ids, meth_binds) -> -- Figure out bindings for the superclass context - tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts - `thenM` \ (sc_binds_inner, sc_binds_outer) -> - - -- It's possible that the superclass stuff might have done unification + -- Don't include this_dict in the 'givens', else + -- sc_dicts get bound by just selecting from this_dict!! + addErrCtxt superClassCtxt + (tcSimplifySuperClasses inst_tyvars' + dfun_arg_dicts + sc_dicts) `thenM` \ sc_binds -> + + -- It's possible that the superclass stuff might unified one + -- of the inst_tyavars' with something in the envt checkSigTyVars inst_tyvars' `thenM_` -- Deal with 'SPECIALISE instance' pragmas by making them @@ -411,7 +415,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas) dict_bind = noLoc (VarBind this_dict_id dict_rhs) - all_binds = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds) + all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds) main_bind = noLoc $ AbsBinds inst_tyvars' @@ -421,8 +425,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) in showLIE (text "instance") `thenM_` returnM (unitBag main_bind `unionBags` - prag_binds `unionBags` - sc_binds_outer) + prag_binds ) tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' @@ -515,65 +518,6 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars') \end{code} -Note: [Superclass loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We have to be very, very careful when generating superclasses, lest we -accidentally build a loop. Here's an example: - - class S a - - class S a => C a where { opc :: a -> a } - class S b => D b where { opd :: b -> b } - - instance C Int where - opc = opd - - instance D Int where - opd = opc - -From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int} -Simplifying, we may well get: - $dfCInt = :C ds1 (opd dd) - dd = $dfDInt - ds1 = $p1 dd -Notice that we spot that we can extract ds1 from dd. - -Alas! Alack! We can do the same for (instance D Int): - - $dfDInt = :D ds2 (opc dc) - dc = $dfCInt - ds2 = $p1 dc - -And now we've defined the superclass in terms of itself. - - -Solution: treat the superclass context separately, and simplify it -all the way down to nothing on its own. Don't toss any 'free' parts -out to be simplified together with other bits of context. -Hence the tcSimplifyTop below. - -At a more basic level, don't include this_dict in the context wrt -which we simplify sc_dicts, else sc_dicts get bound by just selecting -from this_dict!! - -\begin{code} -tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts - = addErrCtxt superClassCtxt $ - getLIE (tcSimplifyCheck doc inst_tyvars' - dfun_arg_dicts - sc_dicts) `thenM` \ (sc_binds1, sc_lie) -> - - -- We must simplify this all the way down - -- lest we build superclass loops - -- See Note [Superclass loops] above - tcSimplifyTop sc_lie `thenM` \ sc_binds2 -> - - returnM (sc_binds1, sc_binds2) - - where - doc = ptext SLIT("instance declaration superclass context") -\end{code} - ------------------------------ [Inline dfuns] Inlining dfuns unconditionally diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index e7cfee9..0a433ec 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -10,6 +10,7 @@ module TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs, + tcSimplifySuperClasses, tcSimplifyTop, tcSimplifyInteractive, tcSimplifyBracket, @@ -32,19 +33,19 @@ import Inst ( lookupInst, LookupInstResult(..), instToId, tyVarsOfInsts, cloneDict, ipNamesOfInsts, ipNamesOfInst, dictPred, instBindingRequired, fdPredsOfInst, - newDictsFromOld, tcInstClassOp, - getDictClassTys, isTyVarDict, - instLoc, zonkInst, tidyInsts, tidyMoreInsts, + newDictsAtLoc, tcInstClassOp, + getDictClassTys, isTyVarDict, instLoc, + zonkInst, tidyInsts, tidyMoreInsts, Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, isInheritableInst, pprDFuns, pprDictsTheta ) import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders ) import InstEnv ( lookupInstEnv, classInstances ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) -import TcType ( TcTyVar, TcTyVarSet, ThetaType, - mkClassPred, isOverloadedTy, mkTyConApp, +import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, + mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar, mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, - tyVarsOfPred, tcEqType, pprPred ) + tyVarsOfPred, tcEqType, pprPred, mkPredTy ) import Id ( idType, mkUserLocal ) import Var ( TyVar ) import Name ( Name, getOccName, getSrcLoc ) @@ -665,7 +666,7 @@ inferLoop doc tau_tvs wanteds try_me inst | isFreeWhenInferring qtvs inst = Free | isClassDict inst = DontReduceUnlessConstant -- Dicts - | otherwise = ReduceMe -- Lits and Methods + | otherwise = ReduceMe NoSCs -- Lits and Methods in traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_` @@ -778,12 +779,13 @@ tcSimplifyCheck -- global type variables in the environment; so you don't -- need to worry about setting them before calling tcSimplifyCheck tcSimplifyCheck doc qtvs givens wanted_lie - = tcSimplCheck doc get_qtvs - givens wanted_lie `thenM` \ (qtvs', binds) -> - returnM binds + = ASSERT( all isSkolemTyVar qtvs ) + do { (qtvs', frees, binds) <- tcSimplCheck doc get_qtvs AddSCs givens wanted_lie + ; extendLIEs frees + ; return binds } where --- get_qtvs = zonkTcTyVarsAndFV qtvs - get_qtvs = return (mkVarSet qtvs) +-- get_qtvs = zonkTcTyVarsAndFV qtvs + get_qtvs = return (mkVarSet qtvs) -- All skolems -- tcSimplifyInferCheck is used when we know the constraints we are to simplify @@ -798,7 +800,9 @@ tcSimplifyInferCheck TcDictBinds) -- Bindings tcSimplifyInferCheck doc tau_tvs givens wanted_lie - = tcSimplCheck doc get_qtvs givens wanted_lie + = do { (qtvs', frees, binds) <- tcSimplCheck doc get_qtvs AddSCs givens wanted_lie + ; extendLIEs frees + ; return (qtvs', binds) } where -- Figure out which type variables to quantify over -- You might think it should just be the signature tyvars, @@ -825,17 +829,16 @@ tcSimplifyInferCheck doc tau_tvs givens wanted_lie Here is the workhorse function for all three wrappers. \begin{code} -tcSimplCheck doc get_qtvs givens wanted_lie - = check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) -> +tcSimplCheck doc get_qtvs want_scs givens wanted_lie + = do { (qtvs, frees, binds, irreds) <- check_loop givens wanted_lie - -- Complain about any irreducible ones - mappM zonkInst given_dicts_and_ips `thenM` \ givens' -> - groupErrs (addNoInstanceErrs (Just doc) givens') irreds `thenM_` - - -- Done - extendLIEs frees `thenM_` - returnM (qtvs, binds) + -- Complain about any irreducible ones + ; if not (null irreds) + then do { givens' <- mappM zonkInst given_dicts_and_ips + ; groupErrs (addNoInstanceErrs (Just doc) givens') irreds } + else return () + ; returnM (qtvs, frees, binds) } where given_dicts_and_ips = filter (not . isMethod) givens -- For error reporting, filter out methods, which are @@ -854,7 +857,7 @@ tcSimplCheck doc get_qtvs givens wanted_lie -- When checking against a given signature we always reduce -- until we find a match against something given, or can't reduce try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free - | otherwise = ReduceMe + | otherwise = ReduceMe want_scs in reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> @@ -869,6 +872,62 @@ tcSimplCheck doc get_qtvs givens wanted_lie %************************************************************************ %* * + tcSimplifySuperClasses +%* * +%************************************************************************ + +Note [SUPERCLASS-LOOP 1] +~~~~~~~~~~~~~~~~~~~~~~~~ +We have to be very, very careful when generating superclasses, lest we +accidentally build a loop. Here's an example: + + class S a + + class S a => C a where { opc :: a -> a } + class S b => D b where { opd :: b -> b } + + instance C Int where + opc = opd + + instance D Int where + opd = opc + +From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int} +Simplifying, we may well get: + $dfCInt = :C ds1 (opd dd) + dd = $dfDInt + ds1 = $p1 dd +Notice that we spot that we can extract ds1 from dd. + +Alas! Alack! We can do the same for (instance D Int): + + $dfDInt = :D ds2 (opc dc) + dc = $dfCInt + ds2 = $p1 dc + +And now we've defined the superclass in terms of itself. + +Solution: never generate a superclass selectors at all when +satisfying the superclass context of an instance declaration. + +Two more nasty cases are in + tcrun021 + tcrun033 + +\begin{code} +tcSimplifySuperClasses qtvs givens sc_wanteds + = ASSERT( all isSkolemTyVar qtvs ) + do { (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds + ; binds2 <- tc_simplify_top doc False NoSCs frees + ; return (binds1 `unionBags` binds2) } + where + get_qtvs = return (mkVarSet qtvs) + doc = ptext SLIT("instance declaration superclass context") +\end{code} + + +%************************************************************************ +%* * \subsection{tcSimplifyRestricted} %* * %************************************************************************ @@ -1028,7 +1087,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds is_nested_group = isNotTopLevel top_lvl try_me inst | isFreeWrtTyVars qtvs inst, (is_nested_group || isDict inst) = Free - | otherwise = ReduceMe + | otherwise = ReduceMe AddSCs in reduceContextWithoutImprovement doc try_me wanteds' `thenM` \ (frees, binds, irreds) -> @@ -1086,7 +1145,7 @@ want to get forall dIntegralInt. fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int -because the scsel will mess up matching. Instead we want +because the scsel will mess up RULE matching. Instead we want forall dIntegralInt, dNumInt. fromIntegral Int Int dIntegralInt dNumInt = id Int @@ -1108,7 +1167,7 @@ tcSimplifyToDicts wanteds -- Reduce methods and lits only; stop as soon as we get a dictionary try_me inst | isDict inst = KeepDictWithoutSCs -- See notes above re "WithoutSCs" - | otherwise = ReduceMe + | otherwise = ReduceMe NoSCs \end{code} @@ -1164,7 +1223,7 @@ tcSimplifyIPs given_ips wanteds -- Simplify any methods that mention the implicit parameter try_me inst | isFreeWrtIPs ip_set inst = Free - | otherwise = ReduceMe + | otherwise = ReduceMe NoSCs simpl_loop givens wanteds = mappM zonkInst givens `thenM` \ givens' -> @@ -1236,7 +1295,7 @@ bindInstsOfLocalFuns wanteds local_ids overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them -- so it's worth building a set, so that -- lookup (in isMethodFor) is faster - try_me inst | isMethod inst = ReduceMe + try_me inst | isMethod inst = ReduceMe NoSCs | otherwise = Free \end{code} @@ -1251,7 +1310,7 @@ The main control over context reduction is here \begin{code} data WhatToDo - = ReduceMe -- Try to reduce this + = ReduceMe WantSCs -- Try to reduce this -- If there's no instance, behave exactly like -- DontReduce: add the inst to -- the irreductible ones, but don't @@ -1267,7 +1326,7 @@ data WhatToDo | Free -- Return as free reduceMe :: Inst -> WhatToDo -reduceMe inst = ReduceMe +reduceMe inst = ReduceMe AddSCs data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses -- of a predicate when adding it to the avails @@ -1682,12 +1741,12 @@ reduce stack try_me wanted avails -- First, see if the inst can be reduced to a constant in one step try_simple addFree - ; ReduceMe -> -- It should be reduced + ; ReduceMe want_scs -> -- It should be reduced lookupInst wanted `thenM` \ lookup_result -> case lookup_result of GenInst wanteds' rhs -> addIrred NoSCs avails wanted `thenM` \ avails1 -> reduceList stack try_me wanteds' avails1 `thenM` \ avails2 -> - addWanted avails2 wanted rhs wanteds' + addWanted want_scs avails2 wanted rhs wanteds' -- Experiment with temporarily doing addIrred *before* the reduceList, -- which has the effect of adding the thing we are trying -- to prove to the database before trying to prove the things it @@ -1697,17 +1756,17 @@ reduce stack try_me wanted avails -- the examples in [SUPERCLASS-LOOP] -- So we do an addIrred before, and then overwrite it afterwards with addWanted - SimpleInst rhs -> addWanted avails wanted rhs [] + SimpleInst rhs -> addWanted want_scs avails wanted rhs [] NoInstance -> -- No such instance! -- Add it and its superclasses - addIrred AddSCs avails wanted + addIrred want_scs avails wanted } where try_simple do_this_otherwise = lookupInst wanted `thenM` \ lookup_result -> case lookup_result of - SimpleInst rhs -> addWanted avails wanted rhs [] + SimpleInst rhs -> addWanted AddSCs avails wanted rhs [] other -> do_this_otherwise avails wanted \end{code} @@ -1762,32 +1821,35 @@ addFree :: Avails -> Inst -> TcM Avails -- addFree avails free = returnM (addToFM avails free IsFree) -addWanted :: Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails -addWanted avails wanted rhs_expr wanteds - = addAvailAndSCs avails wanted avail +addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails +addWanted want_scs avails wanted rhs_expr wanteds + = addAvailAndSCs want_scs avails wanted avail where avail | instBindingRequired wanted = Rhs rhs_expr wanteds | otherwise = ASSERT( null wanteds ) NoRhs addGiven :: Avails -> Inst -> TcM Avails -addGiven avails given = addAvailAndSCs avails given (Given (instToId given) False) +addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given) False) + -- Always add superclasses for 'givens' + -- -- No ASSERT( not (given `elemFM` avails) ) because in an instance -- decl for Ord t we can add both Ord t and Eq t as 'givens', -- so the assert isn't true addIrred :: WantSCs -> Avails -> Inst -> TcM Avails -addIrred NoSCs avails irred = returnM (addToFM avails irred Irred) -addIrred AddSCs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails ) - addAvailAndSCs avails irred Irred - -addAvailAndSCs :: Avails -> Inst -> Avail -> TcM Avails -addAvailAndSCs avails inst avail - | not (isClassDict inst) = returnM avails1 - | otherwise = traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) `thenM_` - addSCs is_loop avails1 inst +addIrred want_scs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails ) + addAvailAndSCs want_scs avails irred Irred + +addAvailAndSCs :: WantSCs -> Avails -> Inst -> Avail -> TcM Avails +addAvailAndSCs want_scs avails inst avail + | not (isClassDict inst) = return avails_with_inst + | NoSCs <- want_scs = return avails_with_inst + | otherwise = do { traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) + ; addSCs is_loop avails_with_inst inst } where - avails1 = addToFM avails inst avail - is_loop inst = any (`tcEqType` idType (instToId inst)) dep_tys + avails_with_inst = addToFM avails inst avail + + is_loop pred = any (`tcEqType` mkPredTy pred) dep_tys -- Note: this compares by *type*, not by Unique deps = findAllDeps (unitVarSet (instToId inst)) avail dep_tys = map idType (varSetElems deps) @@ -1809,38 +1871,37 @@ addAvailAndSCs avails inst avail so_far' = extendVarSet so_far kid_id -- Add the new kid to so_far kid_id = instToId kid -addSCs :: (Inst -> Bool) -> Avails -> Inst -> TcM Avails +addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails -- Add all the superclasses of the Inst to Avails -- The first param says "dont do this because the original thing -- depends on this one, so you'd build a loop" -- Invariant: the Inst is already in Avails. addSCs is_loop avails dict - = newDictsFromOld dict sc_theta' `thenM` \ sc_dicts -> - foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) + = do { sc_dicts <- newDictsAtLoc (instLoc dict) sc_theta' + ; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) } where (clas, tys) = getDictClassTys dict (tyvars, sc_theta, sc_sels, _) = classBigSig clas sc_theta' = substTheta (zipTopTvSubst tyvars tys) sc_theta - add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses - | add_me sc_dict = addSCs is_loop avails' sc_dict - | otherwise = returnM avails + add_sc avails (sc_dict, sc_sel) + | is_loop (dictPred sc_dict) = return avails -- See Note [SUPERCLASS-LOOP 2] + | is_given sc_dict = return avails + | otherwise = addSCs is_loop avails' sc_dict where sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict] avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict]) - add_me :: Inst -> Bool - add_me sc_dict - | is_loop sc_dict = False -- See Note [SUPERCLASS-LOOP] - | otherwise = case lookupFM avails sc_dict of - Just (Given _ _) -> False -- Given is cheaper than superclass selection - other -> True + is_given :: Inst -> Bool + is_given sc_dict = case lookupFM avails sc_dict of + Just (Given _ _) -> True -- Given is cheaper than superclass selection + other -> False \end{code} -Note [SUPERCLASS-LOOP]: Checking for loops -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have to be careful here. If we are *given* d1:Ord a, +Note [SUPERCLASS-LOOP 2] +~~~~~~~~~~~~~~~~~~~~~~~~ +But the above isn't enough. Suppose we are *given* d1:Ord a, and want to deduce (d2:C [a]) where class Ord a => C a where @@ -1938,44 +1999,51 @@ It's OK: the final zonking stage should zap y to (), which is fine. \begin{code} tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds -tcSimplifyTop wanteds = tc_simplify_top False {- Not interactive loop -} wanteds -tcSimplifyInteractive wanteds = tc_simplify_top True {- Interactive loop -} wanteds +tcSimplifyTop wanteds + = tc_simplify_top doc False {- Not interactive loop -} AddSCs wanteds + where + doc = text "tcSimplifyTop" +tcSimplifyInteractive wanteds + = tc_simplify_top doc True {- Interactive loop -} AddSCs wanteds + where + doc = text "tcSimplifyTop" -- The TcLclEnv should be valid here, solely to improve -- error message generation for the monomorphism restriction -tc_simplify_top is_interactive wanteds - = getLclEnv `thenM` \ lcl_env -> - traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) `thenM_` - simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) -> - ASSERT( null frees ) +tc_simplify_top doc is_interactive want_scs wanteds + = do { lcl_env <- getLclEnv + ; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) - let + ; let try_me inst = ReduceMe want_scs + ; (frees, binds, irreds) <- simpleReduceLoop doc try_me wanteds + + ; let -- All the non-std ones are definite errors - (stds, non_stds) = partition isStdClassTyVarDict irreds - - -- Group by type variable - std_groups = equivClasses cmp_by_tyvar stds - - -- Pick the ones which its worth trying to disambiguate - -- namely, the onese whose type variable isn't bound - -- up with one of the non-standard classes - (std_oks, std_bads) = partition worth_a_try std_groups - worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d) - non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds) - - -- Collect together all the bad guys - bad_guys = non_stds ++ concat std_bads - (non_ips, bad_ips) = partition isClassDict bad_guys - (ambigs, no_insts) = partition isTyVarDict non_ips - -- If the dict has no type constructors involved, it must be ambiguous, - -- except I suppose that another error with fundeps maybe should have - -- constrained those type variables - in + (stds, non_stds) = partition isStdClassTyVarDict irreds + + -- Group by type variable + std_groups = equivClasses cmp_by_tyvar stds + + -- Pick the ones which its worth trying to disambiguate + -- namely, the onese whose type variable isn't bound + -- up with one of the non-standard classes + (std_oks, std_bads) = partition worth_a_try std_groups + worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d) + non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds) + + -- Collect together all the bad guys + bad_guys = non_stds ++ concat std_bads + (non_ips, bad_ips) = partition isClassDict bad_guys + (ambigs, no_insts) = partition isTyVarDict non_ips + -- If the dict has no type constructors involved, it must be ambiguous, + -- except I suppose that another error with fundeps maybe should have + -- constrained those type variables -- Report definite errors - groupErrs (addNoInstanceErrs Nothing []) no_insts `thenM_` - strangeTopIPErrs bad_ips `thenM_` + ; ASSERT( null frees ) + groupErrs (addNoInstanceErrs Nothing []) no_insts + ; strangeTopIPErrs bad_ips -- Deal with ambiguity errors, but only if -- if there has not been an error so far: @@ -1989,21 +2057,19 @@ tc_simplify_top is_interactive wanteds -- dealing with the (Num a) context arising from f's definition; -- we try to unify a with Int (to default it), but find that it's -- already been unified with the rigid variable from g's type sig - ifErrsM (returnM []) ( - - -- Complain about the ones that don't fall under - -- the Haskell rules for disambiguation - -- This group includes both non-existent instances - -- e.g. Num (IO a) and Eq (Int -> Int) - -- and ambiguous dictionaries - -- e.g. Num a - addTopAmbigErrs ambigs `thenM_` + ; binds_ambig <- ifErrsM (returnM []) $ + do { -- Complain about the ones that don't fall under + -- the Haskell rules for disambiguation + -- This group includes both non-existent instances + -- e.g. Num (IO a) and Eq (Int -> Int) + -- and ambiguous dictionaries + -- e.g. Num a + addTopAmbigErrs ambigs - -- Disambiguate the ones that look feasible - mappM (disambigGroup is_interactive) std_oks - ) `thenM` \ binds_ambig -> + -- Disambiguate the ones that look feasible + ; mappM (disambigGroup is_interactive) std_oks } - returnM (binds `unionBags` unionManyBags binds_ambig) + ; return (binds `unionBags` unionManyBags binds_ambig) } ---------------------------------- d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 @@ -2098,7 +2164,7 @@ disambigGroup is_interactive dicts unifyTauTy default_ty (mkTyVarTy tyvar) `thenM_` -- and reduce the context, for real this time simpleReduceLoop (text "disambig" <+> ppr dicts) - reduceMe dicts `thenM` \ (frees, binds, ambigs) -> + reduceMe dicts `thenM` \ (frees, binds, ambigs) -> WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs ) warnDefault dicts default_ty `thenM_` returnM binds