TcSimplify.lhs 64.8 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
	tcSimplifyDeriv, tcSimplifyDefault,
15
	bindInstsOfLocalFuns
16
17
    ) where

18
#include "HsVersions.h"
19

20
21
import {-# SOURCE #-} TcUnify( unifyTauTy )

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

27
import TcMonad
28
import Inst		( lookupInst, LookupInstResult(..),
29
			  tyVarsOfInst, predsOfInsts, predsOfInst, newDicts,
30
31
32
			  isDict, isClassDict, isLinearInst, linearInstType,
			  isStdClassTyVarDict, isMethodFor, isMethod,
			  instToId, tyVarsOfInsts,  cloneDict,
33
			  ipNamesOfInsts, ipNamesOfInst, dictPred,
34
			  instBindingRequired, instCanBeGeneralised,
35
			  newDictsFromOld, newMethodAtLoc,
36
			  getDictClassTys, isTyVarDict,
37
			  instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts,
38
			  Inst, LIE, pprInsts, pprInstsInFull,
39
			  mkLIE, lieToList
sof's avatar
sof committed
40
			)
41
import TcEnv		( tcGetGlobalTyVars, tcGetInstEnv, tcLookupGlobalId )
42
import InstEnv		( lookupInstEnv, classInstEnv, InstLookupResult(..) )
43
import TcMType		( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
44
import TcType		( TcTyVar, TcTyVarSet, ThetaType, 
45
			  mkClassPred, isOverloadedTy, mkTyConApp,
46
			  mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
47
			  tyVarsOfPred, isIPPred, isInheritablePred, predHasFDs )
48
import Id		( idType, mkUserLocal )
49
import Var		( TyVar )
50
import Name		( getOccName, getSrcLoc )
51
import NameSet		( NameSet, mkNameSet, elemNameSet )
52
import Class		( classBigSig )
53
import FunDeps		( oclose, grow, improve, pprEquationDoc )
54
import PrelInfo		( isNumericClass, isCreturnableClass, isCcallishClass, 
chak's avatar
chak committed
55
			  splitName, fstName, sndName )
56

57
import Subst		( mkTopTyVarSubst, substTheta, substTy )
58
import TysWiredIn	( unitTy, pairTyCon )
59
import VarSet
60
61
import FiniteMap
import Outputable
62
import ListSetOps	( equivClasses )
63
import Util		( zipEqual )
64
import List		( partition )
65
import CmdLineOpts
66
67
68
69
70
\end{code}


%************************************************************************
%*									*
71
\subsection{NOTES}
72
73
74
%*									*
%************************************************************************

75
	--------------------------------------
76
		Notes on quantification
77
	--------------------------------------
78
79
80
81
82
83

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

	G	the environment
	T	the type of the RHS
84
	C	the constraints from that RHS
85
86
87
88
89
90
91
92
93
94
95

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

96
and float the constraints Ct further outwards.
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
130
131
132
133
134

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
135
		using all conceivable links from C.
136
137
138
139
140
141
142

		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.

143
Notice that
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
   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 ...
164

165
166
167
168
169
170
171
	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

172
  And then if the fn was called at several different c's, each of
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
  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.



196
197
198
	--------------------------------------
		Notes on ambiguity
	--------------------------------------
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
233
234
235
236
237

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.

238
So here's the plan.  We WARN about probable ambiguity if
239
240
241
242
243

	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
244
in the environment, or by the variables in the type.
245
246
247

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

248
	class J a b c | a b -> c
249
250
251
	fv(G) = {a}

Is this ambiguous?
252
	forall b c. (J a b c) => b -> b
253
254

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

257
It's a bit vague exactly which C we should use for this oclose call.  If we
258
259
260
261
262
263
264
265
266
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

267
then c is a "bubble"; there's no way it can ever improve, and it's
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
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.
286
The definitely-ambiguous can then float out, and get smashed at top level
287
288
289
(which squashes out the constants, like Eq (T a) above)


290
	--------------------------------------
291
		Notes on principal types
292
	--------------------------------------
293
294
295

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

297
298
299
300
301
302
303
    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


304
	--------------------------------------
305
		Notes on implicit parameters
306
	--------------------------------------
307

308
309
310
311
312
Question 1: can we "inherit" implicit parameters
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:

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

314
315
316
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:
317

318
319
320
	f :: Int -> Int

(so we get ?y from the context of f's definition), or
321
322
323

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

324
325
326
327
328
329
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.

330
331
BOTTOM LINE: when *inferring types* you *must* quantify 
over implicit parameters. See the predicate isFreeWhenInferring.
332

333
334
335
336
337

Question 2: type signatures
~~~~~~~~~~~~~~~~~~~~~~~~~~~
BUT WATCH OUT: When you supply a type signature, we can't force you
to quantify over implicit parameters.  For example:
338
339
340
341
342
343
344
345
346
347
348

	(?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).
349

350
351
352
What about when you supply a type signature for a binding?
Is it legal to give the following explicit, user type 
signature to f, thus:
353

354
	f :: Int -> Int
355
	f x = (x::Int) + ?y
356

357
At first sight this seems reasonable, but it has the nasty property
358
that adding a type signature changes the dynamic semantics.
359
Consider this:
360

361
	(let f x = (x::Int) + ?y
362
363
364
365
 	 in (f 3, f 3 with ?y=5))  with ?y = 6

		returns (3+6, 3+5)
vs
366
	(let f :: Int -> Int
367
	     f x = x + ?y
368
369
370
371
	 in (f 3, f 3 with ?y=5))  with ?y = 6

		returns (3+6, 3+6)

372
373
Indeed, simply inlining f (at the Haskell source level) would change the
dynamic semantics.
374

375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
Nevertheless, as Launchbury says (email Oct 01) we can't really give the
semantics for a Haskell program without knowing its typing, so if you 
change the typing you may change the semantics.

To make things consistent in all cases where we are *checking* against
a supplied signature (as opposed to inferring a type), we adopt the
rule: 

	a signature does not need to quantify over implicit params.

[This represents a (rather marginal) change of policy since GHC 5.02,
which *required* an explicit signature to quantify over all implicit
params for the reasons mentioned above.]

But that raises a new question.  Consider 

	Given (signature)	?x::Int
	Wanted (inferred)	?x::Int, ?y::Bool

Clearly we want to discharge the ?x and float the ?y out.  But
what is the criterion that distinguishes them?  Clearly it isn't
what free type variables they have.  The Right Thing seems to be
to float a constraint that
	neither mentions any of the quantified type variables
	nor any of the quantified implicit parameters

See the predicate isFreeWhenChecking.
402

403

404
405
406
Question 3: monomorphism
~~~~~~~~~~~~~~~~~~~~~~~~
There's a nasty corner case when the monomorphism restriction bites:
407

408
409
	z = (x::Int) + ?y

410
411
The argument above suggests that we *must* generalise
over the ?y parameter, to get
412
413
	z :: (?y::Int) => Int,
but the monomorphism restriction says that we *must not*, giving
414
	z :: Int.
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
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:
431
	* Inlining remains valid
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
	* 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.
469

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

472
	z = (x::Int) + ?y
473

474
475
476
477
478
479
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.
480

481
Choice (C) really says "the monomorphism restriction doesn't apply
482
to implicit parameters".  Which is fine, but remember that every
483
484
485
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'
486
clauses that bind ?y, so a decent compiler should common up all
487
488
489
those function calls.  So I think I strongly favour (C).  Indeed,
one could make a similar argument for abolishing the monomorphism
restriction altogether.
490

491
BOTTOM LINE: we choose (B) at present.  See tcSimplifyRestricted
492

493

494

495
496
497
498
499
500
501
502
503
%************************************************************************
%*									*
\subsection{tcSimplifyInfer}
%*									*
%************************************************************************

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

    1. Compute Q = grow( fvs(T), C )
504
505

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

508
    3. Try improvement, using functional dependencies
509

510
511
512
513
    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
514
Eq (a,b), we don't simplify to (Eq a, Eq b).  So Q won't be different
515
516
517
518
519
520
521
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 ...
522

523
524
525
526
527
528
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
529
again.
530

531
532

\begin{code}
533
tcSimplifyInfer
534
535
	:: SDoc
	-> TcTyVarSet		-- fv(T); type vars
536
537
538
539
540
541
	-> LIE			-- Wanted
	-> TcM ([TcTyVar],	-- Tyvars to quantify (zonked)
		LIE,		-- Free
		TcDictBinds,	-- Bindings
		[TcId])		-- Dict Ids that must be bound here (zonked)
\end{code}
542

543
544
545

\begin{code}
tcSimplifyInfer doc tau_tvs wanted_lie
546
  = inferLoop doc (varSetElems tau_tvs)
547
	      (lieToList wanted_lie)	`thenTc` \ (qtvs, frees, binds, irreds) ->
548
549

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

552
    returnTc (qtvs, mkLIE frees, binds, map instToId irreds)
553
554
555
556
557
558

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 ->
559
    let
560
561
 	preds = predsOfInsts wanteds'
	qtvs  = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
562
563

	try_me inst
564
565
566
	  | isFreeWhenInferring qtvs inst = Free
	  | isClassDict inst 		  = DontReduceUnlessConstant	-- Dicts
	  | otherwise	    		  = ReduceMe 			-- Lits and Methods
567
    in
568
569
		-- Step 2
    reduceContext doc try_me [] wanteds'    `thenTc` \ (no_improvement, frees, binds, irreds) ->
570

571
572
		-- Step 3
    if no_improvement then
573
	returnTc (varSetElems qtvs, frees, binds, irreds)
574
    else
575
576
577
578
579
580
581
582
583
584
585
586
	-- 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)

587
588
589
	-- However, NOTICE that when we are done, we might have some bindings, but
	-- the final qtvs might be empty.  See [NO TYVARS] below.
				
590
591
	inferLoop doc tau_tvs (irreds ++ frees)	`thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
	returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
592
\end{code}
593

594
595
596
597
598
599
600
601
602
603
604
605
606
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)
607
and improve by binding l->T, after which we can do some reduction
608
609
610
on both the Lte and If constraints.  What we *can't* do is start again
with (Max Z (S x) y)!

611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
[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
630
631
632
polymorphic in.  

The net effect of [NO TYVARS] 
633

634
\begin{code}
635
636
637
isFreeWhenInferring :: TyVarSet -> Inst	-> Bool
isFreeWhenInferring qtvs inst
  =  isFreeWrtTyVars qtvs inst			-- Constrains no quantified vars
638
  && all isInheritablePred (predsOfInst inst)	-- And no implicit parameter involved
639
640
641
642
643
644
645
646
647
648
649
						-- (see "Notes on implicit parameters")

isFreeWhenChecking :: TyVarSet	-- Quantified tyvars
	 	   -> NameSet	-- Quantified implicit parameters
		   -> Inst -> Bool
isFreeWhenChecking qtvs ips inst
  =  isFreeWrtTyVars qtvs inst
  && isFreeWrtIPs    ips inst

isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
isFreeWrtIPs     ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
650
\end{code}
651

652

653
654
655
656
657
%************************************************************************
%*									*
\subsection{tcSimplifyCheck}
%*									*
%************************************************************************
658

659
@tcSimplifyCheck@ is used when we know exactly the set of variables
660
we are going to quantify over.  For example, a class or instance declaration.
661
662

\begin{code}
663
tcSimplifyCheck
664
	 :: SDoc
665
666
	 -> [TcTyVar]		-- Quantify over these
	 -> [Inst]		-- Given
667
	 -> LIE			-- Wanted
668
	 -> TcM (LIE,		-- Free
669
		 TcDictBinds)	-- Bindings
670

671
-- tcSimplifyCheck is used when checking expression type signatures,
672
673
674
675
-- 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!
676
tcSimplifyCheck doc qtvs givens wanted_lie
677
  = tcSimplCheck doc get_qtvs
678
679
680
681
682
683
684
685
686
687
		 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
688
	 :: SDoc
689
690
691
692
693
694
695
696
	 -> 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
697
  = tcSimplCheck doc get_qtvs givens wanted_lie
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
  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
715
			-- soundness, and it'll only affect which tyvars, not which
716
717
718
719
720
721
722
			-- dictionaries, we quantify over
	       in
	       returnNF_Tc qtvs
\end{code}

Here is the workhorse function for all three wrappers.

723
\begin{code}
724
tcSimplCheck doc get_qtvs givens wanted_lie
725
  = check_loop givens (lieToList wanted_lie)	`thenTc` \ (qtvs, frees, binds, irreds) ->
726

727
	-- Complain about any irreducible ones
728
    complainCheck doc givens irreds		`thenNF_Tc_`
729

730
	-- Done
731
    returnTc (qtvs, mkLIE frees, binds)
732

733
  where
734
735
    ip_set = mkNameSet (ipNamesOfInsts givens)

736
737
738
739
    check_loop givens wanteds
      =		-- Step 1
    	mapNF_Tc zonkInst givens	`thenNF_Tc` \ givens' ->
    	mapNF_Tc zonkInst wanteds	`thenNF_Tc` \ wanteds' ->
740
741
    	get_qtvs 			`thenNF_Tc` \ qtvs' ->

742
743
744
745
 		    -- Step 2
    	let
 	    -- When checking against a given signature we always reduce
 	    -- until we find a match against something given, or can't reduce
746
747
 	    try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free
 			| otherwise  			       = ReduceMe
748
749
    	in
    	reduceContext doc try_me givens' wanteds'	`thenTc` \ (no_improvement, frees, binds, irreds) ->
750

751
752
753
754
755
756
 		    -- 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)
757
758
759
\end{code}


760
761
762
763
764
765
766
767
%************************************************************************
%*									*
\subsection{tcSimplifyRestricted}
%*									*
%************************************************************************

\begin{code}
tcSimplifyRestricted 	-- Used for restricted binding groups
768
			-- i.e. ones subject to the monomorphism restriction
769
	:: SDoc
770
	-> TcTyVarSet		-- Free in the type of the RHSs
771
772
773
774
775
776
777
	-> 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
778
   	-- We can't just take the free vars of wanted_lie because that'll
779
780
781
782
783
784
785
	-- 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
786
787
788
789
790
791
	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.
792
    in
793
    simpleReduceLoop doc try_me wanteds		`thenTc` \ (_, _, constrained_dicts) ->
794
795

	-- Next, figure out the tyvars we will quantify over
796
797
    zonkTcTyVarsAndFV (varSetElems tau_tvs)	`thenNF_Tc` \ tau_tvs' ->
    tcGetGlobalTyVars				`thenNF_Tc` \ gbl_tvs ->
798
    let
799
800
	constrained_tvs = tyVarsOfInsts constrained_dicts
	qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts constrained_dicts) gbl_tvs)
801
802
803
804
805
806
807
			 `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.
	--
808
	-- We quantify only over constraints that are captured by qtvs;
809
	-- these will just be a subset of non-dicts.  This in contrast
810
	-- to normal inference (using isFreeWhenInferring) in which we quantify over
811
	-- all *non-inheritable* constraints too.  This implements choice
812
	-- (B) under "implicit parameter and monomorphism" above.
813
814
815
816
	--
	-- Remember that we may need to do *some* simplification, to
	-- (for example) squash {Monad (ST s)} into {}.  It's not enough
	-- just to float all constraints
817
818
    mapNF_Tc zonkInst (lieToList wanted_lie)	`thenNF_Tc` \ wanteds' ->
    let
819
820
        try_me inst | isFreeWrtTyVars qtvs inst = Free
	            | otherwise                 = ReduceMe
821
822
823
824
    in
    reduceContext doc try_me [] wanteds'	`thenTc` \ (no_improvement, frees, binds, irreds) ->
    ASSERT( no_improvement )
    ASSERT( null irreds )
825
	-- No need to loop because simpleReduceLoop will have
826
827
828
829
830
	-- already done any improvement necessary

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

831
832
833
834
835
836
837

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

838
839
840
841
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.

842
The same thing is used for specialise pragmas. Consider
843

844
845
846
847
848
849
850
851
852
853
854
855
	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)

856
But that means that we must simplify the Method for f to (f Int dNumInt)!
857
858
So tcSimplifyToDicts squeezes out all Methods.

859
860
861
862
863
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 #-}

864
Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
865
866
867
868
869
870
871
872
873
874
875
876
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"

877
\begin{code}
878
tcSimplifyToDicts :: LIE -> TcM ([Inst], TcDictBinds)
879
tcSimplifyToDicts wanted_lie
880
  = simpleReduceLoop doc try_me wanteds		`thenTc` \ (frees, binds, irreds) ->
881
	-- Since try_me doesn't look at types, we don't need to
882
	-- do any zonking, so it's safe to call reduceContext directly
883
    ASSERT( null frees )
884
885
    returnTc (irreds, binds)

886
  where
887
    doc = text "tcSimplifyToDicts"
888
    wanteds = lieToList wanted_lie
889
890

	-- Reduce methods and lits only; stop as soon as we get a dictionary
891
892
    try_me inst	| isDict inst = DontReduce NoSCs
		| otherwise   = ReduceMe
893
894
\end{code}

895

896
897
898
899
900
901
902
903
904
905
%************************************************************************
%*									*
\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
906
step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.
907
908
909
910
911
912

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

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

913
then the constraint (?x::Int) arising from the call to f will
914
force the binding for ?x to be of type Int.
915
916

\begin{code}
917
tcSimplifyIPs :: [Inst]		-- The implicit parameters bound here
918
919
	      -> LIE
	      -> TcM (LIE, TcDictBinds)
920
921
tcSimplifyIPs given_ips wanted_lie
  = simpl_loop given_ips wanteds	`thenTc` \ (frees, binds) ->
922
    returnTc (mkLIE frees, binds)
923
  where
924
    doc	     = text "tcSimplifyIPs" <+> ppr given_ips
925
    wanteds  = lieToList wanted_lie
926
    ip_set   = mkNameSet (ipNamesOfInsts given_ips)
927

928
	-- Simplify any methods that mention the implicit parameter
929
930
    try_me inst | isFreeWrtIPs ip_set inst = Free
		| otherwise		   = ReduceMe
931
932
933
934

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

936
937
938
939
940
941
942
943
        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)
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
\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
976
  | null overloaded_ids
977
978
979
980
	-- Common case
  = returnTc (init_lie, EmptyMonoBinds)

  | otherwise
981
  = simpleReduceLoop doc try_me wanteds		`thenTc` \ (frees, binds, irreds) ->
982
    ASSERT( null irreds )
983
    returnTc (mkLIE frees, binds)
984
985
986
987
  where
    doc		     = text "bindInsts" <+> ppr local_ids
    wanteds	     = lieToList init_lie
    overloaded_ids   = filter is_overloaded local_ids
988
    is_overloaded id = isOverloadedTy (idType id)
989
990

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

994
    try_me inst | isMethodFor overloaded_set inst = ReduceMe
995
		| otherwise		          = Free
996
\end{code}
997

998

999
1000
%************************************************************************
%*									*
1001
\subsection{Data types for the reduction mechanism}
1002
1003
1004
%*									*
%************************************************************************

1005
1006
The main control over context reduction is here

1007
\begin{code}
1008
data WhatToDo
1009
1010
 = ReduceMe		-- Try to reduce this
			-- If there's no instance, behave exactly like
1011
1012
			-- DontReduce: add the inst to
			-- the irreductible ones, but don't
1013
1014
			-- produce an error message of any kind.
			-- It might be quite legitimate such as (Eq a)!
1015

1016
 | DontReduce WantSCs		-- Return as irreducible
1017
1018
1019

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

1021
 | Free			  -- Return as free
1022

1023
1024
1025
reduceMe :: Inst -> WhatToDo
reduceMe inst = ReduceMe

1026
1027
data WantSCs = NoSCs | AddSCs	-- Tells whether we should add the superclasses
				-- of a predicate when adding it to the avails
1028
\end{code}
1029
1030
1031
1032



\begin{code}
1033
type Avails = FiniteMap Inst Avail
1034

1035
data Avail
1036
1037
  = IsFree		-- Used for free Insts
  | Irred		-- Used for irreducible dictionaries,
1038
1039
			-- which are going to be lambda bound

1040
  | Given TcId 		-- Used for dictionaries for which we have a binding
1041
			-- e.g. those "given" in a signature
1042
	  Bool		-- True <=> actually consumed (splittable IPs only)
1043
1044

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

1047
  | Rhs 		-- Used when there is a RHS
1048
1049
	TcExpr	 	-- The RHS
	[Inst]		-- Insts free in the RHS; we need these too
1050

1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
  | Linear 		-- Splittable Insts only.
	Int		-- The Int is always 2 or more; indicates how
			-- many copies are required
	Inst 		-- The splitter
	Avail		-- Where the "master copy" is

  | LinRhss		-- Splittable Insts only; this is used only internally
			-- 	by extractResults, where a Linear 
			--	is turned into an LinRhss
	[TcExpr]	-- A supply of suitable RHSs

1062
pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
1063
			| (inst,avail) <- fmToList avails ]
1064
1065
1066
1067

instance Outputable Avail where
    ppr = pprAvail

1068
1069
1070
1071
1072
1073
1074
1075
pprAvail NoRhs	       	= text "<no rhs>"
pprAvail IsFree	       	= text "Free"
pprAvail Irred	       	= text "Irred"
pprAvail (Given x b)   	= text "Given" <+> ppr x <+> 
		 	  if b then text "(used)" else empty
pprAvail (Rhs rhs bs)   = text "Rhs" <+> ppr rhs <+> braces (ppr bs)
pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a
pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss
1076
1077
1078
1079
1080
1081
1082
1083
1084
\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}
1085
extractResults :: Avails
1086
	       -> [Inst]		-- Wanted
1087
1088
1089
	       -> NF_TcM (TcDictBinds, 	-- Bindings
			  [Inst],	-- Irreducible ones
			  [Inst])	-- Free ones
1090

1091
1092
extractResults avails wanteds
  = go avails EmptyMonoBinds [] [] wanteds
1093
  where
1094
1095
    go avails binds irreds frees [] 
      = returnNF_Tc (binds, irreds, frees)
1096

1097
    go avails binds irreds frees (w:ws)
1098
      = case lookupFM avails w of
1099
1100
	  Nothing    -> pprTrace "Urk: extractResults" (ppr w) $
			go avails binds irreds frees ws
1101

1102
1103
1104
	  Just NoRhs  -> go avails		 binds irreds     frees     ws
	  Just IsFree -> go (add_free avails w)  binds irreds     (w:frees) ws
	  Just Irred  -> go (add_given avails w) binds (w:irreds) frees     ws
1105

1106
	  Just (Given id _) -> go avails new_binds irreds frees ws
1107
			    where
1108
1109
1110
1111
			       new_binds | id == instToId w = binds
					 | otherwise        = addBind binds w (HsVar id)
		-- The sought Id can be one of the givens, via a superclass chain
		-- and then we definitely don't want to generate an x=x binding!
1112

1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
	  Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws)
			     where
				new_binds = addBind binds w rhs

	  Just (LinRhss (rhs:rhss))	-- Consume one of the Rhss
		-> go new_avails new_binds irreds frees ws
		where		
		   new_binds  = addBind binds w rhs
		   new_avails = addToFM avails w (LinRhss rhss)

	  Just (Linear n split_inst avail)
	    -> split n (instToId split_inst) avail w	`thenNF_Tc` \ (binds', (rhs:rhss), irreds') ->
	       go (addToFM avails w (LinRhss rhss))
		  (binds `AndMonoBinds` addBind binds' w rhs)
		  (irreds' ++ irreds) frees (split_inst:ws)


    add_given avails w 
	| instBindingRequired w = addToFM avails w (Given (instToId w) True)
	| otherwise		= addToFM avails w NoRhs
	-- NB: make sure that CCallable/CReturnable use NoRhs rather
	--	than Given, else we end up with bogus bindings.

    add_free avails w | isMethod w = avails
		      | otherwise  = add_given avails w
	-- NB: Hack alert!  
	-- Do *not* replace Free by Given 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
	--	t1 = truncate at f
	--	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!
	-- (split n i a) returns: n rhss
	--			  auxiliary bindings
	--			  1 or 0 insts to add to irreds


split :: Int -> TcId -> Avail -> Inst 
      -> NF_TcM (TcDictBinds, [TcExpr], [Inst])
-- (split n split_id avail wanted) returns
--	* a list of 'n' expressions, all of which witness 'avail'
--	* a bunch of auxiliary bindings to support these expressions
--	* one or zero insts needed to witness the whole lot
--	  (maybe be zero if the initial Inst is a Given)
split n split_id avail wanted
  = go n
  where
    ty  = linearInstType wanted
    pair_ty = mkTyConApp pairTyCon [ty,ty]
    id  = instToId wanted
    occ = getOccName id
    loc = getSrcLoc id

    go 1 = case avail of
	     Given id _ -> returnNF_Tc (EmptyMonoBinds, [HsVar id], [])
	     Irred      -> cloneDict wanted		`thenNF_Tc` \ w' ->
			   returnNF_Tc (EmptyMonoBinds, [HsVar (instToId w')], [w'])

    go n = go ((n+1) `div` 2)		`thenNF_Tc` \ (binds1, rhss, irred) ->
	   expand n rhss		`thenNF_Tc` \ (binds2, rhss') ->
	   returnNF_Tc (binds1 `AndMonoBinds` binds2, rhss', irred)

	-- (expand n rhss) 
	-- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
	--  e.g.  expand 3 [rhs1, rhs2]
	--	  = ( { x = split rhs1 },
	--	      [fst x, snd x, rhs2] )
    expand n rhss
	| n `rem` 2 == 0 = go rhss 	-- n is even
	| otherwise  	 = go (tail rhss)	`thenNF_Tc` \ (binds', rhss') ->
			   returnNF_Tc (binds', head rhss : rhss')
	where
	  go rhss = mapAndUnzipNF_Tc do_one rhss	`thenNF_Tc` \ (binds', rhss') ->
		    returnNF_Tc (andMonoBindList binds', concat rhss')

	  do_one rhs = tcGetUnique 			`thenNF_Tc` \ uniq -> 
chak's avatar
chak committed
1195
1196
		       tcLookupGlobalId fstName		`thenNF_Tc` \ fst_id ->
		       tcLookupGlobalId sndName		`thenNF_Tc` \ snd_id ->
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
		       let 
			  x = mkUserLocal occ uniq pair_ty loc
		       in
		       returnNF_Tc (VarMonoBind x (mk_app split_id rhs),
				    [mk_fs_app fst_id ty x, mk_fs_app snd_id ty x])

mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var

mk_app id rhs = HsApp (HsVar id) rhs

addBind binds inst rhs = binds `AndMonoBinds` VarMonoBind (instToId inst) rhs
1208
1209
1210
1211
1212
\end{code}


%************************************************************************
%*									*
1213
\subsection[reduce]{@reduce@}
1214
%*									*
1215
1216
%************************************************************************

1217
1218
1219
1220
1221
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.
1222

1223
\begin{code}
1224
1225
1226
simpleReduceLoop :: SDoc
	 	 -> (Inst -> WhatToDo)		-- What to do, *not* based on the quantified type variables
		 -> [Inst]			-- Wanted
1227
		 -> TcM ([Inst],		-- Free
1228
1229
1230
1231
1232
1233
1234
1235
1236
			 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
1237
1238
	simpleReduceLoop doc try_me (irreds ++ frees)	`thenTc` \ (frees1, binds1, irreds1) ->
	returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
1239
\end{code}
1240

1241
1242
1243
1244
1245
1246
1247
1248


\begin{code}
reduceContext :: SDoc
	      -> (Inst -> WhatToDo)
	      -> [Inst]			-- Given
	      -> [Inst]			-- Wanted
	      -> NF_TcM (Bool, 		-- True <=> improve step did no unification
1249
			 [Inst],	-- Free
1250
1251
1252
1253
1254
			 TcDictBinds,	-- Dictionary bindings
			 [Inst])	-- Irreducible

reduceContext doc try_me givens wanteds
  =
1255
    traceTc (text "reduceContext" <+> (vcat [
1256
	     text "----------------------",
1257
	     doc,
1258
1259
1260
	     text "given" <+> ppr givens,
	     text "wanted" <+> ppr wanteds,
	     text "----------------------"
1261
1262
	     ]))					`thenNF_Tc_`

1263
        -- Build the Avail mapping from "givens"
1264
    foldlNF_Tc addGiven emptyFM givens			`thenNF_Tc` \ init_state ->
1265
1266

        -- Do the real work
1267
    reduceList (0,[]) try_me wanteds init_state		`thenNF_Tc` \ avails ->
1268
1269
1270
1271

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

1273
1274
    extractResults avails wanteds			`thenNF_Tc` \ (binds, irreds, frees) ->

1275
    traceTc (text "reduceContext end" <+> (vcat [
1276
	     text "----------------------",
1277
	     doc,
1278
1279
	     text "given" <+> ppr givens,
	     text "wanted" <+> ppr wanteds,
1280
	     text "----",
1281
	     text "avails" <+> pprAvails avails,
1282
	     text "frees" <+> ppr frees,
1283
	     text "no_improvement =" <+> ppr no_improvement,
1284
	     text "----------------------"
1285
	     ])) 					`thenNF_Tc_`
1286
1287

    returnTc (no_improvement, frees, binds, irreds)
1288
1289
1290
1291

tcImprove avails
 =  tcGetInstEnv 				`thenTc` \ inst_env ->
    let
1292
1293
1294
1295
1296
1297
	preds = [ (pred, pp_loc)
		| inst <- keysFM avails,
		  let pp_loc = pprInstLoc (instLoc inst),
		  pred <- predsOfInst inst,
		  predHasFDs pred
		]
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
		-- 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
1308
	traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns))	`thenNF_Tc_`
1309
        mapTc_ unify eqns	`thenTc_`
1310
	returnTc False
1311
  where
1312
1313
1314
1315
    unify ((qtvs, t1, t2), doc)
	 = tcAddErrCtxt doc			$
	   tcInstTyVars (varSetElems qtvs)	`thenNF_Tc` \ (_, _, tenv) ->
	   unifyTauTy (substTy tenv t1) (substTy tenv t2)
1316
\end{code}
1317

1318
1319
1320
The main context-reduction function is @reduce@.  Here's its game plan.

\begin{code}
1321
1322
1323
1324
reduceList :: (Int,[Inst])		-- Stack (for err msgs)
					-- along with its depth
       	   -> (Inst -> WhatToDo)
       	   -> [Inst]
1325
1326
       	   -> Avails
       	   -> TcM Avails
1327
1328
1329
1330
1331
1332
1333
1334
1335
\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
1336
     state:	An accumulating parameter of type Avails
1337
		that contains the state of the algorithm
1338

1339
  It returns a Avails.
1340

1341
The (n,stack) pair is just used for error reporting.
1342
1343
1344
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.
1345
1346

\begin{code}