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

\begin{code}
7
module TcBinds ( tcBindsAndThen, tcTopBinds,
8
	         tcSpecSigs, tcBindWithSigs ) where
9

10
#include "HsVersions.h"
11

12
import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
sof's avatar
sof committed
13
import {-# SOURCE #-} TcExpr  ( tcExpr )
14

15
import CmdLineOpts	( opt_NoMonomorphismRestriction )
16
17
18
import HsSyn		( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), 
			  Match(..), HsMatchContext(..), 
			  collectMonoBinders, andMonoBinds
19
			)
sof's avatar
sof committed
20
import RnHsSyn		( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
21
import TcHsSyn		( TcMonoBinds, TcId, zonkId, mkHsLet )
22

23
import TcMonad
24
25
import Inst		( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
			  newDicts, instToId
26
			)
27
import TcEnv		( tcExtendLocalValEnv,
28
			  newSpecPragmaId, newLocalId
29
			)
30
import TcSimplify	( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyRestricted, tcSimplifyToDicts )
31
import TcMonoType	( tcHsSigType, checkSigTyVars,
32
			  TcSigInfo(..), tcTySig, maybeSig, sigCtxt
33
			)
34
import TcPat		( tcPat )
35
import TcSimplify	( bindInstsOfLocalFuns )
36
import TcType		( newTyVarTy, newTyVar, 
37
			  zonkTcTyVarToTyVar
38
			)
39
40
import TcUnify		( unifyTauTy, unifyTauTyLists )

41
import CoreFVs		( idFreeTyVars )
42
import Id		( mkLocalId, setInlinePragma )
43
import Var		( idType, idName )
44
45
import IdInfo		( InlinePragInfo(..) )
import Name		( Name, getOccName, getSrcLoc )
46
import NameSet
47
import Type		( mkTyVarTy, tyVarsOfTypes,
48
			  mkForAllTys, mkFunTys, tyVarsOfType, 
49
			  mkPredTy, mkForAllTy, isUnLiftedType, 
50
			  unliftedTypeKind, liftedTypeKind, openTypeKind
51
			)
52
import Var		( tyVarKind )
53
54
55
import VarSet
import Bag
import Util		( isIn )
56
import ListSetOps	( minusList )
57
import Maybes		( maybeToBool )
58
import BasicTypes	( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel )
59
import FiniteMap	( listToFM, lookupFM )
60
import Outputable
61
\end{code}
62

63

64
65
66
67
68
69
%************************************************************************
%*									*
\subsection{Type-checking bindings}
%*									*
%************************************************************************

70
@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
71
72
73
74
75
76
77
78
79
80
it needs to know something about the {\em usage} of the things bound,
so that it can create specialisations of them.  So @tcBindsAndThen@
takes a function which, given an extended environment, E, typechecks
the scope of the bindings returning a typechecked thing and (most
important) an LIE.  It is this LIE which is then used as the basis for
specialising the things bound.

@tcBindsAndThen@ also takes a "combiner" which glues together the
bindings and the "thing" to make a new "thing".

81
The real work is done by @tcBindWithSigsAndThen@.
82
83
84
85
86
87
88
89
90
91

Recursive and non-recursive binds are handled in essentially the same
way: because of uniques there are no scoping issues left.  The only
difference is that non-recursive bindings can bind primitive values.

Even for non-recursive binding groups we add typings for each binder
to the LVE for the following reason.  When each individual binding is
checked the type of its LHS is unified with that of its RHS; and
type-checking the LHS of course requires that the binder is in scope.

92
93
94
At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.

95
\begin{code}
96
97
98
99
100
101
102
103
104
105
tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE)
tcTopBinds binds
  = tc_binds_and_then TopLevel glue binds	$
    tcGetEnv					`thenNF_Tc` \ env ->
    returnTc ((EmptyMonoBinds, env), emptyLIE)
  where
    glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing)


tcBindsAndThen
106
	:: (RecFlag -> TcMonoBinds -> thing -> thing)		-- Combinator
107
	-> RenamedHsBinds
108
109
	-> TcM (thing, LIE)
	-> TcM (thing, LIE)
sof's avatar
sof committed
110

111
tcBindsAndThen = tc_binds_and_then NotTopLevel
sof's avatar
sof committed
112

113
114
115
116
tc_binds_and_then top_lvl combiner EmptyBinds do_next
  = do_next
tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
  = do_next
sof's avatar
sof committed
117

118
119
120
121
tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
  = tc_binds_and_then top_lvl combiner b1	$
    tc_binds_and_then top_lvl combiner b2	$
    do_next
122

123
tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
124
  =   	-- TYPECHECK THE SIGNATURES
125
      mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs]	`thenTc` \ tc_ty_sigs ->
126
  
127
128
      tcBindWithSigs top_lvl bind tc_ty_sigs
		     sigs is_rec 			`thenTc` \ (poly_binds, poly_lie, poly_ids) ->
129
130
  
	  -- Extend the environment to bind the new polymorphic Ids
131
      tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
132
133
  
	  -- Build bindings and IdInfos corresponding to user pragmas
134
      tcSpecSigs sigs		`thenTc` \ (prag_binds, prag_lie) ->
135
136
137
138
139
140

	-- Now do whatever happens next, in the augmented envt
      do_next			`thenTc` \ (thing, thing_lie) ->

	-- Create specialisations of functions bound here
	-- We want to keep non-recursive things non-recursive
141
	-- so that we desugar unlifted bindings correctly
142
143
144
145
146
147
      case (top_lvl, is_rec) of

		-- For the top level don't bother will all this bindInstsOfLocalFuns stuff
		-- All the top level things are rec'd together anyway, so it's fine to
		-- leave them to the tcSimplifyTop, and quite a bit faster too
	(TopLevel, _)
148
		-> returnTc (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
			     thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)

	(NotTopLevel, NonRecursive) 
		-> bindInstsOfLocalFuns 
				(thing_lie `plusLIE` prag_lie)
				poly_ids			`thenTc` \ (thing_lie', lie_binds) ->

		   returnTc (
			combiner NonRecursive poly_binds $
			combiner NonRecursive prag_binds $
			combiner Recursive lie_binds  $
				-- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
				-- aren't guaranteed in dependency order (though we could change
				-- that); hence the Recursive marker.
			thing,

			thing_lie' `plusLIE` poly_lie
		   )

	(NotTopLevel, Recursive)
		-> bindInstsOfLocalFuns 
				(thing_lie `plusLIE` poly_lie `plusLIE` prag_lie) 
				poly_ids			`thenTc` \ (final_lie, lie_binds) ->

		   returnTc (
			combiner Recursive (
				poly_binds `andMonoBinds`
				lie_binds  `andMonoBinds`
				prag_binds) thing,
			final_lie
179
		   )
180
181
\end{code}

182

183
184
%************************************************************************
%*									*
sof's avatar
sof committed
185
\subsection{tcBindWithSigs}
186
187
188
%*									*
%************************************************************************

sof's avatar
sof committed
189
190
191
192
193
194
195
196
197
@tcBindWithSigs@ deals with a single binding group.  It does generalisation,
so all the clever stuff is in here.

* binder_names and mbind must define the same set of Names

* The Names in tc_ty_sigs must be a subset of binder_names

* The Ids in tc_ty_sigs don't necessarily have to have the same name
  as the Name in the tc_ty_sig
198

199
\begin{code}
sof's avatar
sof committed
200
tcBindWithSigs	
201
	:: TopLevelFlag
sof's avatar
sof committed
202
	-> RenamedMonoBinds
203
	-> [TcSigInfo]
204
	-> [RenamedSig]		-- Used solely to get INLINE, NOINLINE sigs
sof's avatar
sof committed
205
	-> RecFlag
206
	-> TcM (TcMonoBinds, LIE, [TcId])
sof's avatar
sof committed
207

208
tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
sof's avatar
sof committed
209
  = recoverTc (
210
	-- If typechecking the binds fails, then return with each
sof's avatar
sof committed
211
	-- signature-less binder given type (forall a.a), to minimise subsequent
212
	-- error messages
213
	newTyVar liftedTypeKind		`thenNF_Tc` \ alpha_tv ->
214
	let
215
	  forall_a_a    = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
216
          binder_names  = collectMonoBinders mbind
217
	  poly_ids      = map mk_dummy binder_names
sof's avatar
sof committed
218
	  mk_dummy name = case maybeSig tc_ty_sigs name of
219
			    Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id	-- Signature
220
			    Nothing -> mkLocalId name forall_a_a          	-- No signature
221
	in
sof's avatar
sof committed
222
	returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
223
    )						$
224

225
	-- TYPECHECK THE BINDINGS
226
    tcMonoBinds mbind tc_ty_sigs is_rec		`thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
sof's avatar
sof committed
227
    let
228
	tau_tvs = varSetElems (foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids)
sof's avatar
sof committed
229
    in
230

231
232
233
	-- GENERALISE
    generalise binder_names mbind tau_tvs lie_req tc_ty_sigs
				`thenTc` \ (tc_tyvars_to_gen, lie_free, dict_binds, dict_ids) ->
234

235

236
237
238
239
240
241
242
243
	-- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
	-- This commits any unbound kind variables to boxed kind, by unification
	-- It's important that the final quanfified type variables
	-- are fully zonked, *including boxity*, because they'll be 
	-- included in the forall types of the polymorphic Ids.
	-- At calls of these Ids we'll instantiate fresh type variables from
	-- them, and we use their boxity then.
    mapNF_Tc zonkTcTyVarToTyVar tc_tyvars_to_gen	`thenNF_Tc` \ real_tyvars_to_gen ->
244

245
246
247
248
249
250
251
252
253
254
255
256
	-- ZONK THE Ids
	-- It's important that the dict Ids are zonked, including the boxity set
	-- in the previous step, because they are later used to form the type of 
	-- the polymorphic thing, and forall-types must be zonked so far as 
	-- their bound variables are concerned
    mapNF_Tc zonkId dict_ids				`thenNF_Tc` \ zonked_dict_ids ->
    mapNF_Tc zonkId mono_ids				`thenNF_Tc` \ zonked_mono_ids ->

	-- CHECK FOR BOGUS UNLIFTED BINDINGS
    checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids	`thenTc_`

	-- BUILD THE POLYMORPHIC RESULT IDs
257
    let
258
	exports  = zipWith mk_export binder_names zonked_mono_ids
259
	dict_tys = map idType zonked_dict_ids
260

261
262
263
264
265
266
267
268
	inlines    = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
        no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
			       [(name, IMustNotBeINLINEd True  phase) | InlineSig   name phase loc <- inline_sigs, maybeToBool phase])
		-- "INLINE n foo" means inline foo, but not until at least phase n
		-- "NOINLINE n foo" means don't inline foo until at least phase n, and even 
		--		    then only if it is small enough etc.
		-- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
		-- See comments in CoreUnfold.blackListed for the Authorised Version
269

270
271
	mk_export binder_name zonked_mono_id
	  = (tyvars, 
272
	     attachNoInlinePrag no_inlines poly_id,
273
	     zonked_mono_id)
274
	  where
sof's avatar
sof committed
275
	    (tyvars, poly_id) = 
276
277
278
		case maybeSig tc_ty_sigs binder_name of
		  Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) -> 
			(sig_tyvars, sig_poly_id)
279
		  Nothing -> (real_tyvars_to_gen, new_poly_id)
sof's avatar
sof committed
280

281
	    new_poly_id = mkLocalId binder_name poly_ty
282
	    poly_ty = mkForAllTys real_tyvars_to_gen
283
			$ mkFunTys dict_tys 
284
			$ idType zonked_mono_id
285
286
287
288
289
		-- It's important to build a fully-zonked poly_ty, because
		-- we'll slurp out its free type variables when extending the
		-- local environment (tcExtendLocalValEnv); if it's not zonked
		-- it appears to have free tyvars that aren't actually free 
		-- at all.
290
    in
sof's avatar
sof committed
291

292
293
294
    traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
	     exports, [idType poly_id | (_, poly_id, _) <- exports])) `thenTc_`

295
296
	 -- BUILD RESULTS
    returnTc (
297
298
299
300
301
302
303
	AbsBinds real_tyvars_to_gen
		 zonked_dict_ids
		 exports
		 inlines
		 (dict_binds `andMonoBinds` mbind'),
	lie_free,
	[poly_id | (_, poly_id, _) <- exports]
304
    )
305
306

attachNoInlinePrag no_inlines bndr
307
308
309
  = case lookupFM no_inlines (idName bndr) of
	Just prag -> bndr `setInlinePragma` prag
	Nothing   -> bndr
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347

checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids
  = ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
		-- The instCantBeGeneralised stuff in tcSimplify should have
		-- already raised an error if we're trying to generalise an 
		-- unboxed tyvar (NB: unboxed tyvars are always introduced 
		-- along with a class constraint) and it's better done there 
		-- because we have more precise origin information.
		-- That's why we just use an ASSERT here.

	-- Check that pattern-bound variables are not unlifted
    (if or [ (idName id `elem` pat_binders) && isUnLiftedType (idType id) 
	   | id <- zonked_mono_ids ] then
	addErrTc (unliftedBindErr "Pattern" mbind)
     else
	returnTc ()
    )								`thenTc_`

	-- Unlifted bindings must be non-recursive,
	-- not top level, non-polymorphic, and not pattern bound
    if any (isUnLiftedType . idType) zonked_mono_ids then
	checkTc (isNotTopLevel top_lvl)
		(unliftedBindErr "Top-level" mbind)		`thenTc_`
	checkTc (isNonRec is_rec)
		(unliftedBindErr "Recursive" mbind)		`thenTc_`
	checkTc (null real_tyvars_to_gen)
		(unliftedBindErr "Polymorphic" mbind)
     else
	returnTc ()

  where
    pat_binders :: [Name]
    pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)

    justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
    justPatBindings (AndMonoBinds b1 b2) binds = 
	    justPatBindings b1 (justPatBindings b2 binds) 
    justPatBindings other_bind binds = binds
348
349
\end{code}

350

351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
Polymorphic recursion
~~~~~~~~~~~~~~~~~~~~~
The game plan for polymorphic recursion in the code above is 

	* Bind any variable for which we have a type signature
	  to an Id with a polymorphic type.  Then when type-checking 
	  the RHSs we'll make a full polymorphic call.

This fine, but if you aren't a bit careful you end up with a horrendous
amount of partial application and (worse) a huge space leak. For example:

	f :: Eq a => [a] -> [a]
	f xs = ...f...

If we don't take care, after typechecking we get

	f = /\a -> \d::Eq a -> let f' = f a d
			       in
			       \ys:[a] -> ...f'...

Notice the the stupid construction of (f a d), which is of course
identical to the function we're executing.  In this case, the
373
374
375
376
377
378
379
polymorphic recursion isn't being used (but that's a very common case).
We'd prefer

	f = /\a -> \d::Eq a -> letrec
				 fm = \ys:[a] -> ...fm...
			       in
			       fm
380

381
382
This can lead to a massive space leak, from the following top-level defn
(post-typechecking)
383
384

	ff :: [Int] -> [Int]
385
	ff = f Int dEqInt
386
387
388
389
390

Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
f' is another thunk which evaluates to the same thing... and you end
up with a chain of identical values all hung onto by the CAF ff.

391
392
393
394
395
396
397
398
	ff = f Int dEqInt

	   = let f' = f Int dEqInt in \ys. ...f'...

	   = let f' = let f' = f Int dEqInt in \ys. ...f'...
		      in \ys. ...f'...

Etc.
399
400
401
402
Solution: when typechecking the RHSs we always have in hand the
*monomorphic* Ids for each binding.  So we just need to make sure that
if (Method f a d) shows up in the constraints emerging from (...f...)
we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
403
to the "givens" when simplifying constraints.  That's what the "lies_avail"
404
405
406
407
408
409
410
411
412
is doing.


%************************************************************************
%*									*
\subsection{getTyVarsToGen}
%*									*
%************************************************************************

413
\begin{code}
414
generalise_help doc tau_tvs lie_req sigs
415
416

-----------------------
417
  | null sigs
418
  =	-- INFERENCE CASE: Unrestricted group, no type signatures
419
    tcSimplifyInfer doc
420
421
422
		    tau_tvs lie_req

-----------------------
423
  | otherwise
424
425
426
427
428
429
  = 	-- CHECKING CASE: Unrestricted group, there are type signatures
	-- Check signature contexts are empty 
    checkSigsCtxts sigs				`thenTc` \ (sig_avails, sig_dicts) ->

	-- Check that the needed dicts can be
	-- expressed in terms of the signature ones
430
    tcSimplifyInferCheck doc tau_tvs sig_avails lie_req	`thenTc` \ (forall_tvs, lie_free, dict_binds) ->
431
432
433
434
435
436
	
   	-- Check that signature type variables are OK
    checkSigsTyVars sigs					`thenTc_`

    returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)

437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
generalise binder_names mbind tau_tvs lie_req sigs
  | is_unrestricted	-- UNRESTRICTED CASE
  = generalise_help doc tau_tvs lie_req sigs

  | otherwise		-- RESTRICTED CASE
  = 	-- Do a simplification to decide what type variables
	-- are constrained.  We can't just take the free vars
	-- of lie_req because that'll 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
    generalise_help doc tau_tvs lie_req sigs	`thenTc` \ (forall_tvs, lie_free, dict_binds, dict_ids) ->

	-- Check signature contexts are empty 
    checkTc (null sigs || null dict_ids)
	    (restrictedBindCtxtErr binder_names)	`thenTc_`
456
457
458

	-- Identify constrained tyvars
    let
459
460
461
	constrained_tvs = varSetElems (tyVarsOfTypes (map idType dict_ids))
				-- The dict_ids are fully zonked
	final_forall_tvs = forall_tvs `minusList` constrained_tvs
462
    in
463
464
465

	-- Now simplify with exactly that set of tyvars
	-- We have to squash those Methods
466
    tcSimplifyRestricted doc final_forall_tvs [] lie_req	`thenTc` \ (lie_free, binds) ->
467
468

    returnTc (final_forall_tvs, lie_free, binds, [])
469
470
471
472
473

  where
    is_unrestricted | opt_NoMonomorphismRestriction = True
		    | otherwise			    = isUnRestrictedGroup tysig_names mbind

474
    tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
475

476
477
478
479
    doc | null sigs = ptext SLIT("banding(s) for")        <+> pprBinders binder_names
	| otherwise = ptext SLIT("type signature(s) for") <+> pprBinders binder_names

-----------------------
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
	-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
	-- The type signatures on a mutually-recursive group of definitions
	-- must all have the same context (or none).
	--
	-- We unify them because, with polymorphic recursion, their types
	-- might not otherwise be related.  This is a rather subtle issue.
	-- ToDo: amplify
checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs)
  = mapTc_ check_one other_sigs		`thenTc_` 
    if null theta1 then
	returnTc ([], [])		-- Non-overloaded type signatures
    else
    newDicts SignatureOrigin theta1	`thenNF_Tc` \ sig_dicts ->
    let
	-- The "sig_avails" is the stuff available.  We get that from
	-- the context of the type signature, BUT ALSO the lie_avail
	-- so that polymorphic recursion works right (see comments at end of fn)
	sig_avails = sig_dicts ++ sig_meths
    in
    returnTc (sig_avails, map instToId sig_dicts)
  where
    sig1_dict_tys = map mkPredTy theta1
    n_sig1_theta  = length theta1
    sig_meths 	  = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]

    check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
       = tcAddSrcLoc src_loc					$
	 tcAddErrCtxt (sigContextsCtxt id1 id)			$
	 checkTc (length theta == n_sig1_theta) sigContextsErr	`thenTc_`
	 unifyTauTyLists sig1_dict_tys (map mkPredTy theta)

checkSigsTyVars sigs = mapTc_ check_one sigs
  where
    check_one (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
      = tcAddSrcLoc src_loc							$
	tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau)	$
	checkSigTyVars sig_tyvars (idFreeTyVars id)

    sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
\end{code}

521
@getTyVarsToGen@ decides what type variables to generalise over.
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536

For a "restricted group" -- see the monomorphism restriction
for a definition -- we bind no dictionaries, and
remove from tyvars_to_gen any constrained type variables

*Don't* simplify dicts at this point, because we aren't going
to generalise over these dicts.  By the time we do simplify them
we may well know more.  For example (this actually came up)
	f :: Array Int Int
	f x = array ... xs where xs = [1,2,3,4,5]
We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
stuff.  If we simplify only at the f-binding (not the xs-binding)
we'll know that the literals are all Ints, and we can just produce
Int literals!

537
538
539
540
Find all the type variables involved in overloading, the
"constrained_tyvars".  These are the ones we *aren't* going to
generalise.  We must be careful about doing this:

541
542
543
544
545
546
547
548
 (a) If we fail to generalise a tyvar which is not actually
	constrained, then it will never, ever get bound, and lands
	up printed out in interface files!  Notorious example:
		instance Eq a => Eq (Foo a b) where ..
	Here, b is not constrained, even though it looks as if it is.
	Another, more common, example is when there's a Method inst in
	the LIE, whose type might very well involve non-overloaded
	type variables.
549
550
  [NOTE: Jan 2001: I don't understand the problem here so I'm doing 
	the simple thing instead]
551

552
553
554
555
556
557
558
559
 (b) On the other hand, we mustn't generalise tyvars which are constrained,
	because we are going to pass on out the unmodified LIE, with those
	tyvars in it.  They won't be in scope if we've generalised them.

So we are careful, and do a complete simplification just to find the
constrained tyvars. We don't use any of the results, except to
find which tyvars are constrained.

560
\begin{code}
561
562
563
isUnRestrictedGroup :: [Name]		-- Signatures given for these
		    -> RenamedMonoBinds
		    -> Bool
564

565
is_elem v vs = isIn "isUnResMono" v vs
566

567
isUnRestrictedGroup sigs (PatMonoBind other        _ _) = False
568
isUnRestrictedGroup sigs (VarMonoBind v _)	        = v `is_elem` sigs
569
570
isUnRestrictedGroup sigs (FunMonoBind v _ matches _)	= any isUnRestrictedMatch matches || 
							  v `is_elem` sigs
571
572
573
isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2)		= isUnRestrictedGroup sigs mb1 &&
							  isUnRestrictedGroup sigs mb2
isUnRestrictedGroup sigs EmptyMonoBinds			= True
574
575
576

isUnRestrictedMatch (Match _ [] Nothing _) = False	-- No args, no signature
isUnRestrictedMatch other		   = True	-- Some args or a signature
577
\end{code}
578

579

580
581
582
583
584
%************************************************************************
%*									*
\subsection{tcMonoBind}
%*									*
%************************************************************************
585

586
587
@tcMonoBinds@ deals with a single @MonoBind@.  
The signatures have been dealt with already.
588

589
590
\begin{code}
tcMonoBinds :: RenamedMonoBinds 
591
	    -> [TcSigInfo]
592
	    -> RecFlag
593
	    -> TcM (TcMonoBinds, 
594
		      LIE,		-- LIE required
595
		      [Name],		-- Bound names
596
		      [TcId])		-- Corresponding monomorphic bound things
597
598
599
600

tcMonoBinds mbinds tc_ty_sigs is_rec
  = tc_mb_pats mbinds		`thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
    let
601
602
603
604
605
606
607
608
609
610
	id_list 	  = bagToList ids
	(names, mono_ids) = unzip id_list

		-- This last defn is the key one:
		-- extend the val envt with bindings for the 
		-- things bound in this group, overriding the monomorphic
		-- ids with the polymorphic ones from the pattern
	extra_val_env = case is_rec of
			  Recursive    -> map mk_bind id_list
			  NonRecursive -> []
611
612
613
614
615
    in
	-- Don't know how to deal with pattern-bound existentials yet
    checkTc (isEmptyBag tvs && isEmptyBag lie_avail) 
	    (existentialExplode mbinds)			`thenTc_` 

616
	-- *Before* checking the RHSs, but *after* checking *all* the patterns,
617
618
619
	-- extend the envt with bindings for all the bound ids;
	--   and *then* override with the polymorphic Ids from the signatures
	-- That is the whole point of the "complete_it" stuff.
620
621
622
623
624
625
626
627
628
629
630
	--
	-- There's a further wrinkle: we have to delay extending the environment
	-- until after we've dealt with any pattern-bound signature type variables
	-- Consider  f (x::a) = ...f...
	-- We're going to check that a isn't unified with anything in the envt, 
	-- so f itself had better not be!  So we pass the envt binding f into
	-- complete_it, which extends the actual envt in TcMatches.tcMatch, after
	-- dealing with the signature tyvars

    complete_it extra_val_env				`thenTc` \ (mbinds', lie_req_rhss) ->

631
    returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
632
  where
633

634
635
636
637
638
639
640
	-- This function is used when dealing with a LHS binder; 
	-- we make a monomorphic version of the Id.  
	-- We check for a type signature; if there is one, we use the mono_id
	-- from the signature.  This is how we make sure the tau part of the
	-- signature actually maatches the type of the LHS; then tc_mb_pats
	-- ensures the LHS and RHS have the same type
	
641
642
643
644
645
646
    tc_pat_bndr name pat_ty
	= case maybeSig tc_ty_sigs name of
	    Nothing
		-> newLocalId (getOccName name) pat_ty (getSrcLoc name)

	    Just (TySigInfo _ _ _ _ _ mono_id _ _)
647
		-> tcAddSrcLoc (getSrcLoc name)		$
648
649
		   unifyTauTy (idType mono_id) pat_ty 	`thenTc_`
		   returnTc mono_id
650

651
652
653
    mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
				Nothing 				  -> (name, mono_id)
				Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
654
655

    tc_mb_pats EmptyMonoBinds
656
      = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
657
658
659
660
661

    tc_mb_pats (AndMonoBinds mb1 mb2)
      = tc_mb_pats mb1		`thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
        tc_mb_pats mb2		`thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
	let
662
663
664
	   complete_it xve = complete_it1 xve	`thenTc` \ (mb1', lie1) ->
			     complete_it2 xve	`thenTc` \ (mb2', lie2) ->
			     returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
665
666
667
668
669
670
671
672
	in
	returnTc (complete_it,
		  lie_req1 `plusLIE` lie_req2,
		  tvs1 `unionBags` tvs2,
		  ids1 `unionBags` ids2,
		  lie_avail1 `plusLIE` lie_avail2)

    tc_mb_pats (FunMonoBind name inf matches locn)
673
      = newTyVarTy kind 		`thenNF_Tc` \ bndr_ty -> 
674
	tc_pat_bndr name bndr_ty	`thenTc` \ bndr_id ->
675
	let
676
677
678
	   complete_it xve = tcAddSrcLoc locn				$
			     tcMatchesFun xve name bndr_ty  matches	`thenTc` \ (matches', lie) ->
			     returnTc (FunMonoBind bndr_id inf matches' locn, lie)
679
680
681
	in
	returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)

682
    tc_mb_pats bind@(PatMonoBind pat grhss locn)
683
      = tcAddSrcLoc locn	 	$
684
	newTyVarTy kind 		`thenNF_Tc` \ pat_ty -> 
685
686
687
688
689
690
691
692
693
694
695

		-- 	Now typecheck the pattern
		-- We don't support binding fresh type variables in the
		-- pattern of a pattern binding.  For example, this is illegal:
		--	(x::a, y::b) = e
		-- whereas this is ok
		--	(x::Int, y::Bool) = e
		--
		-- We don't check explicitly for this problem.  Instead, we simply
		-- type check the pattern with tcPat.  If the pattern mentions any
		-- fresh tyvars we simply get an out-of-scope type variable error
696
	tcPat tc_pat_bndr pat pat_ty		`thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
697
	let
698
699
700
701
702
	   complete_it xve = tcAddSrcLoc locn		 		$
			     tcAddErrCtxt (patMonoBindsCtxt bind)	$
			     tcExtendLocalValEnv xve			$
			     tcGRHSs grhss pat_ty PatBindRhs		`thenTc` \ (grhss', lie) ->
			     returnTc (PatMonoBind pat' grhss' locn, lie)
703
704
	in
	returnTc (complete_it, lie_req, tvs, ids, lie_avail)
705
706
707

	-- Figure out the appropriate kind for the pattern,
	-- and generate a suitable type variable 
708
    kind = case is_rec of
709
710
		Recursive    -> liftedTypeKind	-- Recursive, so no unlifted types
		NonRecursive -> openTypeKind 	-- Non-recursive, so we permit unlifted types
711
712
\end{code}

713

714
715
716
717
718
719
%************************************************************************
%*									*
\subsection{SPECIALIZE pragmas}
%*									*
%************************************************************************

720
@tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
721
722
723
724
pragmas.  It is convenient for them to appear in the @[RenamedSig]@
part of a binding because then the same machinery can be used for
moving them into place as is done for type signatures.

725
They look like this:
726
727
728
729
730

\begin{verbatim}
	f :: Ord a => [a] -> b -> b
	{-# SPECIALIZE f :: [Int] -> b -> b #-}
\end{verbatim}
731
732

For this we generate:
733
\begin{verbatim}
734
735
736
	f* = /\ b -> let d1 = ...
		     in f Int b d1
\end{verbatim}
737

738
739
740
741
where f* is a SpecPragmaId.  The **sole** purpose of SpecPragmaIds is to
retain a right-hand-side that the simplifier will otherwise discard as
dead code... the simplifier has a flag that tells it not to discard
SpecPragmaId bindings.
742

743
744
745
746
747
748
In this case the f* retains a call-instance of the overloaded
function, f, (including appropriate dictionaries) so that the
specialiser will subsequently discover that there's a call of @f@ at
Int, and will create a specialisation for @f@.  After that, the
binding for @f*@ can be discarded.

749
750
751
752
753
We used to have a form
	{-# SPECIALISE f :: <type> = g #-}
which promised that g implemented f at <type>, but we do that with 
a RULE now:
	{-# SPECIALISE (f::<type) = g #-}
754

755
\begin{code}
756
tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE)
757
tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
sof's avatar
sof committed
758
759
760
  = 	-- SPECIALISE f :: forall b. theta => tau  =  g
    tcAddSrcLoc src_loc		 		$
    tcAddErrCtxt (valSpecSigCtxt name poly_ty)	$
761
762

	-- Get and instantiate its alleged specialised type
763
    tcHsSigType poly_ty				`thenTc` \ sig_ty ->
764

sof's avatar
sof committed
765
766
767
768
	-- Check that f has a more general type, and build a RHS for
	-- the spec-pragma-id at the same time
    tcExpr (HsVar name) sig_ty			`thenTc` \ (spec_expr, spec_lie) ->

769
	-- Squeeze out any Methods (see comments with tcSimplifyToDicts)
770
    tcSimplifyToDicts spec_lie			`thenTc` \ (spec_dicts, spec_binds) ->
771

772
773
774
775
776
777
778
    	-- Just specialise "f" by building a SpecPragmaId binding
	-- It is the thing that makes sure we don't prematurely 
	-- dead-code-eliminate the binding we are really interested in.
    newSpecPragmaId name sig_ty		`thenNF_Tc` \ spec_id ->

	-- Do the rest and combine
    tcSpecSigs sigs			`thenTc` \ (binds_rest, lie_rest) ->
779
    returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr),
780
	      lie_rest   `plusLIE`      mkLIE spec_dicts)
781
782
783

tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
tcSpecSigs []		      = returnTc (EmptyMonoBinds, emptyLIE)
784
785
786
\end{code}


787
788
%************************************************************************
%*									*
789
\subsection[TcBinds-errors]{Error contexts and messages}
790
791
792
793
794
%*									*
%************************************************************************


\begin{code}
795
796
patMonoBindsCtxt bind
  = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
797

798
-----------------------------------------------
799
800
valSpecSigCtxt v ty
  = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
801
	 nest 4 (ppr v <+> dcolon <+> ppr ty)]
802

803
-----------------------------------------------
804
sigContextsErr = ptext SLIT("Mismatched contexts")
805

806
sigContextsCtxt s1 s2
sof's avatar
sof committed
807
  = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), 
808
		quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
sof's avatar
sof committed
809
	 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
810

811
-----------------------------------------------
812
unliftedBindErr flavour mbind
813
  = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
814
815
	 4 (ppr mbind)

816
-----------------------------------------------
817
818
819
820
821
existentialExplode mbinds
  = hang (vcat [text "My brain just exploded.",
	        text "I can't handle pattern bindings for existentially-quantified constructors.",
		text "In the binding group"])
	4 (ppr mbinds)
822
823
824
825
826
827
828
829
830

-----------------------------------------------
restrictedBindCtxtErr binder_names
  = hang (ptext SLIT("Illegal overloaded type signature(s)"))
       4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
		ptext SLIT("that falls under the monomorphism restriction")])

-- Used in error messages
pprBinders bndrs = braces (pprWithCommas ppr bndrs)
831
\end{code}