TcSimplify.lhs 59.6 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
%
\section[TcSimplify]{TcSimplify}

6
7
8


\begin{code}
9
module TcSimplify (
10
	tcSimplifyInfer, tcSimplifyInferCheck,
11
	tcSimplifyCheck, tcSimplifyRestricted,
12
	tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
13

14
15
	tcSimplifyThetas, tcSimplifyCheckThetas,
	bindInstsOfLocalFuns
16
17
    ) where

18
#include "HsVersions.h"
19

20
import HsSyn		( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
21
import TcHsSyn		( TcExpr, TcId,
22
23
			  TcMonoBinds, TcDictBinds
			)
24

25
import TcMonad
26
import Inst		( lookupInst, lookupSimpleInst, LookupInstResult(..),
27
			  tyVarsOfInst, predsOfInsts, predsOfInst,
28
			  isDict, isClassDict, instName,
29
			  isStdClassTyVarDict, isMethodFor,
30
31
32
			  instToId, tyVarsOfInsts,
			  instBindingRequired, instCanBeGeneralised,
			  newDictsFromOld, instMentionsIPs,
33
			  getDictClassTys, isTyVarDict,
34
			  instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts,
35
			  Inst, LIE, pprInsts, pprInstsInFull,
36
			  mkLIE, lieToList
sof's avatar
sof committed
37
			)
38
import TcEnv		( tcGetGlobalTyVars, tcGetInstEnv )
39
import InstEnv		( lookupInstEnv, classInstEnv, InstLookupResult(..) )
40

41
42
43
44
45
import TcMType		( zonkTcTyVarsAndFV, tcInstTyVars, unifyTauTy )
import TcType		( ThetaType, PredType, mkClassPred, isOverloadedTy,
			  mkTyVarTy, tcGetTyVar, isTyVarClassPred,
			  tyVarsOfPred, getClassPredTys_maybe, isClassPred, isIPPred,
			  inheritablePred, predHasFDs )
46
import Id		( idType )
47
import NameSet		( mkNameSet )
48
import Class		( classBigSig )
49
import FunDeps		( oclose, grow, improve, pprEquationDoc )
sof's avatar
sof committed
50
import PrelInfo		( isNumericClass, isCreturnableClass, isCcallishClass )
51

52
import Subst		( mkTopTyVarSubst, substTheta, substTy )
53
import TysWiredIn	( unitTy )
54
import VarSet
55
56
import FiniteMap
import Outputable
57
import ListSetOps	( equivClasses )
58
import Util		( zipEqual )
59
import List		( partition )
60
import CmdLineOpts
61
62
63
64
65
\end{code}


%************************************************************************
%*									*
66
\subsection{NOTES}
67
68
69
%*									*
%************************************************************************

70
	--------------------------------------
71
		Notes on quantification
72
	--------------------------------------
73
74
75
76
77
78

Suppose we are about to do a generalisation step.
We have in our hand

	G	the environment
	T	the type of the RHS
79
	C	the constraints from that RHS
80
81
82
83
84
85
86
87
88
89
90

The game is to figure out

	Q	the set of type variables over which to quantify
	Ct	the constraints we will *not* quantify over
	Cq	the constraints we will quantify over

So we're going to infer the type

	forall Q. Cq => T

91
and float the constraints Ct further outwards.
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

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.

	BETWEEN THESE TWO BOUNDS, ANY Q WILL DO!

Example:	class H x y | x->y where ...

	fv(G) = {a}	C = {H a b, H c d}
			T = c -> b

	(A)  Q intersect {a} is empty
	(B)  Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d}

	So Q can be {c,d}, {b,c,d}

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
130
		using all conceivable links from C.
131
132
133
134
135
136
137

		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.

138
Notice that
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
   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:

	Q = grow( fv(T), C ) \ oclose( fv(G), C )

That is, quantify over all variable that that MIGHT be fixed by the
call site (which influences T), but which aren't DEFINITELY fixed by
G.  This choice definitely quantifies over enough type variables,
albeit perhaps too many.

Why grow( fv(T), C ) rather than fv(T)?  Consider

	class H x y | x->y where ...
159

160
161
162
163
164
165
166
	T = c->c
	C = (H c d)

  If we used fv(T) = {c} we'd get the type

	forall c. H c d => c -> b

167
  And then if the fn was called at several different c's, each of
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
  which fixed d differently, we'd get a unification error, because
  d isn't quantified.  Solution: quantify d.  So we must quantify
  everything that might be influenced by c.

Why not oclose( fv(T), C )?  Because we might not be able to see
all the functional dependencies yet:

	class H x y | x->y where ...
	instance H x y => Eq (T x y) where ...

	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.


There really isn't any point in quantifying over any more than
grow( fv(T), C ), because the call sites can't possibly influence
any other type variables.



191
192
193
	--------------------------------------
		Notes on ambiguity
	--------------------------------------
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

It's very hard to be certain when a type is ambiguous.  Consider

	class K x
	class H x y | x -> y
	instance H x y => K (x,y)

Is this type ambiguous?
	forall a b. (K (a,b), Eq b) => a -> a

Looks like it!  But if we simplify (K (a,b)) we get (H a b) and
now we see that a fixes b.  So we can't tell about ambiguity for sure
without doing a full simplification.  And even that isn't possible if
the context has some free vars that may get unified.  Urgle!

Here's another example: is this ambiguous?
	forall a b. Eq (T b) => a -> a
Not if there's an insance decl (with no context)
	instance Eq (T b) where ...

You may say of this example that we should use the instance decl right
away, but you can't always do that:

	class J a b where ...
	instance J Int b where ...

	f :: forall a b. J a b => a -> a

(Notice: no functional dependency in J's class decl.)
Here f's type is perfectly fine, provided f is only called at Int.
It's premature to complain when meeting f's signature, or even
when inferring a type for f.



However, we don't *need* to report ambiguity right away.  It'll always
show up at the call site.... and eventually at main, which needs special
treatment.  Nevertheless, reporting ambiguity promptly is an excellent thing.

233
So here's the plan.  We WARN about probable ambiguity if
234
235
236
237
238

	fv(Cq) is not a subset of  oclose(fv(T) union fv(G), C)

(all tested before quantification).
That is, all the type variables in Cq must be fixed by the the variables
239
in the environment, or by the variables in the type.
240
241
242

Notice that we union before calling oclose.  Here's an example:

243
	class J a b c | a b -> c
244
245
246
	fv(G) = {a}

Is this ambiguous?
247
	forall b c. (J a b c) => b -> b
248
249

Only if we union {a} from G with {b} from T before using oclose,
250
do we see that c is fixed.
251

252
It's a bit vague exactly which C we should use for this oclose call.  If we
253
254
255
256
257
258
259
260
261
don't fix enough variables we might complain when we shouldn't (see
the above nasty example).  Nothing will be perfect.  That's why we can
only issue a warning.


Can we ever be *certain* about ambiguity?  Yes: if there's a constraint

	c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY

262
then c is a "bubble"; there's no way it can ever improve, and it's
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
certainly ambiguous.  UNLESS it is a constant (sigh).  And what about
the nasty example?

	class K x
	class H x y | x -> y
	instance H x y => K (x,y)

Is this type ambiguous?
	forall a b. (K (a,b), Eq b) => a -> a

Urk.  The (Eq b) looks "definitely ambiguous" but it isn't.  What we are after
is a "bubble" that's a set of constraints

	Cq = Ca union Cq'  st  fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY

Hence another idea.  To decide Q start with fv(T) and grow it
by transitive closure in Cq (no functional dependencies involved).
Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
281
The definitely-ambiguous can then float out, and get smashed at top level
282
283
284
(which squashes out the constants, like Eq (T a) above)


285
	--------------------------------------
286
		Notes on principal types
287
	--------------------------------------
288
289
290

    class C a where
      op :: a -> a
291

292
293
294
295
296
297
298
    f x = let g y = op (y::Int) in True

Here the principal type of f is (forall a. a->a)
but we'll produce the non-principal type
    f :: forall a. C Int => a -> a


299
	--------------------------------------
300
		Notes on implicit parameters
301
	--------------------------------------
302

303
304
305
306
307
Question 1: can we "inherit" implicit parameters
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:

	f x = (x::Int) + ?y
308

309
310
311
where f is *not* a top-level binding.
From the RHS of f we'll get the constraint (?y::Int).
There are two types we might infer for f:
312

313
314
315
	f :: Int -> Int

(so we get ?y from the context of f's definition), or
316
317
318

	f :: (?y::Int) => Int -> Int

319
320
321
322
323
324
At first you might think the first was better, becuase then
?y behaves like a free variable of the definition, rather than
having to be passed at each call site.  But of course, the WHOLE
IDEA is that ?y should be passed at each call site (that's what
dynamic binding means) so we'd better infer the second.

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
BOTTOM LINE: you *must* quantify over implicit parameters. See
isFreeAndInheritable.

BUT WATCH OUT: for *expressions*, this isn't right.  Consider:

	(?x + 1) :: Int

This is perfectly reasonable.  We do not want to insist on

	(?x + 1) :: (?x::Int => Int)

That would be silly.  Here, the definition site *is* the occurrence site,
so the above strictures don't apply.  Hence the difference between
tcSimplifyCheck (which *does* allow implicit paramters to be inherited)
and tcSimplifyCheckBind (which does not).
340
341
342
343


Question 2: type signatures
~~~~~~~~~~~~~~~~~~~~~~~~~~~
344
OK, so is it legal to give an explicit, user type signature to f, thus:
345

346
	f :: Int -> Int
347
	f x = (x::Int) + ?y
348

349
At first sight this seems reasonable, but it has the nasty property
350
that adding a type signature changes the dynamic semantics.
351
Consider this:
352

353
	(let f x = (x::Int) + ?y
354
355
356
357
 	 in (f 3, f 3 with ?y=5))  with ?y = 6

		returns (3+6, 3+5)
vs
358
	(let f :: Int -> Int
359
	     f x = x + ?y
360
361
362
363
	 in (f 3, f 3 with ?y=5))  with ?y = 6

		returns (3+6, 3+6)

364
365
Indeed, simply inlining f (at the Haskell source level) would change the
dynamic semantics.
366

367
368
Conclusion: the above type signature is illegal.  You'll get a message
of the form "could not deduce (?y::Int) from ()".
369

370

371
372
373
Question 3: monomorphism
~~~~~~~~~~~~~~~~~~~~~~~~
There's a nasty corner case when the monomorphism restriction bites:
374

375
376
	z = (x::Int) + ?y

377
378
The argument above suggests that we *must* generalise
over the ?y parameter, to get
379
380
	z :: (?y::Int) => Int,
but the monomorphism restriction says that we *must not*, giving
381
	z :: Int.
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
Why does the momomorphism restriction say this?  Because if you have

	let z = x + ?y in z+z

you might not expect the addition to be done twice --- but it will if
we follow the argument of Question 2 and generalise over ?y.



Possible choices
~~~~~~~~~~~~~~~~
(A) Always generalise over implicit parameters
    Bindings that fall under the monomorphism restriction can't
	be generalised

    Consequences:
398
	* Inlining remains valid
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
	* No unexpected loss of sharing
	* But simple bindings like
		z = ?y + 1
	  will be rejected, unless you add an explicit type signature
	  (to avoid the monomorphism restriction)
		z :: (?y::Int) => Int
		z = ?y + 1
	  This seems unacceptable

(B) Monomorphism restriction "wins"
    Bindings that fall under the monomorphism restriction can't
	be generalised
    Always generalise over implicit parameters *except* for bindings
	that fall under the monomorphism restriction

    Consequences
	* Inlining isn't valid in general
	* No unexpected loss of sharing
	* Simple bindings like
		z = ?y + 1
	  accepted (get value of ?y from binding site)

(C) Always generalise over implicit parameters
    Bindings that fall under the monomorphism restriction can't
	be generalised, EXCEPT for implicit parameters
    Consequences
	* Inlining remains valid
	* Unexpected loss of sharing (from the extra generalisation)
	* Simple bindings like
		z = ?y + 1
	  accepted (get value of ?y from occurrence sites)


Discussion
~~~~~~~~~~
None of these choices seems very satisfactory.  But at least we should
decide which we want to do.
436

437
It's really not clear what is the Right Thing To Do.  If you see
438

439
	z = (x::Int) + ?y
440

441
442
443
444
445
446
would you expect the value of ?y to be got from the *occurrence sites*
of 'z', or from the valuue of ?y at the *definition* of 'z'?  In the
case of function definitions, the answer is clearly the former, but
less so in the case of non-fucntion definitions.   On the other hand,
if we say that we get the value of ?y from the definition site of 'z',
then inlining 'z' might change the semantics of the program.
447

448
Choice (C) really says "the monomorphism restriction doesn't apply
449
to implicit parameters".  Which is fine, but remember that every
450
451
452
innocent binding 'x = ...' that mentions an implicit parameter in
the RHS becomes a *function* of that parameter, called at each
use of 'x'.  Now, the chances are that there are no intervening 'with'
453
clauses that bind ?y, so a decent compiler should common up all
454
455
456
those function calls.  So I think I strongly favour (C).  Indeed,
one could make a similar argument for abolishing the monomorphism
restriction altogether.
457

458
BOTTOM LINE: we choose (B) at present.  See tcSimplifyRestricted
459

460

461

462
463
464
465
466
467
468
469
470
%************************************************************************
%*									*
\subsection{tcSimplifyInfer}
%*									*
%************************************************************************

tcSimplify is called when we *inferring* a type.  Here's the overall game plan:

    1. Compute Q = grow( fvs(T), C )
471
472

    2. Partition C based on Q into Ct and Cq.  Notice that ambiguous
473
       predicates will end up in Ct; we deal with them at the top level
474

475
    3. Try improvement, using functional dependencies
476

477
478
479
480
    4. If Step 3 did any unification, repeat from step 1
       (Unification can change the result of 'grow'.)

Note: we don't reduce dictionaries in step 2.  For example, if we have
481
Eq (a,b), we don't simplify to (Eq a, Eq b).  So Q won't be different
482
483
484
485
486
487
488
after step 2.  However note that we may therefore quantify over more
type variables than we absolutely have to.

For the guts, we need a loop, that alternates context reduction and
improvement with unification.  E.g. Suppose we have

	class C x y | x->y where ...
489

490
491
492
493
494
495
and tcSimplify is called with:
	(C Int a, C Int b)
Then improvement unifies a with b, giving
	(C Int a, C Int a)

If we need to unify anything, we rattle round the whole thing all over
496
again.
497

498
499

\begin{code}
500
tcSimplifyInfer
501
502
	:: SDoc
	-> TcTyVarSet		-- fv(T); type vars
503
504
505
506
507
508
	-> LIE			-- Wanted
	-> TcM ([TcTyVar],	-- Tyvars to quantify (zonked)
		LIE,		-- Free
		TcDictBinds,	-- Bindings
		[TcId])		-- Dict Ids that must be bound here (zonked)
\end{code}
509

510
511
512

\begin{code}
tcSimplifyInfer doc tau_tvs wanted_lie
513
  = inferLoop doc (varSetElems tau_tvs)
514
	      (lieToList wanted_lie)	`thenTc` \ (qtvs, frees, binds, irreds) ->
515
516

	-- Check for non-generalisable insts
517
518
    mapTc_ addCantGenErr (filter (not . instCanBeGeneralised) irreds)	`thenTc_`

519
    returnTc (qtvs, mkLIE frees, binds, map instToId irreds)
520
521
522
523
524
525

inferLoop doc tau_tvs wanteds
  =   	-- Step 1
    zonkTcTyVarsAndFV tau_tvs		`thenNF_Tc` \ tau_tvs' ->
    mapNF_Tc zonkInst wanteds		`thenNF_Tc` \ wanteds' ->
    tcGetGlobalTyVars			`thenNF_Tc` \ gbl_tvs ->
526
    let
527
528
 	preds = predsOfInsts wanteds'
	qtvs  = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
529
530

	try_me inst
531
532
533
	  | isFreeAndInheritable qtvs inst = Free
	  | isClassDict inst 		   = DontReduceUnlessConstant	-- Dicts
	  | otherwise	    		   = ReduceMe 			-- Lits and Methods
534
    in
535
536
		-- Step 2
    reduceContext doc try_me [] wanteds'    `thenTc` \ (no_improvement, frees, binds, irreds) ->
537

538
539
		-- Step 3
    if no_improvement then
540
	returnTc (varSetElems qtvs, frees, binds, irreds)
541
    else
542
543
544
545
546
547
548
549
550
551
552
553
	-- 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)

554
555
556
	-- However, NOTICE that when we are done, we might have some bindings, but
	-- the final qtvs might be empty.  See [NO TYVARS] below.
				
557
558
	inferLoop doc tau_tvs (irreds ++ frees)	`thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
	returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
559
\end{code}
560

561
562
563
564
565
566
567
568
569
570
571
572
573
Example [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)
574
and improve by binding l->T, after which we can do some reduction
575
576
577
on both the Lte and If constraints.  What we *can't* do is start again
with (Max Z (S x) y)!

578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
[NO TYVARS]

	class Y a b | a -> b where
	    y :: a -> X b
	
	instance Y [[a]] a where
	    y ((x:_):_) = X x
	
	k :: X a -> X a -> X a

	g :: Num a => [X a] -> [X a]
	g xs = h xs
	    where
	    h ys = ys ++ map (k (y [[0]])) xs

The excitement comes when simplifying the bindings for h.  Initially
try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
From this we get t1:=:t2, but also various bindings.  We can't forget
the bindings (because of [LOOP]), but in fact t1 is what g is
polymorphic in.

599
\begin{code}
600
601
isFreeAndInheritable qtvs inst
  =  isFree qtvs inst					-- Constrains no quantified vars
602
  && all inheritablePred (predsOfInst inst)		-- And no implicit parameter involved
603
							-- (see "Notes on implicit parameters")
604

605
isFree qtvs inst
606
  = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
607
\end{code}
608

609

610
611
612
613
614
%************************************************************************
%*									*
\subsection{tcSimplifyCheck}
%*									*
%************************************************************************
615

616
@tcSimplifyCheck@ is used when we know exactly the set of variables
617
we are going to quantify over.  For example, a class or instance declaration.
618
619

\begin{code}
620
tcSimplifyCheck
621
	 :: SDoc
622
623
	 -> [TcTyVar]		-- Quantify over these
	 -> [Inst]		-- Given
624
	 -> LIE			-- Wanted
625
	 -> TcM (LIE,		-- Free
626
		 TcDictBinds)	-- Bindings
627

628
-- tcSimplifyCheck is used when checking exprssion type signatures,
629
630
631
632
-- class decls, instance decls etc.
-- Note that we psss isFree (not isFreeAndInheritable) to tcSimplCheck
-- It's important that we can float out non-inheritable predicates
-- Example:		(?x :: Int) is ok!
633
tcSimplifyCheck doc qtvs givens wanted_lie
634
635
636
637
638
639
640
641
642
643
644
  = tcSimplCheck doc isFree get_qtvs
		 givens wanted_lie	`thenTc` \ (qtvs', frees, binds) ->
    returnTc (frees, binds)
  where
    get_qtvs = zonkTcTyVarsAndFV qtvs


-- 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
645
	 :: SDoc
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
	 -> TcTyVarSet		-- fv(T)
	 -> [Inst]		-- Given
	 -> LIE			-- Wanted
	 -> TcM ([TcTyVar],	-- Variables over which to quantify
		 LIE,		-- Free
		 TcDictBinds)	-- Bindings

tcSimplifyInferCheck doc tau_tvs givens wanted_lie
  = tcSimplCheck doc isFreeAndInheritable get_qtvs givens wanted_lie
  where
	-- 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.
    all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)

    get_qtvs = zonkTcTyVarsAndFV all_tvs	`thenNF_Tc` \ all_tvs' ->
	       tcGetGlobalTyVars		`thenNF_Tc` \ gbl_tvs ->
	       let
	          qtvs = all_tvs' `minusVarSet` gbl_tvs
			-- We could close gbl_tvs, but its not necessary for
672
			-- soundness, and it'll only affect which tyvars, not which
673
674
675
676
677
678
679
			-- dictionaries, we quantify over
	       in
	       returnNF_Tc qtvs
\end{code}

Here is the workhorse function for all three wrappers.

680
\begin{code}
681
682
tcSimplCheck doc is_free get_qtvs givens wanted_lie
  = check_loop givens (lieToList wanted_lie)	`thenTc` \ (qtvs, frees, binds, irreds) ->
683

684
	-- Complain about any irreducible ones
685
    complainCheck doc givens irreds		`thenNF_Tc_`
686

687
	-- Done
688
    returnTc (qtvs, mkLIE frees, binds)
689

690
691
692
693
694
  where
    check_loop givens wanteds
      =		-- Step 1
    	mapNF_Tc zonkInst givens	`thenNF_Tc` \ givens' ->
    	mapNF_Tc zonkInst wanteds	`thenNF_Tc` \ wanteds' ->
695
696
    	get_qtvs 			`thenNF_Tc` \ qtvs' ->

697
698
699
700
701
 		    -- Step 2
    	let
 	    -- When checking against a given signature we always reduce
 	    -- until we find a match against something given, or can't reduce
 	    try_me inst | is_free qtvs' inst = Free
702
 			| otherwise          = ReduceMe
703
704
    	in
    	reduceContext doc try_me givens' wanteds'	`thenTc` \ (no_improvement, frees, binds, irreds) ->
705

706
707
708
709
710
711
 		    -- Step 3
    	if no_improvement then
 	    returnTc (varSetElems qtvs', frees, binds, irreds)
    	else
 	    check_loop givens' (irreds ++ frees) 	`thenTc` \ (qtvs', frees1, binds1, irreds1) ->
 	    returnTc (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1)
712
713
714
\end{code}


715
716
717
718
719
720
721
722
%************************************************************************
%*									*
\subsection{tcSimplifyRestricted}
%*									*
%************************************************************************

\begin{code}
tcSimplifyRestricted 	-- Used for restricted binding groups
723
			-- i.e. ones subject to the monomorphism restriction
724
	:: SDoc
725
	-> TcTyVarSet		-- Free in the type of the RHSs
726
727
728
729
730
731
732
	-> LIE			-- Free in the RHSs
	-> TcM ([TcTyVar],	-- Tyvars to quantify (zonked)
		LIE,		-- Free
		TcDictBinds)	-- Bindings

tcSimplifyRestricted doc tau_tvs wanted_lie
  = 	-- First squash out all methods, to find the constrained tyvars
733
   	-- We can't just take the free vars of wanted_lie because that'll
734
735
736
737
738
739
740
	-- have methods that may incidentally mention entirely unconstrained variables
	--  	e.g. a call to 	f :: Eq a => a -> b -> b
	-- Here, b is unconstrained.  A good example would be
	--	foo = f (3::Int)
	-- We want to infer the polymorphic type
	--	foo :: forall b. b -> b
    let
741
742
743
744
745
746
	wanteds = lieToList wanted_lie
	try_me inst = ReduceMe		-- Reduce as far as we can.  Don't stop at
					-- dicts; the idea is to get rid of as many type
					-- variables as possible, and we don't want to stop
					-- at (say) Monad (ST s), because that reduces
					-- immediately, with no constraint on s.
747
    in
748
    simpleReduceLoop doc try_me wanteds		`thenTc` \ (_, _, constrained_dicts) ->
749
750

	-- Next, figure out the tyvars we will quantify over
751
752
    zonkTcTyVarsAndFV (varSetElems tau_tvs)	`thenNF_Tc` \ tau_tvs' ->
    tcGetGlobalTyVars				`thenNF_Tc` \ gbl_tvs ->
753
    let
754
755
	constrained_tvs = tyVarsOfInsts constrained_dicts
	qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts constrained_dicts) gbl_tvs)
756
757
758
759
760
761
762
			 `minusVarSet` constrained_tvs
    in

	-- The first step may have squashed more methods than
	-- necessary, so try again, this time knowing the exact
	-- set of type variables to quantify over.
	--
763
	-- We quantify only over constraints that are captured by qtvs;
764
	-- these will just be a subset of non-dicts.  This in contrast
765
766
	-- to normal inference (using isFreeAndInheritable) in which we quantify over
	-- all *non-inheritable* constraints too.  This implements choice
767
768
769
770
771
772
773
774
775
	-- (B) under "implicit parameter and monomorphism" above.
    mapNF_Tc zonkInst (lieToList wanted_lie)	`thenNF_Tc` \ wanteds' ->
    let
        try_me inst | isFree qtvs inst = Free
	            | otherwise        = ReduceMe
    in
    reduceContext doc try_me [] wanteds'	`thenTc` \ (no_improvement, frees, binds, irreds) ->
    ASSERT( no_improvement )
    ASSERT( null irreds )
776
	-- No need to loop because simpleReduceLoop will have
777
778
779
780
781
	-- already done any improvement necessary

    returnTc (varSetElems qtvs, mkLIE frees, binds)
\end{code}

782
783
784
785
786
787
788

%************************************************************************
%*									*
\subsection{tcSimplifyToDicts}
%*									*
%************************************************************************

789
790
791
792
On the LHS of transformation rules we only simplify methods and constants,
getting dictionaries.  We want to keep all of them unsimplified, to serve
as the available stuff for the RHS of the rule.

793
The same thing is used for specialise pragmas. Consider
794

795
796
797
798
799
800
801
802
803
804
805
806
	f :: Num a => a -> a
	{-# SPECIALISE f :: Int -> Int #-}
	f = ...

The type checker generates a binding like:

	f_spec = (f :: Int -> Int)

and we want to end up with

	f_spec = _inline_me_ (f Int dNumInt)

807
But that means that we must simplify the Method for f to (f Int dNumInt)!
808
809
So tcSimplifyToDicts squeezes out all Methods.

810
811
812
813
814
IMPORTANT NOTE:  we *don't* want to do superclass commoning up.  Consider

	fromIntegral :: (Integral a, Num b) => a -> b
	{-# RULES "foo"  fromIntegral = id :: Int -> Int #-}

815
Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
816
817
818
819
820
821
822
823
824
825
826
827
want to get

	forall dIntegralInt.
	fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int

because the scsel will mess up matching.  Instead we want

	forall dIntegralInt, dNumInt.
	fromIntegral Int Int dIntegralInt dNumInt = id Int

Hence "DontReduce NoSCs"

828
\begin{code}
829
tcSimplifyToDicts :: LIE -> TcM ([Inst], TcDictBinds)
830
tcSimplifyToDicts wanted_lie
831
  = simpleReduceLoop doc try_me wanteds		`thenTc` \ (frees, binds, irreds) ->
832
	-- Since try_me doesn't look at types, we don't need to
833
	-- do any zonking, so it's safe to call reduceContext directly
834
    ASSERT( null frees )
835
836
    returnTc (irreds, binds)

837
  where
838
    doc = text "tcSimplifyToDicts"
839
    wanteds = lieToList wanted_lie
840
841

	-- Reduce methods and lits only; stop as soon as we get a dictionary
842
843
    try_me inst	| isDict inst = DontReduce NoSCs
		| otherwise   = ReduceMe
844
845
\end{code}

846

847
848
849
850
851
852
853
854
855
856
%************************************************************************
%*									*
\subsection{Filtering at a dynamic binding}
%*									*
%************************************************************************

When we have
	let ?x = R in B

we must discharge all the ?x constraints from B.  We also do an improvement
857
step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.
858
859
860
861
862
863

Actually, the constraints from B might improve the types in ?x. For example

	f :: (?x::Int) => Char -> Char
	let ?x = 3 in f 'c'

864
then the constraint (?x::Int) arising from the call to f will
865
force the binding for ?x to be of type Int.
866
867

\begin{code}
868
tcSimplifyIPs :: [Inst]		-- The implicit parameters bound here
869
870
	      -> LIE
	      -> TcM (LIE, TcDictBinds)
871
872
tcSimplifyIPs given_ips wanted_lie
  = simpl_loop given_ips wanteds	`thenTc` \ (frees, binds) ->
873
    returnTc (mkLIE frees, binds)
874
  where
875
876
877
878
    doc	     = text "tcSimplifyIPs" <+> ppr ip_names
    wanteds  = lieToList wanted_lie
    ip_names = map instName given_ips
    ip_set   = mkNameSet ip_names
879

880
	-- Simplify any methods that mention the implicit parameter
881
    try_me inst | inst `instMentionsIPs` ip_set = ReduceMe
882
		| otherwise		        = Free
883
884
885
886

    simpl_loop givens wanteds
      = mapNF_Tc zonkInst givens		`thenNF_Tc` \ givens' ->
        mapNF_Tc zonkInst wanteds		`thenNF_Tc` \ wanteds' ->
887

888
889
890
891
892
893
894
895
        reduceContext doc try_me givens' wanteds'    `thenTc` \ (no_improvement, frees, binds, irreds) ->

        if no_improvement then
	    ASSERT( null irreds )
	    returnTc (frees, binds)
	else
	    simpl_loop givens' (irreds ++ frees)	`thenTc` \ (frees1, binds1) ->
	    returnTc (frees1, binds `AndMonoBinds` binds1)
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
\end{code}


%************************************************************************
%*									*
\subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
%*									*
%************************************************************************

When doing a binding group, we may have @Insts@ of local functions.
For example, we might have...
\begin{verbatim}
let f x = x + 1	    -- orig local function (overloaded)
    f.1 = f Int	    -- two instances of f
    f.2 = f Float
 in
    (f.1 5, f.2 6.7)
\end{verbatim}
The point is: we must drop the bindings for @f.1@ and @f.2@ here,
where @f@ is in scope; those @Insts@ must certainly not be passed
upwards towards the top-level.	If the @Insts@ were binding-ified up
there, they would have unresolvable references to @f@.

We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
For each method @Inst@ in the @init_lie@ that mentions one of the
@Ids@, we create a binding.  We return the remaining @Insts@ (in an
@LIE@), as well as the @HsBinds@ generated.

\begin{code}
bindInstsOfLocalFuns ::	LIE -> [TcId] -> TcM (LIE, TcMonoBinds)

bindInstsOfLocalFuns init_lie local_ids
928
  | null overloaded_ids
929
930
931
932
	-- Common case
  = returnTc (init_lie, EmptyMonoBinds)

  | otherwise
933
  = simpleReduceLoop doc try_me wanteds		`thenTc` \ (frees, binds, irreds) ->
934
    ASSERT( null irreds )
935
    returnTc (mkLIE frees, binds)
936
937
938
939
  where
    doc		     = text "bindInsts" <+> ppr local_ids
    wanteds	     = lieToList init_lie
    overloaded_ids   = filter is_overloaded local_ids
940
    is_overloaded id = isOverloadedTy (idType id)
941
942

    overloaded_set = mkVarSet overloaded_ids	-- There can occasionally be a lot of them
943
						-- so it's worth building a set, so that
944
945
						-- lookup (in isMethodFor) is faster

946
    try_me inst | isMethodFor overloaded_set inst = ReduceMe
947
		| otherwise		          = Free
948
\end{code}
949

950

951
952
%************************************************************************
%*									*
953
\subsection{Data types for the reduction mechanism}
954
955
956
%*									*
%************************************************************************

957
958
The main control over context reduction is here

959
\begin{code}
960
data WhatToDo
961
962
 = ReduceMe		-- Try to reduce this
			-- If there's no instance, behave exactly like
963
964
			-- DontReduce: add the inst to
			-- the irreductible ones, but don't
965
966
			-- produce an error message of any kind.
			-- It might be quite legitimate such as (Eq a)!
967

968
 | DontReduce WantSCs		-- Return as irreducible
969
970
971

 | DontReduceUnlessConstant	-- Return as irreducible unless it can
				-- be reduced to a constant in one step
972

973
 | Free			  -- Return as free
974

975
976
data WantSCs = NoSCs | AddSCs	-- Tells whether we should add the superclasses
				-- of a predicate when adding it to the avails
977
\end{code}
978
979
980
981



\begin{code}
982
983
type RedState = (Avails,	-- What's available
		 [Inst])	-- Insts for which try_me returned Free
984

985
type Avails = FiniteMap Inst Avail
986

987
data Avail
988
989
990
991
992
993
994
  = Irred		-- Used for irreducible dictionaries,
			-- which are going to be lambda bound

  | BoundTo TcId	-- Used for dictionaries for which we have a binding
			-- e.g. those "given" in a signature

  | NoRhs 		-- Used for Insts like (CCallable f)
995
996
			-- where no witness is required.

997
  | Rhs 		-- Used when there is a RHS
998
999
	TcExpr	 	-- The RHS
	[Inst]		-- Insts free in the RHS; we need these too
1000

1001
1002
pprAvails avails = vcat [ppr inst <+> equals <+> pprAvail avail
			| (inst,avail) <- fmToList avails ]
1003
1004
1005
1006

instance Outputable Avail where
    ppr = pprAvail

1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
pprAvail NoRhs	      = text "<no rhs>"
pprAvail Irred	      = text "Irred"
pprAvail (BoundTo x)  = text "Bound to" <+> ppr x
pprAvail (Rhs rhs bs) = ppr rhs <+> braces (ppr bs)
\end{code}

Extracting the bindings from a bunch of Avails.
The bindings do *not* come back sorted in dependency order.
We assume that they'll be wrapped in a big Rec, so that the
dependency analyser can sort them out later

The loop startes
\begin{code}
bindsAndIrreds :: Avails
	       -> [Inst]		-- Wanted
	       -> (TcDictBinds, 	-- Bindings
		   [Inst])		-- Irreducible ones

bindsAndIrreds avails wanteds
  = go avails EmptyMonoBinds [] wanteds
  where
    go avails binds irreds [] = (binds, irreds)

    go avails binds irreds (w:ws)
      = case lookupFM avails w of
	  Nothing    -> -- Free guys come out here
			-- (If we didn't do addFree we could use this as the
			--  criterion for free-ness, and pick up the free ones here too)
			go avails binds irreds ws

	  Just NoRhs -> go avails binds irreds ws

	  Just Irred -> go (addToFM avails w (BoundTo (instToId w))) binds (w:irreds) ws

	  Just (BoundTo id) -> go avails new_binds irreds ws
			    where
				-- For implicit parameters, all occurrences share the same
				-- Id, so there is no need for synonym bindings
			       new_binds | new_id == id = binds
1046
					 | otherwise	= addBind binds new_id (HsVar id)
1047
1048
			       new_id   = instToId w

1049
	  Just (Rhs rhs ws') -> go avails' (addBind binds id rhs) irreds (ws' ++ ws)
1050
1051
1052
			     where
				id	 = instToId w
				avails'  = addToFM avails w (BoundTo id)
1053
1054

addBind binds id rhs = binds `AndMonoBinds` VarMonoBind id rhs
1055
1056
1057
1058
1059
\end{code}


%************************************************************************
%*									*
1060
\subsection[reduce]{@reduce@}
1061
%*									*
1062
1063
%************************************************************************

1064
1065
1066
1067
1068
When the "what to do" predicate doesn't depend on the quantified type variables,
matters are easier.  We don't need to do any zonking, unless the improvement step
does something, in which case we zonk before iterating.

The "given" set is always empty.
1069

1070
\begin{code}
1071
1072
1073
simpleReduceLoop :: SDoc
	 	 -> (Inst -> WhatToDo)		-- What to do, *not* based on the quantified type variables
		 -> [Inst]			-- Wanted
1074
		 -> TcM ([Inst],		-- Free
1075
1076
1077
1078
1079
1080
1081
1082
1083
			 TcDictBinds,
			 [Inst])		-- Irreducible

simpleReduceLoop doc try_me wanteds
  = mapNF_Tc zonkInst wanteds			`thenNF_Tc` \ wanteds' ->
    reduceContext doc try_me [] wanteds'	`thenTc` \ (no_improvement, frees, binds, irreds) ->
    if no_improvement then
	returnTc (frees, binds, irreds)
    else
1084
1085
	simpleReduceLoop doc try_me (irreds ++ frees)	`thenTc` \ (frees1, binds1, irreds1) ->
	returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
1086
\end{code}
1087

1088
1089
1090
1091
1092
1093
1094
1095


\begin{code}
reduceContext :: SDoc
	      -> (Inst -> WhatToDo)
	      -> [Inst]			-- Given
	      -> [Inst]			-- Wanted
	      -> NF_TcM (Bool, 		-- True <=> improve step did no unification
1096
			 [Inst],	-- Free
1097
1098
1099
1100
1101
			 TcDictBinds,	-- Dictionary bindings
			 [Inst])	-- Irreducible

reduceContext doc try_me givens wanteds
  =
1102
    traceTc (text "reduceContext" <+> (vcat [
1103
	     text "----------------------",
1104
	     doc,
1105
1106
1107
	     text "given" <+> ppr givens,
	     text "wanted" <+> ppr wanteds,
	     text "----------------------"
1108
1109
	     ]))					`thenNF_Tc_`

1110
        -- Build the Avail mapping from "givens"
1111
    foldlNF_Tc addGiven (emptyFM, []) givens		`thenNF_Tc` \ init_state ->
1112
1113

        -- Do the real work
1114
1115
1116
1117
1118
    reduceList (0,[]) try_me wanteds init_state		`thenNF_Tc` \ state@(avails, frees) ->

	-- Do improvement, using everything in avails
	-- In particular, avails includes all superclasses of everything
    tcImprove avails					`thenTc` \ no_improvement ->
1119

1120
    traceTc (text "reduceContext end" <+> (vcat [
1121
	     text "----------------------",
1122
	     doc,
1123
1124
	     text "given" <+> ppr givens,
	     text "wanted" <+> ppr wanteds,
1125
	     text "----",
1126
	     text "avails" <+> pprAvails avails,
1127
	     text "frees" <+> ppr frees,
1128
	     text "no_improvement =" <+> ppr no_improvement,
1129
	     text "----------------------"
1130
1131
1132
1133
	     ])) 					`thenNF_Tc_`
     let
	(binds, irreds) = bindsAndIrreds avails wanteds
     in
1134
     returnTc (no_improvement, frees, binds, irreds)
1135
1136
1137
1138

tcImprove avails
 =  tcGetInstEnv 				`thenTc` \ inst_env ->
    let
1139
1140
1141
1142
1143
1144
	preds = [ (pred, pp_loc)
		| inst <- keysFM avails,
		  let pp_loc = pprInstLoc (instLoc inst),
		  pred <- predsOfInst inst,
		  predHasFDs pred
		]
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
		-- Avails has all the superclasses etc (good)
		-- It also has all the intermediates of the deduction (good)
		-- It does not have duplicates (good)
		-- NB that (?x::t1) and (?x::t2) will be held separately in avails
		--    so that improve will see them separate
	eqns  = improve (classInstEnv inst_env) preds
     in
     if null eqns then
	returnTc True
     else
1155
	traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns))	`thenNF_Tc_`
1156
        mapTc_ unify eqns	`thenTc_`
1157
	returnTc False
1158
  where
1159
1160
1161
1162
    unify ((qtvs, t1, t2), doc)
	 = tcAddErrCtxt doc			$
	   tcInstTyVars (varSetElems qtvs)	`thenNF_Tc` \ (_, _, tenv) ->
	   unifyTauTy (substTy tenv t1) (substTy tenv t2)
1163
\end{code}
1164

1165
1166
1167
The main context-reduction function is @reduce@.  Here's its game plan.

\begin{code}
1168
1169
1170
1171
reduceList :: (Int,[Inst])		-- Stack (for err msgs)
					-- along with its depth
       	   -> (Inst -> WhatToDo)
       	   -> [Inst]
1172
1173
       	   -> RedState
       	   -> TcM RedState
1174
1175
1176
1177
1178
1179
1180
1181
1182
\end{code}

@reduce@ is passed
     try_me:	given an inst, this function returns
		  Reduce       reduce this
		  DontReduce   return this in "irreds"
		  Free	       return this in "frees"

     wanteds:	The list of insts to reduce
1183
     state:	An accumulating parameter of type RedState
1184
		that contains the state of the algorithm
1185

1186
1187
  It returns a RedState.

1188
The (n,stack) pair is just used for error reporting.
1189
1190
1191
n is always the depth of the stack.
The stack is the stack of Insts being reduced: to produce X
I had to produce Y, to produce Y I had to produce Z, and so on.
1192
1193

\begin{code}
1194
1195
1196
reduceList (n,stack) try_me wanteds state
  | n > opt_MaxContextReductionDepth
  = failWithTc (reduceDepthErr n stack)
1197

1198
1199
1200
  | otherwise
  =
#ifdef DEBUG
1201
   (if n > 8 then
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
	pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
    else (\x->x))
#endif
    go wanteds state
  where
    go []     state = returnTc state
    go (w:ws) state = reduce (n+1, w:stack) try_me w state	`thenTc` \ state' ->
		      go ws state'

    -- Base case: we're done!
1212
reduce stack try_me wanted state
1213
    -- It's the same as an existing inst, or a superclass thereof
1214
1215
  | isAvailable state wanted
  = returnTc state
1216

1217
1218
1219
  | otherwise
  = case try_me wanted of {

1220
      DontReduce want_scs -> addIrred want_scs state wanted
1221

1222
1223
    ; DontReduceUnlessConstant ->    -- It's irreducible (or at least should not be reduced)
  				     -- First, see if the inst can be reduced to a constant in one step
1224
	try_simple (addIrred AddSCs)	-- Assume want superclasses
1225

1226
1227
1228
    ; Free ->	-- It's free so just chuck it upstairs
  		-- First, see if the inst can be reduced to a constant in one step
	try_simple addFree
1229

1230
    ; ReduceMe ->		-- It should be reduced
1231
1232
	lookupInst wanted	      `thenNF_Tc` \ lookup_result ->
	case lookup_result of
1233
	    GenInst wanteds' rhs -> reduceList stack try_me wanteds' state	`thenTc` \ state' ->
1234
1235
				    addWanted state' wanted rhs wanteds'
	    SimpleInst rhs       -> addWanted state wanted rhs []
1236

1237
	    NoInstance ->    -- No such instance!
1238
1239
			     -- Add it and its superclasses
		    	     addIrred AddSCs state wanted
1240

1241
1242
1243
1244
1245
1246
1247
1248
    }
  where
    try_simple do_this_otherwise
      = lookupInst wanted	  `thenNF_Tc` \ lookup_result ->
	case lookup_result of
	    SimpleInst rhs -> addWanted state wanted rhs []
	    other	   -> do_this_otherwise state wanted
\end{code}
1249
1250
1251


\begin{code}
1252
1253
1254
isAvailable :: RedState -> Inst -> Bool
isAvailable (avails, _) wanted = wanted `elemFM` avails
	-- NB: the Ord instance of Inst compares by the class/type info
1255
	-- *not* by unique.  So
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
	--	d1::C Int ==  d2::C Int

-------------------------
addFree :: RedState -> Inst -> NF_TcM RedState
	-- 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!
	--
	-- NB1: do *not* add superclasses.  If we have
	--	df::Floating a
	--	dn::Num a
1269
	-- but a is not bound here, then we *don't* want to derive
1270
1271
1272
1273
1274
1275
	-- dn from df here lest we lose sharing.
	--
	-- NB2: do *not* add the Inst to avails at all 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
1276
	--	t1 = truncate at f
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
	--	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!
	-- Solution: never put methods in avail till they are captured
	-- in which case addFree isn't used
	--
	-- NB3: make sure that CCallable/CReturnable use NoRhs rather
	--	than BoundTo, else we end up with bogus bindings.
	--	c.f. instBindingRequired in addWanted
addFree (avails, frees) free
  | isDict free = returnNF_Tc (addToFM avails free avail, free:frees)
  | otherwise   = returnNF_Tc (avails,			  free:frees)
  where
    avail | instBindingRequired free = BoundTo (instToId free)
	  | otherwise		     = NoRhs

addWanted :: RedState -> Inst -> TcExpr -> [Inst] -> NF_TcM RedState
1298
1299
addWanted state@(avails, frees) wanted rhs_expr wanteds
-- Do *not* add superclasses as well.  Here's an example of why not
1300
-- 	class Eq a => Foo a b
1301
1302
1303
--	instance Eq a => Foo [a] a
-- If we are reducing
--	(Foo [t] t)
1304
-- we'll first deduce that it holds (via the instance decl).  We
1305
1306
1307
1308
-- must not then overwrite the Eq t constraint with a superclass selection!
-- 	ToDo: this isn't entirely unsatisfactory, because
--	      we may also lose some entirely-legitimate sharing this way

1309
  = ASSERT( not (isAvailable state wanted) )
1310
    returnNF_Tc (addToFM avails wanted avail, frees)
1311
  where
1312
1313
1314
    avail | instBindingRequired wanted = Rhs rhs_expr wanteds
	  | otherwise		       = ASSERT( null wanteds ) NoRhs

1315
addGiven :: RedState -> Inst -> NF_TcM RedState
1316
addGiven state given = addAvailAndSCs state given (BoundTo (instToId given))
1317

1318
1319
1320
addIrred :: WantSCs -> RedState -> Inst -> NF_TcM RedState
addIrred NoSCs  (avails,frees) irred = returnNF_Tc (addToFM avails irred Irred, frees)
addIrred AddSCs state	       irred = addAvailAndSCs state irred Irred
1321

1322
1323
1324
addAvailAndSCs :: RedState -> Inst -> Avail -> NF_TcM RedState
addAvailAndSCs (avails, frees) wanted avail
  = add_avail_and_scs avails wanted avail	`thenNF_Tc` \ avails' ->
1325
1326
1327
    returnNF_Tc (avails', frees)

---------------------
1328
1329
1330
add_avail_and_scs :: Avails -> Inst -> Avail -> NF_TcM Avails
add_avail_and_scs avails wanted avail
  = add_scs (addToFM avails wanted avail) wanted
1331

1332