From c04a5fe3e2867d59ce9757069fdd20c06c326724 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 30 Jan 2009 15:27:38 +0000 Subject: [PATCH] Fix Trac #2985: generating superclasses and recursive dictionaries The Note [Recursive instances and superclases] explains the subtle issues to do with generating the bindings for superclasses when we compile an instance declaration, at least if we want to do the clever "recursive superclass" idea from the SYB3 paper. The old implementation of tcSimplifySuperClasses stumbled when type equalities entered the picture (details in the Note); this patch fixes the problem using a slightly hacky trick. When we re-engineer the constraint solver we'll want to keep an eye on this. Probably worth merging to the 6.10 branch. --- compiler/typecheck/TcRnTypes.lhs | 12 ++++++- compiler/typecheck/TcSimplify.lhs | 68 +++++++++++++++++++++++-------------- 2 files changed, 53 insertions(+), 27 deletions(-) diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index ff8e3d6..28bfd8e 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -29,7 +29,7 @@ module TcRnTypes( -- Insts Inst(..), EqInstCo, InstOrigin(..), InstLoc(..), - pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, + pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, setInstLoc, LIE, emptyLIE, unitLIE, plusLIE, consLIE, instLoc, instSpan, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, @@ -868,6 +868,9 @@ data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt instLoc :: Inst -> InstLoc instLoc inst = tci_loc inst +setInstLoc :: Inst -> InstLoc -> Inst +setInstLoc inst new_loc = inst { tci_loc = new_loc } + instSpan :: Inst -> SrcSpan instSpan wanted = instLocSpan (instLoc wanted) @@ -912,7 +915,13 @@ data InstOrigin | ExprSigOrigin -- e :: ty | RecordUpdOrigin | ViewPatOrigin + | InstScOrigin -- Typechecking superclasses of an instance declaration + + | NoScOrigin -- A very special hack; see TcSimplify, + -- Note [Recursive instances and superclases] + + | DerivOrigin -- Typechecking deriving | StandAloneDerivOrigin -- Typechecking stand-alone deriving | DefaultOrigin -- Typechecking a default decl @@ -936,6 +945,7 @@ instance Outputable InstOrigin where ppr TupleOrigin = ptext (sLit "a tuple") ppr NegateOrigin = ptext (sLit "a use of syntactic negation") ppr InstScOrigin = ptext (sLit "the superclasses of an instance declaration") + ppr NoScOrigin = ptext (sLit "an instance declaration") ppr DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration") ppr StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") ppr DefaultOrigin = ptext (sLit "a 'default' declaration") diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index ad7e5c2..071d4c0 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1265,9 +1265,23 @@ the givens, as you can see from the derivation described above. Conclusion: in the very special case of tcSimplifySuperClasses we have one 'given' (namely the "this" dictionary) whose superclasses -must not be added to 'givens' by addGiven. That is the *whole* reason -for the red_given_scs field in RedEnv, and the function argument to -addGiven. +must not be added to 'givens' by addGiven. + +There is a complication though. Suppose there are equalities + instance (Eq a, a~b) => Num (a,b) +Then we normalise the 'givens' wrt the equalities, so the original +given "this" dictionary is cast to one of a different type. So it's a +bit trickier than before to identify the "special" dictionary whose +superclasses must not be added. See test + indexed-types/should_run/EqInInstance + +We need a persistent property of the dictionary to record this +special-ness. Current I'm using the InstLocOrigin (a bit of a hack, +but cool), which is maintained by dictionary normalisation. +Specifically, the InstLocOrigin is + NoScOrigin +then the no-superclass thing kicks in. WATCH OUT if you fiddle +with InstLocOrigin! \begin{code} tcSimplifySuperClasses @@ -1279,20 +1293,23 @@ tcSimplifySuperClasses -> TcM TcDictBinds tcSimplifySuperClasses loc this givens sc_wanteds = do { traceTc (text "tcSimplifySuperClasses") + + -- Note [Recursive instances and superclases] + ; no_sc_loc <- getInstLoc NoScOrigin + ; let no_sc_this = setInstLoc this no_sc_loc + + ; let env = RedEnv { red_doc = pprInstLoc loc, + red_try_me = try_me, + red_givens = no_sc_this : givens, + red_stack = (0,[]), + red_improve = False } -- No unification vars + + ; (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 = RedEnv { red_doc = pprInstLoc loc, - red_try_me = try_me, - red_givens = this:givens, - red_given_scs = add_scs, - red_stack = (0,[]), - red_improve = False } -- No unification vars - add_scs g | g==this = NoSCs - | otherwise = AddSCs - try_me _ = ReduceMe -- Try hard, so we completely solve the superclass -- constraints right here. See Note [SUPERCLASS-LOOP 1] \end{code} @@ -1761,8 +1778,6 @@ data RedEnv -- Always dicts & equalities -- but see Note [Rigidity] - , red_given_scs :: Inst -> WantSCs -- See Note [Recursive instances and superclases] - , red_stack :: (Int, [Inst]) -- Recursion stack (for err msg) -- See Note [RedStack] } @@ -1785,7 +1800,6 @@ mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv mkRedEnv doc try_me givens = RedEnv { red_doc = doc, red_try_me = try_me, red_givens = givens, - red_given_scs = const AddSCs, red_stack = (0,[]), red_improve = True } @@ -1794,7 +1808,6 @@ mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv mkInferRedEnv doc try_me = RedEnv { red_doc = doc, red_try_me = try_me, red_givens = [], - red_given_scs = const AddSCs, red_stack = (0,[]), red_improve = True } @@ -1803,7 +1816,6 @@ mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv mkNoImproveRedEnv doc try_me = RedEnv { red_doc = doc, red_try_me = try_me, red_givens = [], - red_given_scs = const AddSCs, red_stack = (0,[]), red_improve = True } @@ -1887,8 +1899,7 @@ reduceContext env wanteds0 -- Build the Avail mapping from "given_dicts" ; (init_state, _) <- getLIE $ do - { init_state <- foldlM (addGiven (red_given_scs env)) - emptyAvails givens' + { init_state <- foldlM addGiven emptyAvails givens' ; return init_state } @@ -2602,14 +2613,19 @@ addWanted want_scs avails wanted rhs_expr wanteds where avail = Rhs rhs_expr wanteds -addGiven :: (Inst -> WantSCs) -> Avails -> Inst -> TcM Avails -addGiven want_scs avails given = addAvailAndSCs (want_scs given) avails given (Given given) - -- Conditionally add superclasses for 'givens' +addGiven :: Avails -> Inst -> TcM Avails +addGiven avails given + = addAvailAndSCs want_scs avails given (Given given) + where + want_scs = case instLocOrigin (instLoc given) of + NoScOrigin -> NoSCs + _other -> AddSCs + -- Conditionally add superclasses for 'given' -- See Note [Recursive instances and superclases] - -- - -- 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 + + -- 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 \end{code} \begin{code} -- 1.7.10.4