From b6d08641e2757898470a10dfa906084ade8ab835 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 7 Dec 2007 07:13:02 +0000 Subject: [PATCH] Properly keep track of whether normalising given or wanted dicts - The information of whether given or wanted class dictionaries where normalised by rewriting wasn't always correctly propagated in TcTyFuns, which lead to malformed dictionary bindings. - Also fixes a bug in TcPat.tcConPat where GADT equalities where emitted in the wrong position in case bindings (which led to CoreLint failures). --- compiler/basicTypes/DataCon.lhs | 12 +++++++----- compiler/coreSyn/CoreLint.lhs | 7 ++++--- compiler/deSugar/DsExpr.lhs | 2 +- compiler/typecheck/TcPat.lhs | 12 ++++++++---- compiler/typecheck/TcSimplify.lhs | 3 ++- compiler/typecheck/TcTyFuns.lhs | 27 ++++++++++++++++++++------- 6 files changed, 42 insertions(+), 21 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 0c6e3c5..7744e8b 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -338,19 +338,21 @@ data DataCon dcRepTyCon :: TyCon, -- Result tycon, T dcRepType :: Type, -- Type of the constructor - -- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a + -- forall a x y. (a:=:(x,y), x~y, Ord x) => + -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: -- see Note [Data con representation] below) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: - -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... } + -- case (e :: T t) of + -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... -- It's convenient to apply the rep-type of MkT to 't', to get - -- forall b. Ord b => ... + -- forall x y. (t:=:(x,y), x~y, Ord x) => x -> y -> T t -- and use that to check the pattern. Mind you, this is really only - -- use in CoreLint. + -- used in CoreLint. - -- Finally, the curried worker function that corresponds to the constructor + -- The curried worker function that corresponds to the constructor: -- It doesn't have an unfolding; the code generator saturates these Ids -- and allocates a real constructor when it finds one. -- diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 395c72a..adb67ad 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -519,9 +519,10 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) { -- Check the pattern -- Scrutinee type must be a tycon applicn; checked by caller -- This code is remarkably compact considering what it does! - -- NB: args must be in scope here so that the lintCoreArgs line works. - -- NB: relies on existential type args coming *after* ordinary type args - + -- NB: args must be in scope here so that the lintCoreArgs + -- line works. + -- NB: relies on existential type args coming *after* + -- ordinary type args ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args) ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) } diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 66c57de..68bf3f1 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -181,7 +181,7 @@ scrungleMatch var scrut body scrungle (Let binds body) = Let binds (scrungle body) scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other)) -\end{code} +\end{code} %************************************************************************ %* * diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index c2f758d..10946f3 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -637,17 +637,21 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys' - arg_pats pstate thing_inside + arg_pats pstate thing_inside ; let res_pat = ConPatOut { pat_con = L con_span data_con, - pat_tvs = [], pat_dicts = [], pat_binds = emptyLHsBinds, - pat_args = arg_pats', pat_ty = pat_ty' } + pat_tvs = [], pat_dicts = [], + pat_binds = emptyLHsBinds, + pat_args = arg_pats', + pat_ty = pat_ty' } ; return (wrap_res_pat res_pat, inner_tvs, res) } else do -- The general case, with existential, and local equality -- constraints { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec] - theta' = substTheta tenv (full_theta ++ eq_preds) + theta' = substTheta tenv (eq_preds ++ full_theta) + -- order is *important* as we generate the list of + -- dictionary binders from theta' ctxt = pat_ctxt pstate ; checkTc (case ctxt of { ProcPat -> False; other -> True }) (existentialProcPat data_con) diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 3397594..433266e 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1820,7 +1820,8 @@ reduceContext env wanteds -- 8. Substitute the wanted *equations* in the wanted *dictionaries* ; let irreds = dict_irreds ++ implic_irreds - ; (norm_irreds, normalise_binds2) <- substEqInDictInsts eq_irreds irreds + ; (norm_irreds, normalise_binds2) <- substEqInDictInsts True {-wanted-} + eq_irreds irreds -- 9. eliminate the artificial skolem constants introduced in 1. ; eliminate_skolems diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs index d7da2f7..ca3c4a8 100644 --- a/compiler/typecheck/TcTyFuns.lhs +++ b/compiler/typecheck/TcTyFuns.lhs @@ -388,14 +388,18 @@ normalise_dicts -- Fals <=> they are given -> TcM ([Inst],TcDictBinds) normalise_dicts given_eqs dicts is_wanted - = do { traceTc $ text "normalise???Dicts <-" <+> ppr dicts <+> + = do { traceTc $ let name | is_wanted = "normaliseWantedDicts <-" + | otherwise = "normaliseGivenDicts <-" + in + text name <+> ppr dicts <+> text "with" <+> ppr given_eqs ; (dicts0, binds0) <- normaliseInsts is_wanted dicts - ; (dicts1, binds1) <- substEqInDictInsts given_eqs dicts0 + ; (dicts1, binds1) <- substEqInDictInsts is_wanted given_eqs dicts0 ; let binds01 = binds0 `unionBags` binds1 ; if isEmptyBag binds1 then return (dicts1, binds01) - else do { (dicts2, binds2) <- normaliseGivenDicts given_eqs dicts1 + else do { (dicts2, binds2) <- + normalise_dicts given_eqs dicts1 is_wanted ; return (dicts2, binds01 `unionBags` binds2) } } \end{code} @@ -1080,10 +1084,11 @@ form where F is a type family. \begin{code} -substEqInDictInsts :: [Inst] -- given equalities (used as rewrite rules) +substEqInDictInsts :: Bool -- whether the *dictionaries* are wanted/given + -> [Inst] -- given equalities (used as rewrite rules) -> [Inst] -- dictinaries to be normalised -> TcM ([Inst], TcDictBinds) -substEqInDictInsts eqInsts dictInsts +substEqInDictInsts isWanted eqInsts dictInsts = do { traceTc (text "substEqInDictInst <-" <+> ppr dictInsts) ; dictInsts' <- foldlM rewriteWithOneEquality (dictInsts, emptyBag) eqInsts @@ -1097,7 +1102,7 @@ substEqInDictInsts eqInsts dictInsts tci_right = target}) | isOpenSynTyConApp pattern || isTyVarTy pattern = do { (dictInsts', moreDictBinds) <- - genericNormaliseInsts True {- wanted -} applyThisEq dictInsts + genericNormaliseInsts isWanted applyThisEq dictInsts ; return (dictInsts', dictBinds `unionBags` moreDictBinds) } where @@ -1176,7 +1181,13 @@ genericNormaliseInsts isWanted fun insts rhs = L (instLocSpan loc) cast_expr binds = instToDictBind target_dict rhs -- return the new inst - ; traceTc $ text "genericNormaliseInst ->" <+> ppr dict' + ; traceTc $ let name | isWanted + = "genericNormaliseInst (wanted) ->" + | otherwise + = "genericNormaliseInst (given) ->" + in + text name <+> ppr dict' <+> + text "with" <+> ppr binds ; return (dict', binds) } } @@ -1184,6 +1195,8 @@ genericNormaliseInsts isWanted fun insts -- TOMDO: What do we have to do about ImplicInst, Method, and LitInst?? normaliseOneInst _isWanted _fun inst = do { inst' <- zonkInst inst + ; traceTc $ text "*** TcTyFuns.normaliseOneInst: Skipping" <+> + ppr inst ; return (inst', emptyBag) } \end{code} -- 1.7.10.4