import PprType ( pprClassPred )
import TcMonoType ( tcSigPolyId, tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
import TcUnify ( checkSigTyVars )
-import TcSimplify ( tcSimplifyCheck )
+import TcSimplify ( tcSimplifyCheck, tcSimplifyTop )
import HscTypes ( HomeSymbolTable, DFunId, FixityEnv,
PersistentCompilerState(..), PersistentRenamerState,
ModDetails(..)
(clas, inst_tys') = getClassPredTys pred
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
- sel_names = [idName sel_id | (sel_id, _) <- op_items]
-
-- Instantiate the super-class context with inst_tys
sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta
-
- -- Find any definitions in monobinds that aren't from the class
- bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
origin = InstanceDeclOrigin
in
- -- Check that all the method bindings come from this class
- mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
-
-- Create dictionary Ids from the specified instance contexts.
- newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts ->
- newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts ->
- newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
+ newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts ->
+ newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts ->
+ newDicts origin [pred] `thenNF_Tc` \ [this_dict] ->
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
- mapAndUnzipTc (mkMethodBind origin clas inst_tys' monobinds)
- op_items `thenTc` \ (meth_insts, meth_infos) ->
+ -- Check that all the method bindings come from this class
+ mkMethodBinds clas inst_tys' op_items monobinds `thenTc` \ (meth_insts, meth_infos) ->
- let
- -- These insts are in scope; quite a few, eh?
- avail_insts = [this_dict] ++
- dfun_arg_dicts ++
- sc_dicts ++
- meth_insts
+ let -- These insts are in scope; quite a few, eh?
+ avail_insts = [this_dict] ++ dfun_arg_dicts ++
+ sc_dicts ++ meth_insts
xtve = inst_tyvars `zip` inst_tyvars'
tc_meth = tcMethodBind xtve inst_tyvars' dfun_theta' avail_insts
in
- mapAndUnzipTc tc_meth meth_infos `thenTc` \ (meth_binds_s, meth_lie_s) ->
+ mapAndUnzipTc tc_meth meth_infos `thenTc` \ (meth_binds_s, meth_lie_s) ->
-- Figure out bindings for the superclass context
- tcAddErrCtxt superClassCtxt $
- tcSimplifyCheck
- (ptext SLIT("instance declaration superclass context"))
- inst_tyvars'
- dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
- -- get bound by just selecting from this_dict!!
- (mkLIE sc_dicts)
- `thenTc` \ (sc_lie, sc_binds) ->
- -- It's possible that the superclass stuff might have done unification
- checkSigTyVars inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
+ tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
+ `thenTc` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) ->
-- Deal with SPECIALISE instance pragmas by making them
-- look like SPECIALISE pragmas for the dfun
let
- mk_prag (SpecInstSig ty loc) = SpecSig (idName dfun_id) ty loc
- mk_prag prag = prag
-
- all_prags = map mk_prag uprags
+ spec_prags = [ SpecSig (idName dfun_id) ty loc
+ | SpecInstSig ty loc <- uprags]
in
tcExtendGlobalValEnv [dfun_id] (
tcExtendLocalValEnv2 [(idName sel_id, tcSigPolyId sig)
| (sel_id, sig, _) <- meth_infos] $
-- Map sel_id to the local method name we are using
- tcSpecSigs all_prags
+ tcSpecSigs spec_prags
) `thenTc` \ (prag_binds, prag_lie) ->
-- Create the result bindings
dict_bind = VarMonoBind this_dict_id dict_rhs
meth_binds = andMonoBindList meth_binds_s
- all_binds = sc_binds `AndMonoBinds` meth_binds `AndMonoBinds` dict_bind
+ all_binds = sc_binds_inner `AndMonoBinds` meth_binds `AndMonoBinds` dict_bind
main_bind = AbsBinds
zonked_inst_tyvars
[(inst_tyvars', local_dfun_id, this_dict_id)]
inlines all_binds
in
- returnTc (plusLIEs meth_lie_s `plusLIE` sc_lie `plusLIE` prag_lie,
- main_bind `AndMonoBinds` prag_binds)
+ returnTc (plusLIEs meth_lie_s `plusLIE` prag_lie,
+ main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer)
+\end{code}
+
+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
+ = tcAddErrCtxt superClassCtxt $
+ tcSimplifyCheck doc inst_tyvars'
+ dfun_arg_dicts
+ (mkLIE sc_dicts) `thenTc` \ (sc_lie, sc_binds1) ->
+
+ -- It's possible that the superclass stuff might have done unification
+ checkSigTyVars inst_tyvars' `thenTc` \ zonked_inst_tyvars ->
+
+ -- We must simplify this all the way down
+ -- lest we build superclass loops
+ tcSimplifyTop sc_lie `thenTc` \ sc_binds2 ->
+
+ returnTc (zonked_inst_tyvars, sc_binds1, sc_binds2)
+
+ where
+ doc = ptext SLIT("instance declaration superclass context")
\end{code}
+\begin{code}
+mkMethodBinds clas inst_tys' op_items monobinds
+ = -- Check that all the method bindings come from this class
+ mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
+
+ -- Make the method bindings
+ mapAndUnzipTc mk_method_bind op_items
+
+ where
+ mk_method_bind op_item = mkMethodBind InstanceDeclOrigin clas
+ inst_tys' monobinds op_item
+
+ -- Find any definitions in monobinds that aren't from the class
+ sel_names = [idName sel_id | (sel_id, _) <- op_items]
+ bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
+\end{code}
+
+
------------------------------
Inlining dfuns unconditionally
------------------------------
-- tcSimplifyCheck is used when checking expression type signatures,
-- class decls, instance decls etc.
--
--- NB: we psss isFree (not isFreeAndInheritable) to tcSimplCheck
--- It's important that we can float out non-inheritable predicates
--- Example: (?x :: Int) is ok!
---
-- NB: tcSimplifyCheck does not consult the
-- global type variables in the environment; so you don't
-- need to worry about setting them before calling tcSimplifyCheck
-- an optimisation, and perhaps it is more trouble that it is worth,
-- as the following comments show!
--
- -- NB1: do *not* add superclasses. If we have
+ -- 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
addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> NF_TcM Avails
addWanted avails wanted rhs_expr wanteds
--- Do *not* add superclasses as well. Here's an example of why not
--- class Eq b => Foo a b
--- instance Eq a => Foo [a] a
--- If we are reducing
--- (Foo [t] t)
--- we'll first deduce that it holds (via the instance decl). We
--- must not then overwrite the Eq t constraint with a superclass selection!
--- ToDo: this isn't entirely satisfactory, because
--- we may also lose some entirely-legitimate sharing this way
-
- = ASSERT( not (wanted `elemFM` avails) )
- returnNF_Tc (addToFM avails wanted avail)
+ = ASSERT2( not (wanted `elemFM` avails), ppr wanted $$ ppr avails )
+ addAvailAndSCs avails wanted avail
where
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
addGiven :: Avails -> Inst -> NF_TcM Avails
addGiven state given = addAvailAndSCs state given (Given (instToId given) False)
+ -- 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 -> NF_TcM Avails
-addIrred NoSCs state irred = returnNF_Tc (addToFM state irred Irred)
-addIrred AddSCs state irred = addAvailAndSCs state irred Irred
+addIrred NoSCs avails irred = returnNF_Tc (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 -> NF_TcM Avails
-addAvailAndSCs avails wanted avail
- = add_scs (addToFM avails wanted avail) wanted
-
-add_scs :: Avails -> Inst -> NF_TcM Avails
+addAvailAndSCs avails inst avail
+ | not (isClassDict inst) = returnNF_Tc avails1
+ | otherwise = addSCs is_loop avails1 inst
+ where
+ avails1 = addToFM avails inst avail
+ is_loop inst = inst `elem` deps
+ deps = findAllDeps avails avail
+
+findAllDeps :: Avails -> Avail -> [Inst]
+-- Find all the Insts that this one depends on
+-- See Note [SUPERCLASS-LOOP]
+findAllDeps avails (Rhs _ kids) = kids ++ concat (map (find_all_deps_help avails) kids)
+findAllDeps avails other = []
+
+find_all_deps_help :: Avails -> Inst -> [Inst]
+find_all_deps_help avails inst
+ = case lookupFM avails inst of
+ Just avail -> findAllDeps avails avail
+ Nothing -> []
+
+addSCs :: (Inst -> Bool) -> Avails -> Inst -> NF_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.
-add_scs avails dict
- | not (isClassDict dict)
+addSCs is_loop avails dict
+ | is_loop dict -- See Note [SUPERCLASS-LOOP]
= returnNF_Tc avails
- | otherwise -- It is a dictionary
+ | otherwise -- No loop
= newDictsFromOld dict sc_theta' `thenNF_Tc` \ sc_dicts ->
foldlNF_Tc add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
where
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
= case lookupFM avails sc_dict of
- Just (Given _ _) -> returnNF_Tc avails -- See Note [SUPER] below
- other -> addAvailAndSCs avails sc_dict avail
+ Just (Given _ _) -> returnNF_Tc avails -- Given is cheaper than
+ -- a superclass selection
+ Just other -> returnNF_Tc avails' -- SCs already added
+ Nothing -> addSCs is_loop avails' sc_dict
where
sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
avail = Rhs sc_sel_rhs [dict]
+ avails' = addToFM avails sc_dict avail
\end{code}
-Note [SUPER]. We have to be careful here. If we are *given* d1:Ord a,
+Note [SUPERCLASS-LOOP]: Checking for loops
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have to be careful here. If we are *given* d1:Ord a,
and want to deduce (d2:C [a]) where
class Ord a => C a where
Then we'll use the instance decl to deduce C [a] and then add the
superclasses of C [a] to avails. But we must not overwrite the binding
for d1:Ord a (which is given) with a superclass selection or we'll just
-build a loop! Hence looking for Given. Crudely, Given is cheaper
-than a selection.
+build a loop!
+
+Here's another example
+ class Eq b => Foo a b
+ instance Eq a => Foo [a] a
+If we are reducing
+ (Foo [t] t)
+
+we'll first deduce that it holds (via the instance decl). We must not
+then overwrite the Eq t constraint with a superclass selection!
+
+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
+first time, but reducible next time.
+
+Now we implement the Right Solution, which is to check for loops directly
+when adding superclasses. It's a bit like the occurs check in unification.
+
%************************************************************************
projects / ghc-hetmet.git / commitdiff