Commit 13878c13 authored by simonpj's avatar simonpj
Browse files

[project @ 2002-04-02 13:21:36 by simonpj]

-----------------------------------------------------
	Fix two nasty, subtle loops in context simplification
	-----------------------------------------------------

The context simplifier in TcSimplify was building a recursive
dictionary, which meant the program looped when run.  The reason
was pretty devious; in fact there are two independent causes.

Cause 1
~~~~~~~
Consider
 	class Eq b => Foo a b
	instance Eq a => Foo [a] a
If we are reducing
	d:Foo [t] t
we'll first deduce that it holds (via the instance decl), thus:
	d:Foo [t] t = $fFooList deq
	deq:Eq t = ...some rhs depending on t...
Now we add d's superclasses.  We must not then overwrite the Eq t
constraint with a superclass selection!!

The only decent way to solve this is to track what dependencies
a binding has; that is what the is_loop parameter to TcSimplify.addSCs
now does.


Cause 2
~~~~~~~
This shows up when simplifying the superclass context of an
instance declaration.  Consider

  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.

This is done in TcInstDcls.tcSuperClasses, which is well commented.

All this from a bug report from Peter White!
parent c19b4e62
......@@ -43,7 +43,7 @@ import InstEnv ( InstEnv, extendInstEnv )
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(..)
......@@ -548,59 +548,38 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }
(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] (
......@@ -608,7 +587,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }
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
......@@ -655,7 +634,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }
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
......@@ -663,10 +642,87 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }
[(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
------------------------------
......
......@@ -671,10 +671,6 @@ tcSimplifyCheck
-- 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
......@@ -1458,7 +1454,7 @@ addFree :: Avails -> Inst -> NF_TcM Avails
-- 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
......@@ -1468,42 +1464,55 @@ addFree avails free = returnNF_Tc (addToFM avails free IsFree)
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
......@@ -1513,14 +1522,19 @@ add_scs avails dict
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
......@@ -1529,8 +1543,27 @@ and want to deduce (d2: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.
%************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment