X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=346fbd875d8a946eccd42256dd1b1c7d1951d910;hb=550bd53be2ca1241a46517187d64fb0d077aeda0;hp=94772a6d3642c4a7d7cd9ad698cc98d1f8dd68e5;hpb=5adfdfb259415ca99d67d3c8b9e5df68cb736326;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 94772a6..346fbd8 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -6,6 +6,13 @@ TcSimplify \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyRestricted, @@ -15,7 +22,9 @@ module TcSimplify ( tcSimplifyBracket, tcSimplifyCheckPat, tcSimplifyDeriv, tcSimplifyDefault, - bindInstsOfLocalFuns + bindInstsOfLocalFuns, + + misMatchMsg ) where #include "HsVersions.h" @@ -28,11 +37,12 @@ import Inst import TcEnv import InstEnv import TcGadt -import TcMType import TcType +import TcMType import TcIface +import TcTyFuns +import TypeRep import Var -import TyCon import Name import NameSet import Class @@ -45,11 +55,14 @@ import ErrUtils import BasicTypes import VarSet import VarEnv +import Module import FiniteMap import Bag import Outputable +import Maybes import ListSetOps import Util +import UniqSet import SrcLoc import DynFlags @@ -133,14 +146,9 @@ from. The Right Thing is to improve whenever the constraint set changes at all. Not hard in principle, but it'll take a bit of fiddling to do. - - - -------------------------------------- - Notes on quantification - -------------------------------------- - -Suppose we are about to do a generalisation step. -We have in our hand +Note [Choosing which variables to quantify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are about to do a generalisation step. We have in our hand G the environment T the type of the RHS @@ -163,11 +171,12 @@ Here are the things that *must* be true: (A) Q intersect fv(G) = EMPTY limits how big Q can be (B) Q superset fv(Cq union T) \ oclose(fv(G),C) limits how small Q can be -(A) says we can't quantify over a variable that's free in the -environment. (B) says we must quantify over all the truly free -variables in T, else we won't get a sufficiently general type. We do -not *need* to quantify over any variable that is fixed by the free -vars of the environment G. + (A) says we can't quantify over a variable that's free in the environment. + (B) says we must quantify over all the truly free variables in T, else + we won't get a sufficiently general type. + +We do not *need* to quantify over any variable that is fixed by the +free vars of the environment G. BETWEEN THESE TWO BOUNDS, ANY Q WILL DO! @@ -181,38 +190,15 @@ Example: class H x y | x->y where ... So Q can be {c,d}, {b,c,d} +In particular, it's perfectly OK to quantify over more type variables +than strictly necessary; there is no need to quantify over 'b', since +it is determined by 'a' which is free in the envt, but it's perfectly +OK to do so. However we must not quantify over 'a' itself. + Other things being equal, however, we'd like to quantify over as few variables as possible: smaller types, fewer type applications, more -constraints can get into Ct instead of Cq. - - ------------------------------------------ -We will make use of - - fv(T) the free type vars of T - - oclose(vs,C) The result of extending the set of tyvars vs - using the functional dependencies from C - - grow(vs,C) The result of extend the set of tyvars vs - using all conceivable links from C. - - E.g. vs = {a}, C = {H [a] b, K (b,Int) c, Eq e} - Then grow(vs,C) = {a,b,c} - - Note that grow(vs,C) `superset` grow(vs,simplify(C)) - That is, simplfication can only shrink the result of grow. - -Notice that - oclose is conservative one way: v `elem` oclose(vs,C) => v is definitely fixed by vs - grow is conservative the other way: if v might be fixed by vs => v `elem` grow(vs,C) - - ------------------------------------------ - -Choosing Q -~~~~~~~~~~ -Here's a good way to choose Q: +constraints can get into Ct instead of Cq. Here's a good way to +choose Q: Q = grow( fv(T), C ) \ oclose( fv(G), C ) @@ -246,9 +232,8 @@ all the functional dependencies yet: T = c->c C = (Eq (T c d)) - Now oclose(fv(T),C) = {c}, because the functional dependency isn't - apparent yet, and that's wrong. We must really quantify over d too. - +Now oclose(fv(T),C) = {c}, because the functional dependency isn't +apparent yet, and that's wrong. We must really quantify over d too. There really isn't any point in quantifying over any more than grow( fv(T), C ), because the call sites can't possibly influence @@ -398,8 +383,8 @@ When m is later unified with [], we can solve both constraints. Notes on implicit parameters -------------------------------------- -Question 1: can we "inherit" implicit parameters -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Inheriting implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: f x = (x::Int) + ?y @@ -424,6 +409,26 @@ BOTTOM LINE: when *inferring types* you *must* quantify over implicit parameters. See the predicate isFreeWhenInferring. +Note [Implicit parameters and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only a *class* predicate can give rise to ambiguity +An *implicit parameter* cannot. For example: + foo :: (?x :: [a]) => Int + foo = length ?x +is fine. The call site will suppply a particular 'x' + +Furthermore, the type variables fixed by an implicit parameter +propagate to the others. E.g. + foo :: (Show a, ?x::[a]) => Int + foo = show (?x++?x) +The type of foo looks ambiguous. But it isn't, because at a call site +we might have + let ?x = 5::Int in foo +and all is well. In effect, implicit parameters are, well, parameters, +so we can take their type variables into account as part of the +"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. + + Question 2: type signatures ~~~~~~~~~~~~~~~~~~~~~~~~~~~ BUT WATCH OUT: When you supply a type signature, we can't force you @@ -642,83 +647,210 @@ tcSimplifyInfer :: SDoc -> TcTyVarSet -- fv(T); type vars -> [Inst] -- Wanted - -> TcM ([TcTyVar], -- Tyvars to quantify (zonked) - TcDictBinds, -- Bindings - [TcId]) -- Dict Ids that must be bound here (zonked) + -> TcM ([TcTyVar], -- Tyvars to quantify (zonked and quantified) + [Inst], -- Dict Ids that must be bound here (zonked) + TcDictBinds) -- Bindings -- Any free (escaping) Insts are tossed into the environment \end{code} \begin{code} -tcSimplifyInfer doc tau_tvs wanted_lie - = inferLoop doc (varSetElems tau_tvs) - wanted_lie `thenM` \ (qtvs, frees, binds, irreds) -> - - extendLIEs frees `thenM_` - returnM (qtvs, binds, map instToId irreds) - -inferLoop doc tau_tvs wanteds - = -- Step 1 - zonkTcTyVarsAndFV tau_tvs `thenM` \ tau_tvs' -> - mappM zonkInst wanteds `thenM` \ wanteds' -> - tcGetGlobalTyVars `thenM` \ gbl_tvs -> - let - preds = fdPredsOfInsts wanteds' - qtvs = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs - - try_me inst - | isFreeWhenInferring qtvs inst = Free - | isClassDict inst = Irred -- Dicts - | otherwise = ReduceMe NoSCs -- Lits and Methods - env = mkRedEnv doc try_me [] - in - traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, - ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_` - -- Step 2 - reduceContext env wanteds' `thenM` \ (improved, frees, binds, irreds) -> - - -- Step 3 - if not improved then - returnM (varSetElems qtvs, frees, binds, irreds) - else - -- If improvement did some unification, we go round again. There - -- are two subtleties: - -- a) We start again with irreds, not wanteds - -- Using an instance decl might have introduced a fresh type variable - -- which might have been unified, so we'd get an infinite loop - -- if we started again with wanteds! See example [LOOP] - -- - -- b) It's also essential to re-process frees, because unification - -- might mean that a type variable that looked free isn't now. - -- - -- Hence the (irreds ++ frees) - - -- However, NOTICE that when we are done, we might have some bindings, but - -- the final qtvs might be empty. See [NO TYVARS] below. - - inferLoop doc tau_tvs (irreds ++ frees) `thenM` \ (qtvs1, frees1, binds1, irreds1) -> - returnM (qtvs1, frees1, binds `unionBags` binds1, irreds1) +tcSimplifyInfer doc tau_tvs wanted + = do { tau_tvs1 <- zonkTcTyVarsAndFV (varSetElems tau_tvs) + ; wanted' <- mapM zonkInst wanted -- Zonk before deciding quantified tyvars + ; gbl_tvs <- tcGetGlobalTyVars + ; let preds1 = fdPredsOfInsts wanted' + gbl_tvs1 = oclose preds1 gbl_tvs + qtvs = grow preds1 tau_tvs1 `minusVarSet` gbl_tvs1 + -- See Note [Choosing which variables to quantify] + + -- To maximise sharing, remove from consideration any + -- constraints that don't mention qtvs at all + ; let (free, bound) = partition (isFreeWhenInferring qtvs) wanted' + ; extendLIEs free + + -- To make types simple, reduce as much as possible + ; traceTc (text "infer" <+> (ppr preds1 $$ ppr (grow preds1 tau_tvs1) $$ ppr gbl_tvs $$ + ppr gbl_tvs1 $$ ppr free $$ ppr bound)) + ; (irreds1, binds1) <- tryHardCheckLoop doc bound + + -- Note [Inference and implication constraints] + ; let want_dict d = tyVarsOfInst d `intersectsVarSet` qtvs + ; (irreds2, binds2) <- approximateImplications doc want_dict irreds1 + + -- Now work out all over again which type variables to quantify, + -- exactly in the same way as before, but starting from irreds2. Why? + -- a) By now improvment may have taken place, and we must *not* + -- quantify over any variable free in the environment + -- tc137 (function h inside g) is an example + -- + -- b) Do not quantify over constraints that *now* do not + -- mention quantified type variables, because they are + -- simply ambiguous (or might be bound further out). Example: + -- f :: Eq b => a -> (a, b) + -- g x = fst (f x) + -- From the RHS of g we get the MethodInst f77 :: alpha -> (alpha, beta) + -- We decide to quantify over 'alpha' alone, but free1 does not include f77 + -- because f77 mentions 'alpha'. Then reducing leaves only the (ambiguous) + -- constraint (Eq beta), which we dump back into the free set + -- See test tcfail181 + -- + -- c) irreds may contain type variables not previously mentioned, + -- e.g. instance D a x => Foo [a] + -- wanteds = Foo [a] + -- Then after simplifying we'll get (D a x), and x is fresh + -- We must quantify over x else it'll be totally unbound + ; tau_tvs2 <- zonkTcTyVarsAndFV (varSetElems tau_tvs1) + ; gbl_tvs2 <- zonkTcTyVarsAndFV (varSetElems gbl_tvs1) + -- Note that we start from gbl_tvs1 + -- We use tcGetGlobalTyVars, then oclose wrt preds2, because + -- we've already put some of the original preds1 into frees + -- E.g. wanteds = C a b (where a->b) + -- gbl_tvs = {a} + -- tau_tvs = {b} + -- Then b is fixed by gbl_tvs, so (C a b) will be in free, and + -- irreds2 will be empty. But we don't want to generalise over b! + ; let preds2 = fdPredsOfInsts irreds2 -- irreds2 is zonked + qtvs = grow preds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2 + ; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2 + ; extendLIEs free + + -- Turn the quantified meta-type variables into real type variables + ; qtvs2 <- zonkQuantifiedTyVars (varSetElems qtvs) + + -- We can't abstract over any remaining unsolved + -- implications so instead just float them outwards. Ugh. + ; let (q_dicts0, implics) = partition isAbstractableInst irreds3 + ; loc <- getInstLoc (ImplicOrigin doc) + ; implic_bind <- bindIrreds loc qtvs2 q_dicts0 implics + + -- Prepare equality instances for quantification + ; let (q_eqs0,q_dicts) = partition isEqInst q_dicts0 + ; q_eqs <- mapM finalizeEqInst q_eqs0 + + ; return (qtvs2, q_eqs ++ q_dicts, binds1 `unionBags` binds2 `unionBags` implic_bind) } + -- NB: when we are done, we might have some bindings, but + -- the final qtvs might be empty. See Note [NO TYVARS] below. + +approximateImplications :: SDoc -> (Inst -> Bool) -> [Inst] -> TcM ([Inst], TcDictBinds) +-- Note [Inference and implication constraints] +-- Given a bunch of Dict and ImplicInsts, try to approximate the implications by +-- - fetching any dicts inside them that are free +-- - using those dicts as cruder constraints, to solve the implications +-- - returning the extra ones too + +approximateImplications doc want_dict irreds + | null extra_dicts + = return (irreds, emptyBag) + | otherwise + = do { extra_dicts' <- mapM cloneDict extra_dicts + ; tryHardCheckLoop doc (extra_dicts' ++ irreds) } + -- By adding extra_dicts', we make them + -- available to solve the implication constraints + where + extra_dicts = get_dicts (filter isImplicInst irreds) + + get_dicts :: [Inst] -> [Inst] -- Returns only Dicts + -- Find the wanted constraints in implication constraints that satisfy + -- want_dict, and are not bound by forall's in the constraint itself + get_dicts ds = concatMap get_dict ds + + get_dict d@(Dict {}) | want_dict d = [d] + | otherwise = [] + get_dict (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds}) + = [ d | let tv_set = mkVarSet tvs + , d <- get_dicts wanteds + , not (tyVarsOfInst d `intersectsVarSet` tv_set)] + get_dict i@(EqInst {}) | want_dict i = [i] + | otherwise = [] + get_dict other = pprPanic "approximateImplications" (ppr other) \end{code} -Example [LOOP] +Note [Inference and implication constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a wanted implication constraint (perhaps arising from +a nested pattern match) like + C a => D [a] +and we are now trying to quantify over 'a' when inferring the type for +a function. In principle it's possible that there might be an instance + instance (C a, E a) => D [a] +so the context (E a) would suffice. The Right Thing is to abstract over +the implication constraint, but we don't do that (a) because it'll be +surprising to programmers and (b) because we don't have the machinery to deal +with 'given' implications. + +So our best approximation is to make (D [a]) part of the inferred +context, so we can use that to discharge the implication. Hence +the strange function get_dicts in approximateImplications. + +The common cases are more clear-cut, when we have things like + forall a. C a => C b +Here, abstracting over (C b) is not an approximation at all -- but see +Note [Freeness and implications]. + +See Trac #1430 and test tc228. - class If b t e r | b t e -> r - instance If T t e t - instance If F t e e - class Lte a b c | a b -> c where lte :: a -> b -> c - instance Lte Z b T - instance (Lte a b l,If l b a c) => Max a b c -Wanted: Max Z (S x) y +\begin{code} +----------------------------------------------------------- +-- tcSimplifyInferCheck is used when we know the constraints we are to simplify +-- against, but we don't know the type variables over which we are going to quantify. +-- This happens when we have a type signature for a mutually recursive group +tcSimplifyInferCheck + :: InstLoc + -> TcTyVarSet -- fv(T) + -> [Inst] -- Given + -> [Inst] -- Wanted + -> TcM ([TyVar], -- Fully zonked, and quantified + TcDictBinds) -- Bindings -Then we'll reduce using the Max instance to: - (Lte Z (S x) l, If l (S x) Z y) -and improve by binding l->T, after which we can do some reduction -on both the Lte and If constraints. What we *can't* do is start again -with (Max Z (S x) y)! +tcSimplifyInferCheck loc tau_tvs givens wanteds + = do { traceTc (text "tcSimplifyInferCheck <-" <+> ppr wanteds) + ; (irreds, binds) <- gentleCheckLoop loc givens wanteds + + -- Figure out which type variables to quantify over + -- You might think it should just be the signature tyvars, + -- but in bizarre cases you can get extra ones + -- f :: forall a. Num a => a -> a + -- f x = fst (g (x, head [])) + 1 + -- g a b = (b,a) + -- Here we infer g :: forall a b. a -> b -> (b,a) + -- We don't want g to be monomorphic in b just because + -- f isn't quantified over b. + ; let all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens) + ; all_tvs <- zonkTcTyVarsAndFV all_tvs + ; gbl_tvs <- tcGetGlobalTyVars + ; let qtvs = varSetElems (all_tvs `minusVarSet` gbl_tvs) + -- We could close gbl_tvs, but its not necessary for + -- soundness, and it'll only affect which tyvars, not which + -- dictionaries, we quantify over + + ; qtvs' <- zonkQuantifiedTyVars qtvs -[NO TYVARS] + -- Now we are back to normal (c.f. tcSimplCheck) + ; implic_bind <- bindIrreds loc qtvs' givens irreds + + ; traceTc (text "tcSimplifyInferCheck ->" <+> ppr (implic_bind)) + ; return (qtvs', binds `unionBags` implic_bind) } +\end{code} +Note [Squashing methods] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful if you want to float methods more: + truncate :: forall a. RealFrac a => forall b. Integral b => a -> b +From an application (truncate f i) we get + t1 = truncate at f + t2 = t1 at i +If we have also have a second occurrence of truncate, we get + t3 = truncate at f + t4 = t3 at i +When simplifying with i,f free, we might still notice that +t1=t3; but alas, the binding for t2 (which mentions t1) +may continue to float out! + + +Note [NO TYVARS] +~~~~~~~~~~~~~~~~~ class Y a b | a -> b where y :: a -> X b @@ -743,9 +875,9 @@ The net effect of [NO TYVARS] \begin{code} isFreeWhenInferring :: TyVarSet -> Inst -> Bool isFreeWhenInferring qtvs inst - = isFreeWrtTyVars qtvs inst -- Constrains no quantified vars - && isInheritableInst inst -- And no implicit parameter involved - -- (see "Notes on implicit parameters") + = isFreeWrtTyVars qtvs inst -- Constrains no quantified vars + && isInheritableInst inst -- and no implicit parameter involved + -- see Note [Inheriting implicit parameters] {- No longer used (with implication constraints) isFreeWhenChecking :: TyVarSet -- Quantified tyvars @@ -780,10 +912,10 @@ tcSimplifyCheck :: InstLoc -> [Inst] -- Wanted -> TcM TcDictBinds -- Bindings tcSimplifyCheck loc qtvs givens wanteds - = ASSERT( all isSkolemTyVar qtvs ) - do { (binds, irreds) <- innerCheckLoop loc AddSCs givens wanteds - ; implic_bind <- bindIrreds loc [] emptyRefinement - qtvs givens irreds + = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs ) + do { traceTc (text "tcSimplifyCheck") + ; (irreds, binds) <- gentleCheckLoop loc givens wanteds + ; implic_bind <- bindIrreds loc qtvs givens irreds ; return (binds `unionBags` implic_bind) } ----------------------------------------------------------- @@ -795,26 +927,40 @@ tcSimplifyCheckPat :: InstLoc -> [Inst] -- Wanted -> TcM TcDictBinds -- Bindings tcSimplifyCheckPat loc co_vars reft qtvs givens wanteds - = ASSERT( all isSkolemTyVar qtvs ) - do { (binds, irreds) <- innerCheckLoop loc AddSCs givens wanteds - ; implic_bind <- bindIrreds loc co_vars reft - qtvs givens irreds + = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs ) + do { traceTc (text "tcSimplifyCheckPat") + ; (irreds, binds) <- gentleCheckLoop loc givens wanteds + ; implic_bind <- bindIrredsR loc qtvs co_vars reft + givens irreds ; return (binds `unionBags` implic_bind) } ----------------------------------------------------------- -bindIrreds :: InstLoc -> [CoVar] -> Refinement - -> [TcTyVar] -> [Inst] -> [Inst] - -> TcM TcDictBinds +bindIrreds :: InstLoc -> [TcTyVar] + -> [Inst] -> [Inst] + -> TcM TcDictBinds +bindIrreds loc qtvs givens irreds + = bindIrredsR loc qtvs [] emptyRefinement givens irreds + +bindIrredsR :: InstLoc -> [TcTyVar] -> [CoVar] + -> Refinement -> [Inst] -> [Inst] + -> TcM TcDictBinds -- Make a binding that binds 'irreds', by generating an implication -- constraint for them, *and* throwing the constraint into the LIE -bindIrreds loc co_vars reft qtvs givens irreds - = do { let givens' = filter isDict givens - -- The givens can include methods - - -- If there are no 'givens', then it's safe to +bindIrredsR loc qtvs co_vars reft givens irreds + | null irreds + = return emptyBag + | otherwise + = do { let givens' = filter isAbstractableInst givens + -- The givens can (redundantly) include methods + -- We want to retain both EqInsts and Dicts + -- There should be no implicadtion constraints + -- See Note [Pruning the givens in an implication constraint] + + -- If there are no 'givens' *and* the refinement is empty + -- (the refinement is like more givens), then it's safe to -- partition the 'wanteds' by their qtvs, thereby trimming irreds -- See Note [Freeness and implications] - ; irreds' <- if null givens' + ; irreds' <- if null givens' && isEmptyRefinement reft then do { let qtv_set = mkVarSet qtvs (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds @@ -824,7 +970,8 @@ bindIrreds loc co_vars reft qtvs givens irreds ; let all_tvs = qtvs ++ co_vars -- Abstract over all these ; (implics, bind) <- makeImplicationBind loc all_tvs reft givens' irreds' - -- This call does the real work + -- This call does the real work + -- If irreds' is empty, it does something sensible ; extendLIEs implics ; return bind } @@ -837,63 +984,88 @@ makeImplicationBind :: InstLoc -> [TcTyVar] -> Refinement -- The binding looks like -- (ir1, .., irn) = f qtvs givens -- where f is (evidence for) the new implication constraint +-- f :: forall qtvs. {reft} givens => (ir1, .., irn) +-- qtvs includes coercion variables -- -- This binding must line up the 'rhs' in reduceImplication makeImplicationBind loc all_tvs reft givens -- Guaranteed all Dicts + -- or EqInsts irreds | null irreds -- If there are no irreds, we are done = return ([], emptyBag) | otherwise -- Otherwise we must generate a binding = do { uniq <- newUnique ; span <- getSrcSpanM - ; let name = mkInternalName uniq (mkVarOcc "ic") (srcSpanStart span) + ; let (eq_givens, dict_givens) = partition isEqInst givens + eq_tyvar_cos = mkTyVarTys (varSetElems $ tyVarsOfTypes $ map eqInstType eq_givens) + -- Urgh! See line 2187 or thereabouts. I believe that all these + -- 'givens' must be a simple CoVar. This MUST be cleaned up. + + ; let name = mkInternalName uniq (mkVarOcc "ic") span implic_inst = ImplicInst { tci_name = name, tci_reft = reft, tci_tyvars = all_tvs, - tci_given = givens, + tci_given = (eq_givens ++ dict_givens), tci_wanted = irreds, tci_loc = loc } - - ; let n_irreds = length irreds - irred_ids = map instToId irreds - tup_ty = mkTupleTy Boxed n_irreds (map idType irred_ids) - pat = TuplePat (map nlVarPat irred_ids) Boxed tup_ty + ; let -- only create binder for dict_irreds + (eq_irreds, dict_irreds) = partition isEqInst irreds + n_dict_irreds = length dict_irreds + dict_irred_ids = map instToId dict_irreds + tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids) + pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty rhs = L span (mkHsWrap co (HsVar (instToId implic_inst))) - co = mkWpApps (map instToId givens) <.> mkWpTyApps (mkTyVarTys all_tvs) - bind | n_irreds==1 = VarBind (head irred_ids) rhs - | otherwise = PatBind { pat_lhs = L span pat, - pat_rhs = unguardedGRHSs rhs, - pat_rhs_ty = tup_ty, - bind_fvs = placeHolderNames } - ; -- pprTrace "Make implic inst" (ppr implic_inst) $ - return ([implic_inst], unitBag (L span bind)) } + co = mkWpApps (map instToId dict_givens) + <.> mkWpTyApps eq_tyvar_cos + <.> mkWpTyApps (mkTyVarTys all_tvs) + bind | [dict_irred_id] <- dict_irred_ids = VarBind dict_irred_id rhs + | otherwise = PatBind { pat_lhs = L span pat, + pat_rhs = unguardedGRHSs rhs, + pat_rhs_ty = tup_ty, + bind_fvs = placeHolderNames } + ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst + ; return ([implic_inst], unitBag (L span bind)) + } ----------------------------------------------------------- -topCheckLoop :: SDoc +tryHardCheckLoop :: SDoc -> [Inst] -- Wanted - -> TcM (TcDictBinds, - [Inst]) -- Irreducible + -> TcM ([Inst], TcDictBinds) -topCheckLoop doc wanteds - = checkLoop (mkRedEnv doc try_me []) wanteds +tryHardCheckLoop doc wanteds + = do { (irreds,binds) <- checkLoop (mkRedEnv doc try_me []) wanteds + ; return (irreds,binds) + } where try_me inst = ReduceMe AddSCs + -- Here's the try-hard bit ----------------------------------------------------------- -innerCheckLoop :: InstLoc -> WantSCs +gentleCheckLoop :: InstLoc -> [Inst] -- Given -> [Inst] -- Wanted - -> TcM (TcDictBinds, - [Inst]) -- Irreducible + -> TcM ([Inst], TcDictBinds) -innerCheckLoop inst_loc want_scs givens wanteds - = checkLoop env wanteds +gentleCheckLoop inst_loc givens wanteds + = do { (irreds,binds) <- checkLoop env wanteds + ; return (irreds,binds) + } where env = mkRedEnv (pprInstLoc inst_loc) try_me givens - try_me inst | isMethodOrLit inst = ReduceMe want_scs - | otherwise = Irred + try_me inst | isMethodOrLit inst = ReduceMe AddSCs + | otherwise = Stop -- When checking against a given signature -- we MUST be very gentle: Note [Check gently] + +gentleInferLoop :: SDoc -> [Inst] + -> TcM ([Inst], TcDictBinds) +gentleInferLoop doc wanteds + = do { (irreds, binds) <- checkLoop env wanteds + ; return (irreds, binds) } + where + env = mkRedEnv doc try_me [] + try_me inst | isMethodOrLit inst = ReduceMe AddSCs + | otherwise = Stop \end{code} Note [Check gently] @@ -917,73 +1089,90 @@ But we MUST NOT reduce (Show [a]) to (Show a), else the whole thing becomes insoluble. So we simplify gently (get rid of literals and methods only, plus common up equal things), deferring the real work until top level, when we solve the implication constraint -with topCheckLooop. +with tryHardCheckLooop. \begin{code} ----------------------------------------------------------- checkLoop :: RedEnv -> [Inst] -- Wanted - -> TcM (TcDictBinds, - [Inst]) -- Irreducible --- Precondition: the try_me never returns Free --- givens are completely rigid + -> TcM ([Inst], TcDictBinds) +-- Precondition: givens are completely rigid +-- Postcondition: returned Insts are zonked checkLoop env wanteds - = do { -- Givens are skolems, so no need to zonk them - wanteds' <- mappM zonkInst wanteds + = go env wanteds + where go env wanteds + = do { -- We do need to zonk the givens; cf Note [Zonking RedEnv] + ; env' <- zonkRedEnv env + ; wanteds' <- zonkInsts wanteds + + ; (improved, binds, irreds) <- reduceContext env' wanteds' - ; (improved, _frees, binds, irreds) <- reduceContext env wanteds' + ; if not improved then + return (irreds, binds) + else do + + -- If improvement did some unification, we go round again. + -- We start again with irreds, not wanteds + -- Using an instance decl might have introduced a fresh type variable + -- which might have been unified, so we'd get an infinite loop + -- if we started again with wanteds! See Note [LOOP] + { (irreds1, binds1) <- go env' irreds + ; return (irreds1, binds `unionBags` binds1) } } +\end{code} - ; ASSERT( null _frees ) +Note [Zonking RedEnv] +~~~~~~~~~~~~~~~~~~~~~ +It might appear as if the givens in RedEnv are always rigid, but that is not +necessarily the case for programs involving higher-rank types that have class +contexts constraining the higher-rank variables. An example from tc237 in the +testsuite is - if not improved then - return (binds, irreds) - else do + class Modular s a | s -> a - { (binds1, irreds1) <- checkLoop env irreds - ; return (binds `unionBags` binds1, irreds1) } } -\end{code} + wim :: forall a w. Integral a + => a -> (forall s. Modular s a => M s w) -> w + wim i k = error "urk" + test5 :: (Modular s a, Integral a) => M s a + test5 = error "urk" -\begin{code} ------------------------------------------------------------ --- tcSimplifyInferCheck is used when we know the constraints we are to simplify --- against, but we don't know the type variables over which we are going to quantify. --- This happens when we have a type signature for a mutually recursive group -tcSimplifyInferCheck - :: InstLoc - -> TcTyVarSet -- fv(T) - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM ([TcTyVar], -- Variables over which to quantify - TcDictBinds) -- Bindings + test4 = wim 4 test4' -tcSimplifyInferCheck loc tau_tvs givens wanteds - = do { (binds, irreds) <- innerCheckLoop loc AddSCs givens wanteds +Notice how the variable 'a' of (Modular s a) in the rank-2 type of wim is +quantified further outside. When type checking test4, we have to check +whether the signature of test5 is an instance of - -- Figure out which type variables to quantify over - -- You might think it should just be the signature tyvars, - -- but in bizarre cases you can get extra ones - -- f :: forall a. Num a => a -> a - -- f x = fst (g (x, head [])) + 1 - -- g a b = (b,a) - -- Here we infer g :: forall a b. a -> b -> (b,a) - -- We don't want g to be monomorphic in b just because - -- f isn't quantified over b. - ; let all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens) - ; all_tvs <- zonkTcTyVarsAndFV all_tvs - ; gbl_tvs <- tcGetGlobalTyVars - ; let qtvs = varSetElems (all_tvs `minusVarSet` gbl_tvs) - -- We could close gbl_tvs, but its not necessary for - -- soundness, and it'll only affect which tyvars, not which - -- dictionaries, we quantify over + (forall s. Modular s a => M s w) + +Consequently, we will get (Modular s t_a), where t_a is a TauTv into the +givens. + +Given the FD of Modular in this example, class improvement will instantiate +t_a to 'a', where 'a' is the skolem from test5's signatures (due to the +Modular s a predicate in that signature). If we don't zonk (Modular s t_a) in +the givens, we will get into a loop as improveOne uses the unification engine +TcGadt.tcUnifyTys, which doesn't know about mutable type variables. + + +Note [LOOP] +~~~~~~~~~~~ + class If b t e r | b t e -> r + instance If T t e t + instance If F t e e + class Lte a b c | a b -> c where lte :: a -> b -> c + instance Lte Z b T + instance (Lte a b l,If l b a c) => Max a b c + +Wanted: Max Z (S x) y + +Then we'll reduce using the Max instance to: + (Lte Z (S x) l, If l (S x) Z y) +and improve by binding l->T, after which we can do some reduction +on both the Lte and If constraints. What we *can't* do is start again +with (Max Z (S x) y)! - -- Now we are back to normal (c.f. tcSimplCheck) - ; implic_bind <- bindIrreds loc [] emptyRefinement - qtvs givens irreds - ; return (qtvs, binds `unionBags` implic_bind) } -\end{code} %************************************************************************ @@ -1037,14 +1226,15 @@ tcSimplifySuperClasses -> [Inst] -- Wanted -> TcM TcDictBinds tcSimplifySuperClasses loc givens sc_wanteds - = do { (binds1, irreds) <- checkLoop env sc_wanteds + = do { traceTc (text "tcSimplifySuperClasses") + ; (irreds,binds1) <- checkLoop env sc_wanteds ; let (tidy_env, tidy_irreds) = tidyInsts irreds ; reportNoInstances tidy_env (Just (loc, givens)) tidy_irreds ; return binds1 } where env = mkRedEnv (pprInstLoc loc) try_me givens try_me inst = ReduceMe NoSCs - -- Like topCheckLoop, but with NoSCs + -- Like tryHardCheckLoop, but with NoSCs \end{code} @@ -1156,7 +1346,7 @@ tcSimplifyRestricted -- Used for restricted binding groups -> [Name] -- Things bound in this group -> TcTyVarSet -- Free in the type of the RHSs -> [Inst] -- Free in the RHSs - -> TcM ([TcTyVar], -- Tyvars to quantify (zonked) + -> TcM ([TyVar], -- Tyvars to quantify (zonked and quantified) TcDictBinds) -- Bindings -- tcSimpifyRestricted returns no constraints to -- quantify over; by definition there are none. @@ -1164,7 +1354,8 @@ tcSimplifyRestricted -- Used for restricted binding groups tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- Zonk everything in sight - = mappM zonkInst wanteds `thenM` \ wanteds' -> + = do { traceTc (text "tcSimplifyRestricted") + ; wanteds' <- zonkInsts wanteds -- 'ReduceMe': Reduce as far as we can. Don't stop at -- dicts; the idea is to get rid of as many type @@ -1175,29 +1366,40 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- BUT do no improvement! See Plan D above -- HOWEVER, some unification may take place, if we instantiate -- a method Inst with an equality constraint - let env = mkNoImproveRedEnv doc (\i -> ReduceMe AddSCs) - in - reduceContext env wanteds' `thenM` \ (_imp, _frees, _binds, constrained_dicts) -> + ; let env = mkNoImproveRedEnv doc (\i -> ReduceMe AddSCs) + ; (_imp, _binds, constrained_dicts) <- reduceContext env wanteds' -- Next, figure out the tyvars we will quantify over - zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> - tcGetGlobalTyVars `thenM` \ gbl_tvs' -> - mappM zonkInst constrained_dicts `thenM` \ constrained_dicts' -> - let - constrained_tvs' = tyVarsOfInsts constrained_dicts' - qtvs' = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs') - `minusVarSet` constrained_tvs' - in - traceTc (text "tcSimplifyRestricted" <+> vcat [ - pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts', + ; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs) + ; gbl_tvs' <- tcGetGlobalTyVars + ; constrained_dicts' <- zonkInsts constrained_dicts + + ; let qtvs1 = tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs' + -- As in tcSimplifyInfer + + -- Do not quantify over constrained type variables: + -- this is the monomorphism restriction + constrained_tvs' = tyVarsOfInsts constrained_dicts' + qtvs = qtvs1 `minusVarSet` constrained_tvs' + pp_bndrs = pprWithCommas (quotes . ppr) bndrs + + -- Warn in the mono + ; warn_mono <- doptM Opt_WarnMonomorphism + ; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1)) + (vcat[ ptext SLIT("the Monomorphism Restriction applies to the binding") + <> plural bndrs <+> ptext SLIT("for") <+> pp_bndrs, + ptext SLIT("Consider giving a type signature for") <+> pp_bndrs]) + + ; traceTc (text "tcSimplifyRestricted" <+> vcat [ + pprInsts wanteds, pprInsts constrained_dicts', ppr _binds, - ppr constrained_tvs', ppr tau_tvs', ppr qtvs' ]) `thenM_` + ppr constrained_tvs', ppr tau_tvs', ppr qtvs ]) -- The first step may have squashed more methods than -- necessary, so try again, this time more gently, knowing the exact -- set of type variables to quantify over. -- - -- We quantify only over constraints that are captured by qtvs'; + -- We quantify only over constraints that are captured by qtvs; -- these will just be a subset of non-dicts. This in contrast -- to normal inference (using isFreeWhenInferring) in which we quantify over -- all *non-inheritable* constraints too. This implements choice @@ -1209,27 +1411,23 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- -- At top level, we *do* squash methods becuase we want to -- expose implicit parameters to the test that follows - let - is_nested_group = isNotTopLevel top_lvl - try_me inst | isFreeWrtTyVars qtvs' inst, - (is_nested_group || isDict inst) = Free - | otherwise = ReduceMe AddSCs - env = mkNoImproveRedEnv doc try_me - in - reduceContext env wanteds' `thenM` \ (_imp, frees, binds, irreds) -> - ASSERT( null irreds ) + ; let is_nested_group = isNotTopLevel top_lvl + try_me inst | isFreeWrtTyVars qtvs inst, + (is_nested_group || isDict inst) = Stop + | otherwise = ReduceMe AddSCs + env = mkNoImproveRedEnv doc try_me + ; (_imp, binds, irreds) <- reduceContext env wanteds' -- See "Notes on implicit parameters, Question 4: top level" - if is_nested_group then - extendLIEs frees `thenM_` - returnM (varSetElems qtvs', binds) - else - let - (non_ips, bad_ips) = partition isClassDict frees - in - addTopIPErrs bndrs bad_ips `thenM_` - extendLIEs non_ips `thenM_` - returnM (varSetElems qtvs', binds) + ; ASSERT( all (isFreeWrtTyVars qtvs) irreds ) -- None should be captured + if is_nested_group then + extendLIEs irreds + else do { let (bad_ips, non_ips) = partition isIPDict irreds + ; addTopIPErrs bndrs bad_ips + ; extendLIEs non_ips } + + ; qtvs' <- zonkQuantifiedTyVars (varSetElems qtvs) + ; return (qtvs', binds) } \end{code} @@ -1308,7 +1506,8 @@ tcSimplifyRuleLhs wanteds -- to fromInteger; this looks fragile to me ; lookup_result <- lookupSimpleInst w' ; case lookup_result of - GenInst ws' rhs -> go dicts (addBind binds w rhs) (ws' ++ ws) + GenInst ws' rhs -> + go dicts (addInstToDictBind binds w rhs) (ws' ++ ws) NoInstance -> pprPanic "tcSimplifyRuleLhs" (ppr w) } \end{code} @@ -1323,7 +1522,7 @@ this bracket again at its usage site. \begin{code} tcSimplifyBracket :: [Inst] -> TcM () tcSimplifyBracket wanteds - = do { topCheckLoop doc wanteds + = do { tryHardCheckLoop doc wanteds ; return () } where doc = text "tcSimplifyBracket" @@ -1361,12 +1560,12 @@ tcSimplifyIPs :: [Inst] -- The implicit parameters bound here -- makes them the same. tcSimplifyIPs given_ips wanteds - = do { wanteds' <- mappM zonkInst wanteds - ; given_ips' <- mappM zonkInst given_ips + = do { wanteds' <- zonkInsts wanteds + ; given_ips' <- zonkInsts given_ips -- Unusually for checking, we *must* zonk the given_ips ; let env = mkRedEnv doc try_me given_ips' - ; (improved, _frees, binds, irreds) <- reduceContext env wanteds' + ; (improved, binds, irreds) <- reduceContext env wanteds' ; if not improved then ASSERT( all is_free irreds ) @@ -1380,7 +1579,7 @@ tcSimplifyIPs given_ips wanteds is_free inst = isFreeWrtIPs ip_set inst -- Simplify any methods that mention the implicit parameter - try_me inst | is_free inst = Irred + try_me inst | is_free inst = Stop | otherwise = ReduceMe NoSCs \end{code} @@ -1420,18 +1619,17 @@ bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcDictBinds -- arguably a bug in Match.tidyEqnInfo (see notes there) bindInstsOfLocalFuns wanteds local_ids - | null overloaded_ids + | null overloaded_ids = do -- Common case - = extendLIEs wanteds `thenM_` - returnM emptyLHsBinds + extendLIEs wanteds + return emptyLHsBinds | otherwise - = do { (binds, irreds) <- checkLoop env for_me + = do { (irreds, binds) <- gentleInferLoop doc for_me ; extendLIEs not_for_me ; extendLIEs irreds ; return binds } where - env = mkRedEnv doc try_me [] doc = text "bindInsts" <+> ppr local_ids overloaded_ids = filter is_overloaded local_ids is_overloaded id = isOverloadedTy (idType id) @@ -1440,8 +1638,6 @@ 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 NoSCs - | otherwise = Irred \end{code} @@ -1461,6 +1657,8 @@ data RedEnv , red_givens :: [Inst] -- All guaranteed rigid -- Always dicts -- but see Note [Rigidity] + , red_reft :: Refinement -- The refinement to apply to the 'givens' + -- You should think of it as 'given equalities' , red_stack :: (Int, [Inst]) -- Recursion stack (for err msg) -- See Note [RedStack] } @@ -1482,14 +1680,17 @@ data RedEnv mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv mkRedEnv doc try_me givens = RedEnv { red_doc = doc, red_try_me = try_me, - red_givens = givens, red_stack = (0,[]), + red_givens = givens, + red_reft = emptyRefinement, + red_stack = (0,[]), red_improve = True } mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv -- Do not do improvement; no givens mkNoImproveRedEnv doc try_me = RedEnv { red_doc = doc, red_try_me = try_me, - red_givens = [], red_stack = (0,[]), + red_givens = [], red_reft = emptyRefinement, + red_stack = (0,[]), red_improve = True } data WhatToDo @@ -1499,29 +1700,46 @@ data WhatToDo -- message of any kind. -- It might be quite legitimate such as (Eq a)! - | Irred -- Return as irreducible unless it can + | Stop -- Return as irreducible unless it can -- be reduced to a constant in one step - - | Free -- Return as free + -- Do not add superclasses; see data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses -- of a predicate when adding it to the avails -- The reason for this flag is entirely the super-class loop problem -- Note [SUPER-CLASS LOOP 1] + +zonkRedEnv :: RedEnv -> TcM RedEnv +zonkRedEnv env + = do { givens' <- mapM zonkInst (red_givens env) + ; return $ env {red_givens = givens'} + } \end{code} + %************************************************************************ %* * \subsection[reduce]{@reduce@} %* * %************************************************************************ +Note [Ancestor Equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +During context reduction, we add to the wanted equalities also those +equalities that (transitively) occur in superclass contexts of wanted +class constraints. Consider the following code + + class a ~ Int => C a + instance C Int + +If (C a) is wanted, we want to add (a ~ Int), which will be discharged by +substituting Int for a. Hence, we ultimately want (C Int), which we +discharge with the explicit instance. \begin{code} reduceContext :: RedEnv -> [Inst] -- Wanted -> TcM (ImprovementDone, - [Inst], -- Free TcDictBinds, -- Dictionary bindings [Inst]) -- Irreducible @@ -1534,28 +1752,124 @@ reduceContext env wanteds text "----------------------" ])) - -- Build the Avail mapping from "givens" - ; init_state <- foldlM addGiven emptyAvails (red_givens env) - - -- Do the real work - ; avails <- reduceList env wanteds init_state - ; let improved = availsImproved avails - ; (binds, irreds, frees) <- extractResults avails wanteds + ; let givens = red_givens env + (given_eqs0, given_dicts0) = partition isEqInst givens + (wanted_eqs0, wanted_non_eqs) = partition isEqInst wanteds + (wanted_implics0, wanted_dicts0) = partition isImplicInst wanted_non_eqs + + -- We want to add as wanted equalities those that (transitively) + -- occur in superclass contexts of wanted class constraints. + -- See Note [Ancestor Equalities] + ; ancestor_eqs <- ancestorEqualities wanted_dicts0 + ; let wanted_eqs = wanted_eqs0 ++ ancestor_eqs + ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs + + -- 1. Normalise the *given* *equality* constraints + ; (given_eqs, eliminate_skolems) <- normaliseGivenEqs given_eqs0 + + -- 2. Normalise the *given* *dictionary* constraints + -- wrt. the toplevel and given equations + ; (given_dicts, given_binds) <- normaliseGivenDicts given_eqs + given_dicts0 + + -- 5. Build the Avail mapping from "given_dicts" + -- Add dicts refined by the current type refinement + ; (init_state, extra_givens) <- getLIE $ do + { init_state <- foldlM addGiven emptyAvails given_dicts + ; let reft = red_reft env + ; if isEmptyRefinement reft then return init_state + else foldlM (addRefinedGiven reft) + init_state given_dicts } + + -- *** ToDo: what to do with the "extra_givens"? For the + -- moment I'm simply discarding them, which is probably wrong + + -- 7. Normalise the *wanted* *dictionary* constraints + -- wrt. the toplevel and given equations + -- NB: normalisation includes zonking as part of what it does + -- so it's important to do it after any unifications + -- that happened as a result of the addGivens + ; (wanted_dicts,normalise_binds1) <- normaliseWantedDicts given_eqs wanted_dicts0 + + -- 6. Solve the *wanted* *dictionary* constraints (not implications) + -- This may expose some further equational constraints... + ; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state) + ; (dict_binds, bound_dicts, dict_irreds) <- extractResults avails wanted_dicts + ; traceTc $ text "reduceContext extractresults" <+> vcat + [ppr avails,ppr wanted_dicts,ppr dict_binds] + + -- *** ToDo: what to do with the "extra_eqs"? For the + -- moment I'm simply discarding them, which is probably wrong + + -- Solve the wanted *implications*. In doing so, we can provide + -- as "given" all the dicts that were originally given, + -- *or* for which we now have bindings, + -- *or* which are now irreds + ; let implic_env = env { red_givens = givens ++ bound_dicts ++ dict_irreds } + ; (implic_binds_s, implic_irreds_s) <- mapAndUnzipM (reduceImplication implic_env) wanted_implics0 + ; let implic_binds = unionManyBags implic_binds_s + implic_irreds = concat implic_irreds_s + + -- 3. Solve the *wanted* *equation* constraints + ; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs + + -- 4. Normalise the *wanted* equality constraints with respect to + -- each other + ; eq_irreds <- normaliseWantedEqs eq_irreds0 + + -- 8. Substitute the wanted *equations* in the wanted *dictionaries* + ; let irreds = dict_irreds ++ implic_irreds + ; (norm_irreds, normalise_binds2) <- substEqInDictInsts True {-wanted-} + eq_irreds irreds + + -- 9. eliminate the artificial skolem constants introduced in 1. + ; eliminate_skolems + + -- Figure out whether we should go round again + -- My current plan is to see if any of the mutable tyvars in + -- givens or irreds has been filled in by improvement. + -- If so, there is merit in going around again, because + -- we may make further progress + -- + -- ToDo: is it only mutable stuff? We may have exposed new + -- equality constraints and should probably go round again + -- then as well. But currently we are dropping them on the + -- floor anyway. + + ; let all_irreds = norm_irreds ++ eq_irreds + ; improved <- anyM isFilledMetaTyVar $ varSetElems $ + tyVarsOfInsts (givens ++ all_irreds) + + -- The old plan (fragile) + -- improveed = availsImproved avails + -- || (not $ isEmptyBag normalise_binds1) + -- || (not $ isEmptyBag normalise_binds2) + -- || (any isEqInst irreds) ; traceTc (text "reduceContext end" <+> (vcat [ text "----------------------", red_doc env, - text "given" <+> ppr (red_givens env), + text "given" <+> ppr givens, + text "given_eqs" <+> ppr given_eqs, text "wanted" <+> ppr wanteds, + text "wanted_dicts" <+> ppr wanted_dicts, text "----", text "avails" <+> pprAvails avails, - text "frees" <+> ppr frees, text "improved =" <+> ppr improved, + text "(all) irreds = " <+> ppr all_irreds, + text "dict-binds = " <+> ppr dict_binds, + text "implic-binds = " <+> ppr implic_binds, text "----------------------" ])) - ; return (improved, frees, binds, irreds) } + ; return (improved, + given_binds `unionBags` normalise_binds1 + `unionBags` normalise_binds2 + `unionBags` dict_binds + `unionBags` implic_binds, + all_irreds) + } tcImproveOne :: Avails -> Inst -> TcM ImprovementDone tcImproveOne avails inst @@ -1579,13 +1893,13 @@ unifyEqns :: [(Equation,(PredType,SDoc),(PredType,SDoc))] unifyEqns [] = return False unifyEqns eqns = do { traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) - ; mappM_ unify eqns + ; mapM_ unify eqns ; return True } where unify ((qtvs, pairs), what1, what2) - = addErrCtxtM (mkEqnMsg what1 what2) $ - tcInstTyVars (varSetElems qtvs) `thenM` \ (_, _, tenv) -> - mapM_ (unif_pr tenv) pairs + = addErrCtxtM (mkEqnMsg what1 what2) $ do + (_, _, tenv) <- tcInstTyVars (varSetElems qtvs) + mapM_ (unif_pr tenv) pairs unif_pr tenv (ty1,ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2) pprEquationDoc (eqn, (p1,w1), (p2,w2)) = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)] @@ -1604,7 +1918,8 @@ The main context-reduction function is @reduce@. Here's its game plan. \begin{code} reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state - = do { dopts <- getDOpts + = do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state)) + ; dopts <- getDOpts #ifdef DEBUG ; if n > 8 then dumpTcRn (hang (ptext SLIT("Interesting! Context reduction stack depth") <+> int n) @@ -1624,35 +1939,37 @@ reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state reduce env wanted avails -- It's the same as an existing inst, or a superclass thereof | Just avail <- findAvail avails wanted - = returnM avails + = do { traceTc (text "reduce: found " <+> ppr wanted) + ; return avails + } | otherwise - = case red_try_me env wanted of { - Free -> try_simple addFree -- It's free so just chuck it upstairs - ; Irred -> try_simple (addIrred AddSCs) -- Assume want superclasses - - ; ReduceMe want_scs -> -- It should be reduced - reduceInst env avails wanted `thenM` \ (avails, lookup_result) -> - case lookup_result of - NoInstance -> -- No such instance! + = do { traceTc (text "reduce" <+> ppr wanted $$ ppr avails) + ; case red_try_me env wanted of { + Stop -> try_simple (addIrred NoSCs); + -- See Note [No superclasses for Stop] + + ReduceMe want_scs -> do -- It should be reduced + { (avails, lookup_result) <- reduceInst env avails wanted + ; case lookup_result of + NoInstance -> addIrred want_scs avails wanted -- Add it and its superclasses - addIrred want_scs avails wanted - - GenInst [] rhs -> addWanted want_scs avails wanted rhs [] + + GenInst [] rhs -> addWanted want_scs avails wanted rhs [] - GenInst wanteds' rhs -> do { avails1 <- addIrred NoSCs avails wanted - ; avails2 <- reduceList env wanteds' avails1 - ; addWanted want_scs avails2 wanted rhs wanteds' } + GenInst wanteds' rhs + -> do { avails1 <- addIrred NoSCs avails wanted + ; avails2 <- reduceList env wanteds' avails1 + ; addWanted want_scs avails2 wanted rhs wanteds' } } -- Temporarily do 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 -- needs. See note [RECURSIVE DICTIONARIES] -- NB: we must not do an addWanted before, because that adds the - -- superclasses too, and thaat can lead to a spurious loop; see + -- superclasses too, and that can lead to a spurious loop; see -- the examples in [SUPERCLASS-LOOP] -- So we do an addIrred before, and then overwrite it afterwards with addWanted - - } + } } where -- First, see if the inst can be reduced to a constant in one step -- Works well for literals (1::Int) and constant dictionaries (d::Num Int) @@ -1699,7 +2016,7 @@ At first I had a gross hack, whereby I simply did not add superclass constraints in addWanted, though I did for addGiven and addIrred. This was sub-optimal, becuase it lost legitimate superclass sharing, and it still didn't do the job: I found a very obscure program (now tcrun021) in which improvement meant the -simplifier got two bites a the cherry... so something seemed to be an Irred +simplifier got two bites a the cherry... so something seemed to be an Stop first time, but reducible next time. Now we implement the Right Solution, which is to check for loops directly @@ -1752,25 +2069,41 @@ contributing clauses. \begin{code} --------------------------------------------- reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult) -reduceInst env avails (ImplicInst { tci_tyvars = tvs, tci_reft = reft, tci_loc = loc, - tci_given = extra_givens, tci_wanted = wanteds }) - = reduceImplication env avails reft tvs extra_givens wanteds loc - reduceInst env avails other_inst = do { result <- lookupSimpleInst other_inst ; return (avails, result) } \end{code} +Note [Equational Constraints in Implication Constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +An implication constraint is of the form + Given => Wanted +where Given and Wanted may contain both equational and dictionary +constraints. The delay and reduction of these two kinds of constraints +is distinct: + +-) In the generated code, wanted Dictionary constraints are wrapped up in an + implication constraint that is created at the code site where the wanted + dictionaries can be reduced via a let-binding. This let-bound implication + constraint is deconstructed at the use-site of the wanted dictionaries. + +-) While the reduction of equational constraints is also delayed, the delay + is not manifest in the generated code. The required evidence is generated + in the code directly at the use-site. There is no let-binding and deconstruction + necessary. The main disadvantage is that we cannot exploit sharing as the + same evidence may be generated at multiple use-sites. However, this disadvantage + is limited because it only concerns coercions which are erased. + +The different treatment is motivated by the different in representation. Dictionary +constraints require manifest runtime dictionaries, while equations require coercions +which are types. + \begin{code} --------------------------------------------- reduceImplication :: RedEnv - -> Avails - -> Refinement -- May refine the givens; often empty - -> [TcTyVar] -- Quantified type variables; all skolems - -> [Inst] -- Extra givens; all rigid - -> [Inst] -- Wanted - -> InstLoc - -> TcM (Avails, LookupInstResult) + -> Inst + -> TcM (TcDictBinds, [Inst]) \end{code} Suppose we are simplifying the constraint @@ -1795,55 +2128,115 @@ Note that \begin{code} -- ToDo: should we instantiate tvs? I think it's not necessary -- - -- ToDo: what about improvement? There may be some improvement - -- exposed as a result of the simplifications done by reduceList - -- which are discarded if we back off. - -- This is almost certainly Wrong, but we'll fix it when dealing - -- better with equality constraints -reduceImplication env orig_avails reft tvs extra_givens wanteds inst_loc + -- Note on coercion variables: + -- + -- The extra given coercion variables are bound at two different sites: + -- -) in the creation context of the implication constraint + -- the solved equational constraints use these binders + -- + -- -) at the solving site of the implication constraint + -- the solved dictionaries use these binders + -- these binders are generated by reduceImplication + -- +reduceImplication env + orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc, + tci_tyvars = tvs, tci_reft = reft, + tci_given = extra_givens, tci_wanted = wanteds }) = do { -- Add refined givens, and the extra givens - (refined_red_givens, avails) - <- if isEmptyRefinement reft then return (red_givens env, orig_avails) - else foldlM (addRefinedGiven reft) ([], orig_avails) (red_givens env) - ; avails <- foldlM addGiven avails extra_givens + -- Todo fix this +-- (refined_red_givens,refined_avails) +-- <- if isEmptyRefinement reft then return (red_givens env,orig_avails) +-- else foldlM (addRefinedGiven reft) ([],orig_avails) (red_givens env) +-- Commented out SLPJ Sept 07; see comment with extractLocalResults below + let refined_red_givens = [] -- Solve the sub-problem ; let try_me inst = ReduceMe AddSCs -- Note [Freeness and implications] - env' = env { red_givens = refined_red_givens ++ extra_givens + env' = env { red_givens = extra_givens ++ red_givens env + , red_reft = reft + , red_doc = sep [ptext SLIT("reduceImplication for") <+> ppr name, + nest 2 (parens $ ptext SLIT("within") <+> red_doc env)] , red_try_me = try_me } ; traceTc (text "reduceImplication" <+> vcat - [ ppr (red_givens env), ppr extra_givens, ppr reft, ppr wanteds ]) - ; avails <- reduceList env' wanteds avails - - -- Extract the binding (no frees, because try_me never says Free) - ; (binds, irreds, _frees) <- extractResults avails wanteds - - -- We always discard the extra avails we've generated; - -- but we remember if we have done any (global) improvement - ; let ret_avails = updateImprovement orig_avails avails - - ; if isEmptyLHsBinds binds then -- No progress - return (ret_avails, NoInstance) + [ ppr (red_givens env), ppr extra_givens, + ppr reft, ppr wanteds]) + ; (irreds, binds) <- checkLoop env' wanteds + ; let (extra_eq_givens, extra_dict_givens) = partition isEqInst extra_givens + -- SLPJ Sept 07: I think this is bogus; currently + -- there are no Eqinsts in extra_givens + dict_ids = map instToId extra_dict_givens + + -- Note [Reducing implication constraints] + -- Tom -- update note, put somewhere! + + ; traceTc (text "reduceImplication result" <+> vcat + [ppr irreds, ppr binds]) + + ; -- extract superclass binds + -- (sc_binds,_) <- extractResults avails [] +-- ; traceTc (text "reduceImplication sc_binds" <+> vcat +-- [ppr sc_binds, ppr avails]) +-- + + -- SLPJ Sept 07: what if improvement happened inside the checkLoop? + -- Then we must iterate the outer loop too! + + ; traceTc (text "reduceImplication condition" <+> ppr ((isEmptyLHsBinds binds) || (null irreds))) + +-- Progress is no longer measered by the number of bindings + ; if (isEmptyLHsBinds binds) && (not $ null irreds) then -- No progress + -- If there are any irreds, we back off and do nothing + return (emptyBag, [orig_implic]) else do - { (implic_insts, bind) <- makeImplicationBind inst_loc tvs reft extra_givens irreds + { (simpler_implic_insts, bind) <- makeImplicationBind inst_loc tvs reft extra_givens irreds -- This binding is useless if the recursive simplification -- made no progress; but currently we don't try to optimise that -- case. After all, we only try hard to reduce at top level, or -- when inferring types. - ; let dict_ids = map instToId extra_givens - co = mkWpTyLams tvs <.> mkWpLams dict_ids <.> WpLet (binds `unionBags` bind) + ; let dict_wanteds = filter (not . isEqInst) wanteds + -- TOMDO: given equational constraints bug! + -- we need a different evidence for given + -- equations depending on whether we solve + -- dictionary constraints or equational constraints + + eq_tyvars = varSetElems $ tyVarsOfTypes $ map eqInstType extra_eq_givens + -- SLPJ Sept07: this looks Utterly Wrong to me, but I think + -- that current extra_givens has no EqInsts, so + -- it makes no difference + co = wrap_inline -- Note [Always inline implication constraints] + <.> mkWpTyLams tvs + <.> mkWpLams eq_tyvars + <.> mkWpLams dict_ids + <.> WpLet (binds `unionBags` bind) + wrap_inline | null dict_ids = idHsWrapper + | otherwise = WpInline rhs = mkHsWrap co payload loc = instLocSpan inst_loc - payload | isSingleton wanteds = HsVar (instToId (head wanteds)) - | otherwise = ExplicitTuple (map (L loc . HsVar . instToId) wanteds) Boxed + payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted) + | otherwise = ExplicitTuple (map (L loc . HsVar . instToId) dict_wanteds) Boxed - -- If there are any irreds, we back off and return NoInstance - ; return (ret_avails, GenInst implic_insts (L loc rhs)) - } } + + ; traceTc (vcat [text "reduceImplication" <+> ppr name, + ppr simpler_implic_insts, + text "->" <+> ppr rhs]) + ; return (unitBag (L loc (VarBind (instToId orig_implic) (L loc rhs))), + simpler_implic_insts) + } + } \end{code} +Note [Always inline implication constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose an implication constraint floats out of an INLINE function. +Then although the implication has a single call site, it won't be +inlined. And that is bad because it means that even if there is really +*no* overloading (type signatures specify the exact types) there will +still be dictionary passing in the resulting code. To avert this, +we mark the implication constraints themselves as INLINE, at least when +there is no loss of sharing as a result. + Note [Freeness and implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's hard to say when an implication constraint can be floated out. Consider @@ -1869,6 +2262,20 @@ We can satisfy the (C Int) from the superclass of D, so we don't want to float the (C Int) out, even though it mentions no type variable in the constraints! +Note [Pruning the givens in an implication constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are about to form the implication constraint + forall tvs. Eq a => Ord b +The (Eq a) cannot contribute to the (Ord b), because it has no access to +the type variable 'b'. So we could filter out the (Eq a) from the givens. + +Doing so would be a bit tidier, but all the implication constraints get +simplified away by the optimiser, so it's no great win. So I don't take +advantage of that at the moment. + +If you do, BE CAREFUL of wobbly type variables. + + %************************************************************************ %* * Avails and AvailHow: the pool of evidence @@ -1885,11 +2292,10 @@ type ImprovementDone = Bool -- True <=> some unification has happened type AvailEnv = FiniteMap Inst AvailHow data AvailHow - = IsFree -- Used for free Insts - | IsIrred -- Used for irreducible dictionaries, + = IsIrred -- Used for irreducible dictionaries, -- which are going to be lambda bound - | Given TcId -- Used for dictionaries for which we have a binding + | Given Inst -- Used for dictionaries for which we have a binding -- e.g. those "given" in a signature | Rhs -- Used when there is a RHS @@ -1901,18 +2307,19 @@ instance Outputable Avails where pprAvails (Avails imp avails) = vcat [ ptext SLIT("Avails") <> (if imp then ptext SLIT("[improved]") else empty) - , nest 2 (vcat [sep [ppr inst, nest 2 (equals <+> ppr avail)] - | (inst,avail) <- fmToList avails ])] + , nest 2 $ braces $ + vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)] + | (inst,avail) <- fmToList avails ]] instance Outputable AvailHow where ppr = pprAvail ------------------------- pprAvail :: AvailHow -> SDoc -pprAvail IsFree = text "Free" pprAvail IsIrred = text "Irred" pprAvail (Given x) = text "Given" <+> ppr x -pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs) +pprAvail (Rhs rhs bs) = sep [text "Rhs" <+> ppr bs, + nest 2 (ppr rhs)] ------------------------- extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv @@ -1935,7 +2342,7 @@ elemAvails wanted (Avails _ avails) = wanted `elemFM` avails extendAvails :: Avails -> Inst -> AvailHow -> TcM Avails -- Does improvement -extendAvails avails@(Avails imp env) inst avail +extendAvails avails@(Avails imp env) inst avail = do { imp1 <- tcImproveOne avails inst -- Do any improvement ; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) } @@ -1955,80 +2362,68 @@ We assume that they'll be wrapped in a big Rec, so that the dependency analyser can sort them out later \begin{code} +type DoneEnv = FiniteMap Inst [Id] +-- Tracks which things we have evidence for + extractResults :: Avails -> [Inst] -- Wanted - -> TcM ( TcDictBinds, -- Bindings - [Inst], -- Irreducible ones - [Inst]) -- Free ones + -> TcM (TcDictBinds, -- Bindings + [Inst], -- The insts bound by the bindings + [Inst]) -- Irreducible ones + -- Note [Reducing implication constraints] extractResults (Avails _ avails) wanteds - = go avails emptyBag [] [] wanteds + = go emptyBag [] [] emptyFM wanteds where - go :: AvailEnv -> TcDictBinds -> [Inst] -> [Inst] -> [Inst] + go :: TcDictBinds -- Bindings for dicts + -> [Inst] -- Bound by the bindings + -> [Inst] -- Irreds + -> DoneEnv -- Has an entry for each inst in the above three sets + -> [Inst] -- Wanted -> TcM (TcDictBinds, [Inst], [Inst]) - go avails binds irreds frees [] - = returnM (binds, irreds, frees) - - go avails binds irreds frees (w:ws) + go binds bound_dicts irreds done [] + = return (binds, bound_dicts, irreds) + + go binds bound_dicts irreds done (w:ws) + | Just done_ids@(done_id : rest_done_ids) <- lookupFM done w + = if w_id `elem` done_ids then + go binds bound_dicts irreds done ws + else + go (add_bind (nlHsVar done_id)) bound_dicts irreds + (addToFM done w (done_id : w_id : rest_done_ids)) ws + + | otherwise -- Not yet done = case findAvailEnv avails w of - Nothing -> pprTrace "Urk: extractResults" (ppr w) $ - go avails binds irreds frees ws - - Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws - Just IsIrred -> go (add_given avails w) binds (w:irreds) frees ws - - Just (Given id) -> go avails new_binds irreds frees ws - where - new_binds | id == instToId w = binds - | otherwise = addBind binds w (L (instSpan w) (HsVar id)) - -- The sought Id can be one of the givens, via a superclass chain - -- and then we definitely don't want to generate an x=x binding! - - Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws) - where - new_binds = addBind binds w rhs - - add_given avails w = extendAvailEnv avails w (Given (instToId w)) - - add_free avails w | isMethod w = avails - | otherwise = add_given avails w - -- NB: Hack alert! - -- Do *not* replace Free by Given if it's a method. - -- The following situation shows why this is bad: - -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b - -- From an application (truncate f i) we get - -- t1 = truncate at f - -- t2 = t1 at i - -- If we have also have a second occurrence of truncate, we get - -- t3 = truncate at f - -- t4 = t3 at i - -- When simplifying with i,f free, we might still notice that - -- t1=t3; but alas, the binding for t2 (which mentions t1) - -- will continue to float out! - -addBind binds inst rhs = binds `unionBags` unitBag (L (instSpan inst) - (VarBind (instToId inst) rhs)) -instSpan wanted = instLocSpan (instLoc wanted) + Nothing -> pprTrace "Urk: extractResults" (ppr w) $ + go binds bound_dicts irreds done ws + + Just IsIrred -> go binds bound_dicts (w:irreds) done' ws + + Just (Rhs rhs ws') -> go (add_bind rhs) (w:bound_dicts) irreds done' (ws' ++ ws) + + Just (Given g) -> go binds' bound_dicts irreds (addToFM done w [g_id]) ws + where + g_id = instToId g + binds' | w_id == g_id = binds + | otherwise = add_bind (nlHsVar g_id) + where + w_id = instToId w + done' = addToFM done w [w_id] + add_bind rhs = addInstToDictBind binds w rhs \end{code} -\begin{code} -------------------------- -addFree :: Avails -> Inst -> TcM Avails - -- When an Inst is tossed upstairs as 'free' we nevertheless add it - -- to avails, so that any other equal Insts will be commoned up right - -- here rather than also being tossed upstairs. This is really just - -- an optimisation, and perhaps it is more trouble that it is worth, - -- as the following comments show! - -- - -- NB: do *not* add superclasses. If we have - -- df::Floating a - -- dn::Num a - -- but a is not bound here, then we *don't* want to derive - -- dn from df here lest we lose sharing. - -- -addFree avails free = extendAvails avails free IsFree +Note [No superclasses for Stop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we decide not to reduce an Inst -- the 'WhatToDo' --- we still +add it to avails, so that any other equal Insts will be commoned up +right here. However, we do *not* add superclasses. If we have + df::Floating a + dn::Num a +but a is not bound here, then we *don't* want to derive dn from df +here lest we lose sharing. +\begin{code} addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails addWanted want_scs avails wanted rhs_expr wanteds = addAvailAndSCs want_scs avails wanted avail @@ -2036,29 +2431,53 @@ addWanted want_scs avails wanted rhs_expr wanteds avail = Rhs rhs_expr wanteds addGiven :: Avails -> Inst -> TcM Avails -addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given)) +addGiven avails given = addAvailAndSCs AddSCs avails given (Given given) -- Always add superclasses for 'givens' -- -- No ASSERT( not (given `elemAvails` 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 -addRefinedGiven :: Refinement -> ([Inst], Avails) -> Inst -> TcM ([Inst], Avails) -addRefinedGiven reft (refined_givens, avails) given +addRefinedGiven :: Refinement -> Avails -> Inst -> TcM Avails +addRefinedGiven reft avails given | isDict given -- We sometimes have 'given' methods, but they -- are always optional, so we can drop them - , Just (co, pred) <- refinePred reft (dictPred given) + , let pred = dictPred given + , isRefineablePred pred -- See Note [ImplicInst rigidity] + , Just (co, pred) <- refinePred reft pred = do { new_given <- newDictBndr (instLoc given) pred ; let rhs = L (instSpan given) $ HsWrap (WpCo co) (HsVar (instToId given)) - ; avails <- addAvailAndSCs AddSCs avails new_given (Rhs rhs [given]) - ; return (new_given:refined_givens, avails) } + ; addAvailAndSCs AddSCs avails new_given (Rhs rhs [given]) } -- ToDo: the superclasses of the original given all exist in Avails -- so we could really just cast them, but it's more awkward to do, -- and hopefully the optimiser will spot the duplicated work | otherwise - = return (refined_givens, avails) + = return avails +\end{code} + +Note [ImplicInst rigidity] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + C :: forall ab. (Eq a, Ord b) => b -> T a + + ...(case x of C v ->
)... + +From the case (where x::T ty) we'll get an implication constraint + forall b. (Eq ty, Ord b) =>