TcIface.lhs 38.4 KB
Newer Older
1
2
3
4
5
6
7
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcIfaceSig]{Type checking of type signatures in interface files}

\begin{code}
module TcIface ( 
8
9
	tcImportDecl, tcHiBootIface, typecheckIface, 
	tcIfaceDecl, tcIfaceGlobal, 
10
	loadImportedInsts, loadImportedRules,
11
12
	tcExtCoreBindings
 ) where
13

14
15
16
#include "HsVersions.h"

import IfaceSyn
17
import LoadIface	( loadHomeInterface, loadInterface, predInstGates,
18
			  loadDecls, findAndReadIface )
19
import IfaceEnv		( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, 
20
			  extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
21
22
			  tcIfaceTyVar, tcIfaceLclId, 
			  newIfaceName, newIfaceNames, ifaceExportNames )
23
24
import BuildTyCl	( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
			  mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
25
import TcRnMonad
26
27
import TcType		( hoistForAllTys )	-- TEMPORARY HACK
import Type		( liftedTypeKind, splitTyConApp, mkSynTy, mkTyConApp,
28
			  mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred )
29
import TypeRep		( Type(..), PredType(..) )
30
import TyCon		( TyCon, tyConName, isSynTyCon )
31
import HscTypes		( ExternalPackageState(..), EpsStats(..), PackageInstEnv, 
32
			  HscEnv, TyThing(..), tyThingClass, tyThingTyCon, 
33
			  ModIface(..), ModDetails(..), ModGuts, HomeModInfo(..),
34
			  emptyModDetails,
35
			  extendTypeEnv, lookupTypeEnv, lookupType, typeEnvIds )
36
import InstEnv		( extendInstEnvList )
37
import CoreSyn
38
import PprCore		( pprIdRules )
39
40
41
42
43
44
45
46
47
48
49
50
51
import Rules		( extendRuleBaseList )
import CoreUtils	( exprType )
import CoreUnfold
import CoreLint		( lintUnfolding )
import WorkWrap		( mkWrapper )
import InstEnv		( DFunId )
import Id		( Id, mkVanillaGlobal, mkLocalId )
import MkId		( mkFCallId )
import IdInfo		( IdInfo, CafInfo(..), WorkerInfo(..), 
			  setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo,
			  setArityInfo, setInlinePragInfo, setCafInfo, 
			  vanillaIdInfo, newStrictnessInfo )
import Class		( Class )
52
53
54
import TyCon		( tyConDataCons, isTupleTyCon, mkForeignTyCon )
import DataCon		( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon )
import TysWiredIn	( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
55
import Var		( TyVar, mkTyVar, tyVarKind )
56
import Name		( Name, nameModule, nameIsLocalOrFrom, 
57
			  isWiredInName, wiredInNameTyThing_maybe, nameParent )
58
59
import NameEnv
import OccName		( OccName )
60
import Module		( Module, lookupModuleEnv )
61
62
import UniqSupply	( initUs_ )
import Outputable	
63
64
import ErrUtils		( Message )
import Maybes		( MaybeErr(..) )
65
import SrcLoc		( noSrcLoc )
66
import Util		( zipWithEqual, dropList, equalLength )
67
import DynFlags		( DynFlag(..), isOneShot )
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
\end{code}

This module takes

	IfaceDecl -> TyThing
	IfaceType -> Type
	etc

An IfaceDecl is populated with RdrNames, and these are not renamed to
Names before typechecking, because there should be no scope errors etc.

	-- For (b) consider: f = $(...h....)
	-- where h is imported, and calls f via an hi-boot file.  
	-- This is bad!  But it is not seen as a staging error, because h
	-- is indeed imported.  We don't want the type-checker to black-hole 
	-- when simplifying and compiling the splice!
	--
	-- Simple solution: discard any unfolding that mentions a variable
	-- bound in this module (and hence not yet processed).
	-- The discarding happens when forkM finds a type error.

%************************************************************************
%*									*
%*	tcImportDecl is the key function for "faulting in" 		*
%*	imported things
%*									*
%************************************************************************

The main idea is this.  We are chugging along type-checking source code, and
find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
it in the EPS type envt.  So it 
	1 loads GHC.Base.hi
	2 gets the decl for GHC.Base.map
	3 typechecks it via tcIfaceDecl
	4 and adds it to the type env in the EPS

Note that DURING STEP 4, we may find that map's type mentions a type 
constructor that also 

Notice that for imported things we read the current version from the EPS
mutable variable.  This is important in situations like
	...$(e1)...$(e2)...
where the code that e1 expands to might import some defns that 
also turn out to be needed by the code that e2 expands to.

\begin{code}
114
115
116
117
118
119
120
121
122
123
tcImportDecl :: Name -> TcM TyThing
-- Entry point for source-code uses of importDecl
tcImportDecl name 
  = do 	{ traceIf (text "tcLookupGlobal" <+> ppr name)
	; mb_thing <- initIfaceTcRn (importDecl name)
	; case mb_thing of
	    Succeeded thing -> return thing
	    Failed err      -> failWithTc err }

importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
124
-- Get the TyThing for this Name from an interface file
125
importDecl name 
126
  | Just thing <- wiredInNameTyThing_maybe name
127
	-- This case definitely happens for tuples, because we
128
	-- don't know how many of them we'll find
129
130
131
	-- It also now happens for all other wired in things.  We used
	-- to pre-populate the eps_PTE with other wired-in things, but
	-- we don't seem to do that any more.  I guess it keeps the PTE smaller?
132
  = do 	{ updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing })
133
	; return (Succeeded thing) }
134
135
136
137
138

  | otherwise
  = do	{ traceIf nd_doc

	-- Load the interface, which should populate the PTE
139
140
141
142
	; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
	; case mb_iface of {
		Failed err_msg  -> return (Failed err_msg) ;
		Succeeded iface -> do
143
144

	-- Now look it up again; this time we should find it
145
	{ eps <- getEps	
146
	; case lookupTypeEnv (eps_PTE eps) name of
147
148
149
	    Just thing -> return (Succeeded thing)
	    Nothing    -> return (Failed not_found_msg)
    }}}
150
  where
151
    nd_doc = ptext SLIT("Need decl for") <+> ppr name
152
153
154
    not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
	  	       2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
		                ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
155
156
157
158
\end{code}

%************************************************************************
%*									*
159
		Type-checking a complete interface
160
161
162
%*									*
%************************************************************************

163
164
165
166
167
168
169
170
Suppose we discover we don't need to recompile.  Then we must type
check the old interface file.  This is a bit different to the
incremental type checking we do as we suck in interface files.  Instead
we do things similarly as when we are typechecking source decls: we
bring into scope the type envt for the interface all at once, using a
knot.  Remember, the decls aren't necessarily in dependency order --
and even if they were, the type decls might be mutually recursive.

171
\begin{code}
172
173
174
175
176
177
typecheckIface :: ModIface 	-- Get the decls from here
	       -> TcRnIf gbl lcl ModDetails
typecheckIface iface
  = initIfaceTc iface $ \ tc_env_var -> do
	-- The tc_env_var is freshly allocated, private to 
	-- type-checking this particular interface
178
179
180
181
182
183
	{ 	-- Get the right set of decls and rules.  If we are compiling without -O
		-- we discard pragmas before typechecking, so that we don't "see"
		-- information that we shouldn't.  From a versioning point of view
		-- It's not actually *wrong* to do so, but in fact GHCi is unable 
		-- to handle unboxed tuples, so it must not see unfoldings.
	  ignore_prags <- doptM Opt_IgnoreInterfacePragmas
184
185
186
187
188

		-- Load & typecheck the decls
	; decl_things <- loadDecls ignore_prags (mi_decls iface)

	; let type_env = mkNameEnv decl_things
189
190
191
	; writeMutVar tc_env_var type_env

		-- Now do those rules and instances
192
193
194
195
	; let { rules | ignore_prags = []
		      | otherwise    = mi_rules iface
	      ; dfuns = mi_insts iface
	      } 
196
197
	; dfuns <- mapM tcIfaceInst dfuns
	; rules <- mapM tcIfaceRule rules
198

199
200
201
		-- Exports
	; exports <-  ifaceExportNames (mi_exports iface)

202
		-- Finished
203
204
205
206
	; return (ModDetails {	md_types = type_env, 
				md_insts = dfuns,
				md_rules = rules,
				md_exports = exports }) 
207
    }
208
209
210
\end{code}


211
212
213
214
215
216
217
218
219
220
221
222
223
224
%************************************************************************
%*									*
		Type and class declarations
%*									*
%************************************************************************

\begin{code}
tcHiBootIface :: Module -> TcRn ModDetails
-- Load the hi-boot iface for the module being compiled,
-- if it indeed exists in the transitive closure of imports
-- Return the ModDetails, empty if no hi-boot iface
tcHiBootIface mod
  = do 	{ traceIf (text "loadHiBootInterface" <+> ppr mod)

225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
	; mode <- getGhciMode
	; if not (isOneShot mode)
		-- In --make and interactive mode, if this module has an hs-boot file
		-- we'll have compiled it already, and it'll be in the HPT
	  then do { hpt <- getHpt
		  ; case lookupModuleEnv hpt mod of
		      Just info -> return (hm_details info)
		      Nothing   -> return emptyModDetails }
	  else do

	-- OK, so we're in one-shot mode.  
	-- In that case, we're read all the direct imports by now, 
	-- so eps_is_boot will record if any of our imports mention us by 
	-- way of hi-boot file
	{ eps <- getEps
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
	; case lookupModuleEnv (eps_is_boot eps) mod of {
	    Nothing -> return emptyModDetails ;	-- The typical case

	    Just (_, False) -> failWithTc moduleLoop ;
 		-- Someone below us imported us!
		-- This is a loop with no hi-boot in the way
		
	    Just (mod, True) -> 	-- There's a hi-boot interface below us
		
    do	{ read_result <- findAndReadIface 
				True	-- Explicit import? 
				need mod
				True	-- Hi-boot file

	; case read_result of
		Failed err               -> failWithTc (elaborate err)
		Succeeded (iface, _path) -> typecheckIface iface
257
    }}}}
258
259
260
261
262
263
264
265
266
267
268
269
  where
    need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
		 <+> ptext SLIT("to compare against the Real Thing")

    moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) 
		     <+> ptext SLIT("depends on itself")

    elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+> 
		          quotes (ppr mod) <> colon) 4 err
\end{code}


270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
%************************************************************************
%*									*
		Type and class declarations
%*									*
%************************************************************************

When typechecking a data type decl, we *lazily* (via forkM) typecheck
the constructor argument types.  This is in the hope that we may never
poke on those argument types, and hence may never need to load the
interface files for types mentioned in the arg types.

E.g.	
	data Foo.S = MkS Baz.T
Mabye we can get away without even loading the interface for Baz!

This is not just a performance thing.  Suppose we have
	data Foo.S = MkS Baz.T
	data Baz.T = MkT Foo.S
(in different interface files, of course).
Now, first we load and typecheck Foo.S, and add it to the type envt.  
If we do explore MkS's argument, we'll load and typecheck Baz.T.
If we explore MkT's argument we'll find Foo.S already in the envt.  

If we typechecked constructor args eagerly, when loading Foo.S we'd try to
typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
which isn't done yet.

All very cunning. However, there is a rather subtle gotcha which bit
me when developing this stuff.  When we typecheck the decl for S, we
extend the type envt with S, MkS, and all its implicit Ids.  Suppose
(a bug, but it happened) that the list of implicit Ids depended in
turn on the constructor arg types.  Then the following sequence of
events takes place:
	* we build a thunk <t> for the constructor arg tys
	* we build a thunk for the extended type environment (depends on <t>)
	* we write the extended type envt into the global EPS mutvar
	
Now we look something up in the type envt
	* that pulls on <t>
	* which reads the global type envt out of the global EPS mutvar
	* but that depends in turn on <t>

It's subtle, because, it'd work fine if we typechecked the constructor args 
eagerly -- they don't need the extended type envt.  They just get the extended
type envt by accident, because they look at it later.

What this means is that the implicitTyThings MUST NOT DEPEND on any of
the forkM stuff.


\begin{code}
tcIfaceDecl :: IfaceDecl -> IfL TyThing

tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
  = do	{ name <- lookupIfaceTop occ_name
	; ty <- tcIfaceType iface_type
	; info <- tcIdInfo name ty info
	; return (AnId (mkVanillaGlobal name ty info)) }

329
tcIfaceDecl (IfaceData {ifName = occ_name, 
330
			ifTyVars = tv_bndrs, 
331
332
333
334
335
336
			ifCons = rdr_cons, 
			ifVrcs = arg_vrcs, ifRec = is_rec, 
			ifGeneric = want_generic })
  = do	{ tc_name <- lookupIfaceTop occ_name
	; bindIfaceTyVars tv_bndrs $ \ tyvars -> do

337
338
339
	{ tycon <- fixM ( \ tycon -> do
	    { cons  <- tcIfaceDataCons tycon tyvars rdr_cons
	    ; tycon <- buildAlgTyCon tc_name tyvars cons 
340
341
342
343
344
			    arg_vrcs is_rec want_generic
	    ; return tycon
	    })
        ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
	; return (ATyCon tycon)
345
    }}
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384

tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
		       ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
     { tc_name <- lookupIfaceTop occ_name
     ; rhs_ty <- tcIfaceType rdr_rhs_ty
     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
     }

tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, 
			 ifFDs = rdr_fds, ifSigs = rdr_sigs, 
			 ifVrcs = tc_vrcs, ifRec = tc_isrec })
  = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
    { cls_name <- lookupIfaceTop occ_name
    ; ctxt <- tcIfaceCtxt rdr_ctxt
    ; sigs <- mappM tc_sig rdr_sigs
    ; fds  <- mappM tc_fd rdr_fds
    ; cls  <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
    ; return (AClass cls) }
  where
   tc_sig (IfaceClassOp occ dm rdr_ty)
     = do { op_name <- lookupIfaceTop occ
	  ; op_ty   <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
		-- Must be done lazily for just the same reason as the 
		-- context of a data decl: the type sig might mention the
		-- class being defined
	  ; return (op_name, dm, op_ty) }

   mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]

   tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
			   ; tvs2' <- mappM tcIfaceTyVar tvs2
			   ; return (tvs1', tvs2') }

tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
  = do	{ name <- lookupIfaceTop rdr_name
	; return (ATyCon (mkForeignTyCon name ext_name 
					 liftedTypeKind 0 [])) }

385
tcIfaceDataCons tycon tc_tyvars if_cons
386
  = case if_cons of
387
388
389
390
391
392
	IfAbstractTyCon		 -> return mkAbstractTyConRhs
	IfDataTyCon mb_ctxt cons -> do 	{ mb_theta <- tc_ctxt mb_ctxt
					; data_cons <- mappM tc_con_decl cons
					; return (mkDataTyConRhs mb_theta data_cons) }
	IfNewTyCon con		 -> do 	{ data_con <- tc_con_decl con
					; return (mkNewTyConRhs tycon data_con) }
393
  where
394
395
396
397
398
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
    tc_ctxt Nothing     = return Nothing
    tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) }

    tc_con_decl (IfVanillaCon {	ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args, 
				ifConStricts = stricts, ifConFields = field_lbls})
      = do { name  <- lookupIfaceTop occ
		-- Read the argument types, but lazily to avoid faulting in
		-- the component types unless they are really needed
 	   ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
	   ; lbl_names <- mappM lookupIfaceTop field_lbls
	   ; buildDataCon name is_infix True {- Vanilla -} 
			  stricts lbl_names
			  tc_tyvars [] arg_tys tycon
			  (mkTyVarTys tc_tyvars)	-- Vanilla => we know result tys
	   }  

    tc_con_decl (IfGadtCon {	ifConTyVars = con_tvs,
				ifConOcc = occ, ifConCtxt = ctxt, 
				ifConArgTys = args, ifConResTys = ress, 
				ifConStricts = stricts})
      = bindIfaceTyVars con_tvs	$ \ con_tyvars -> do
	{ name  <- lookupIfaceTop occ
	; theta <- tcIfaceCtxt ctxt	-- Laziness seems not worth the bother here
	 	-- At one stage I thought that this context checking *had*
		-- to be lazy, because of possible mutual recursion between the
		-- type and the classe: 
		-- E.g. 
		--	class Real a where { toRat :: a -> Ratio Integer }
		--	data (Real a) => Ratio a = ...
		-- But now I think that the laziness in checking class ops breaks 
		-- the loop, so no laziness needed
425
426
427

	-- Read the argument types, but lazily to avoid faulting in
	-- the component types unless they are really needed
428
429
 	; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
 	; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
430

431
432
433
434
	; buildDataCon name False {- Not infix -} False {- Not vanilla -}
		       stricts [{- No fields -}]
		       con_tyvars theta 
		       arg_tys tycon res_tys
435
	}
436
    mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
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
469
470
\end{code}	


%************************************************************************
%*									*
		Instances
%*									*
%************************************************************************

The gating story for instance declarations
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we are looking for a dict (C t1..tn), we slurp in instance decls for
C that 
	mention at least one of the type constructors 
	at the roots of t1..tn

Why "at least one" rather than "all"?  Because functional dependencies 
complicate the picture.  Consider
	class C a b | a->b where ...
	instance C Foo Baz where ...
Here, the gates are really only C and Foo, *not* Baz.
That is, if C and Foo are visible, even if Baz isn't, we must
slurp the decl, even if Baz is thus far completely unknown to the
system.

Why "roots of the types"?  Reason is overlap.  For example, suppose there 
are interfaces in the pool for
  (a)	C Int b
 (b)	C a [b]
  (c)	C a [T] 
Then, if we are trying to resolve (C Int x), we need (a)
if we are trying to resolve (C x [y]), we need *both* (b) and (c),
even though T is not involved yet, so that we spot the overlap.

471
472
473
474
475
476
477

NOTE: if you use an instance decl with NO type constructors
	instance C a where ...
and look up an Inst that only has type variables such as (C (n o))
then GHC won't necessarily suck in the instances that overlap with this.


478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
\begin{code}
loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv
loadImportedInsts cls tys
  = do	{ 	-- Get interfaces for wired-in things, such as Integer
		-- Any non-wired-in tycons will already be loaded, else
		-- we couldn't have them in the Type
	; this_mod <- getModule 
	; let { (cls_gate, tc_gates) = predInstGates cls tys
	      ; imp_wi n = isWiredInName n && this_mod /= nameModule n
	      ;	wired_tcs = filter imp_wi tc_gates }
			-- Wired-in tycons not from this module.  The "this-module"
			-- test bites only when compiling Base etc, because loadHomeInterface
			-- barfs if it's asked to load a non-existent interface
	; if null wired_tcs then returnM ()
	  else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs)

494
495
		-- Now suck in the relevant instances
	; iface_insts <- updateEps (selectInsts cls_gate tc_gates)
496
497
498

	-- Empty => finish up rapidly, without writing to eps
	; if null iface_insts then
499
		do { eps <- getEps; return (eps_inst_env eps) }
500
	  else do
501
	{ traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys, 
502
			nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])])
503

504
505
506
507
508
509
	-- Typecheck the new instances
	; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)

	-- And put them in the package instance environment
	; updateEps ( \ eps ->
	    let 
510
		inst_env' = extendInstEnvList (eps_inst_env eps) dfuns
511
512
513
514
515
516
	    in
	    (eps { eps_inst_env = inst_env' }, inst_env')
	)}}
  where
    wired_doc = ptext SLIT("Need home inteface for wired-in thing")

517
518
519
tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst)
  where
    full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr inst))
520
521
522
523
524

tcIfaceInst :: IfaceInst -> IfL DFunId
tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
  = tcIfaceExtId (LocalTop dfun_occ)

525
526
selectInsts :: Name -> [Name] -> ExternalPackageState 
	    -> (ExternalPackageState, [(Module, SDoc, IfaceInst)])
527
528
selectInsts cls tycons eps
  = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts)
529
  where
530
531
532
533
    insts  = eps_insts eps
    stats  = eps_stats eps
    stats' = stats { n_insts_out = n_insts_out stats + length iface_insts } 

534
535
536
    (insts', iface_insts) 
	= case lookupNameEnv insts cls of {
		Nothing -> (insts, []) ;
537
		Just gated_insts ->
538
	
539
	  case choose1 gated_insts  of {
540
541
542
543
544
	    (_, []) -> (insts, []) ;	-- None picked
	    (gated_insts', iface_insts') -> 

	  (extendNameEnv insts cls gated_insts', iface_insts') }}

545
546
547
548
549
550
    choose1 gated_insts
	| null tycons 			-- Bizarre special case of C (a b); then there are no tycons
	= ([], map snd gated_insts)	-- Just grab all the instances, no real alternative
	| otherwise 			-- Normal case
	= foldl choose2 ([],[]) gated_insts

551
	-- Reverses the gated decls, but that doesn't matter
552
    choose2 (gis, decls) (gates, decl)
553
554
555
	|  null gates 	-- Happens when we have 'instance T a where ...'
        || any (`elem` tycons) gates = (gis, 	           decl:decls)
	| otherwise		     = ((gates,decl) : gis, decls)
556
557
558
559
560
561
562
563
564
565
566
567
568
\end{code}

%************************************************************************
%*									*
		Rules
%*									*
%************************************************************************

We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
are in the type environment.  However, remember that typechecking a Rule may 
(as a side effect) augment the type envt, and so we may need to iterate the process.

\begin{code}
569
570
loadImportedRules :: HscEnv -> ModGuts -> IO [IdCoreRule]
-- Returns just the new rules added
571
572
loadImportedRules hsc_env guts
  = initIfaceRules hsc_env guts $ do 
573
	{ -- Get new rules
574
	  if_rules <- updateEps selectRules
575

576
	; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules])
577

578
579
580
	; core_rules <- mapM tc_rule if_rules

	-- Debug print
581
	; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules)
582
583
584
585
586
	
	-- Update the rule base and return it
	; updateEps (\ eps -> 
	    let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
	    in (eps { eps_rule_base = new_rule_base }, new_rule_base)
587
588
589
590
591
592
	  ) 

	-- Strictly speaking, at this point we should go round again, since
	-- typechecking one set of rules may bring in new things which enable
	-- some more rules to come in.  But we call loadImportedRules several
	-- times anyway, so I'm going to be lazy and ignore this.
593
	; return core_rules
594
    }
595

596
597
598
599
600
tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule)
  where
    full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule))
   
selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)])
601
602
603
-- Not terribly efficient.  Look at each rule in the pool to see if
-- all its gates are in the type env.  If so, take it out of the pool.
-- If not, trim its gates for next time.
604
605
selectRules eps
  = (eps { eps_rules = rules', eps_stats = stats' }, if_rules)
606
  where
607
608
609
610
611
    stats    = eps_stats eps
    rules    = eps_rules eps
    type_env = eps_PTE eps
    stats'   = stats { n_rules_out = n_rules_out stats + length if_rules }

612
613
614
615
616
617
    (rules', if_rules) = foldl do_one ([], []) rules

    do_one (pool, if_rules) (gates, rule)
	| null gates' = (pool, rule:if_rules)
	| otherwise   = ((gates',rule) : pool, if_rules)
	where
618
	  gates' = filter (not . (`elemNameEnv` type_env)) gates
619

620
621
622
623
624
625
626
627

tcIfaceRule :: IfaceRule -> IfL IdCoreRule
tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,
			ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs })
  = bindIfaceBndrs bndrs 	$ \ bndrs' ->
    do	{ fn <- tcIfaceExtId fn_rdr
	; args' <- mappM tcIfaceExpr args
	; rhs'  <- tcIfaceExpr rhs
628
629
630
	; let rule = Rule rule_name act bndrs' args' rhs'
	; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) }
  where
631
632
633

tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
  = do	{ fn <- tcIfaceExtId fn_rdr
634
635
636
	; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }

isOrphNm :: IfaceExtName -> Bool
637
638
639
-- An orphan name comes from somewhere other than this module,
-- so it has a non-local name
isOrphNm name = not (isLocalIfaceExtName name)
640
641
642
643
644
645
646
647
648
649
650
651
652
653
\end{code}


%************************************************************************
%*									*
			Types
%*									*
%************************************************************************

\begin{code}
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
654
tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkIfTcApp tc' ts') }
655
656
657
658
659
tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePredType st; return (PredTy st') }

tcIfaceTypes tys = mapM tcIfaceType tys

660
661
662
663
664
665
666
667
668
mkIfTcApp :: TyCon -> [Type] -> Type
-- In interface files we retain type synonyms (for brevity and better error
-- messages), but type synonyms can expand into non-hoisted types (ones with
-- foralls to the right of an arrow), so we must be careful to hoist them here.
-- This hack should go away when we get rid of hoisting.
mkIfTcApp tc tys
  | isSynTyCon tc = hoistForAllTys (mkSynTy tc tys)
  | otherwise	  = mkTyConApp tc tys

669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
-----------------------------------------
tcIfacePredType :: IfacePredType -> IfL PredType
tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
tcIfacePredType (IfaceIParam ip t)   = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }

-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
tcIfaceCtxt sts = mappM tcIfacePredType sts
\end{code}


%************************************************************************
%*									*
			Core
%*									*
%************************************************************************

\begin{code}
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType ty)
  = tcIfaceType ty		`thenM` \ ty' ->
    returnM (Type ty')

tcIfaceExpr (IfaceLcl name)
  = tcIfaceLclId name 	`thenM` \ id ->
    returnM (Var id)

tcIfaceExpr (IfaceExt gbl)
  = tcIfaceExtId gbl 	`thenM` \ id ->
    returnM (Var id)

tcIfaceExpr (IfaceLit lit)
  = returnM (Lit lit)

tcIfaceExpr (IfaceFCall cc ty)
  = tcIfaceType ty 	`thenM` \ ty' ->
    newUnique		`thenM` \ u ->
    returnM (Var (mkFCallId u cc ty'))

tcIfaceExpr (IfaceTuple boxity args) 
  = mappM tcIfaceExpr args	`thenM` \ args' ->
    let
	-- Put the missing type arguments back in
	con_args = map (Type . exprType) args' ++ args'
    in
    returnM (mkApps (Var con_id) con_args)
  where
    arity = length args
    con_id = dataConWorkId (tupleCon boxity arity)
    

tcIfaceExpr (IfaceLam bndr body)
  = bindIfaceBndr bndr 		$ \ bndr' ->
    tcIfaceExpr body		`thenM` \ body' ->
    returnM (Lam bndr' body')

tcIfaceExpr (IfaceApp fun arg)
  = tcIfaceExpr fun		`thenM` \ fun' ->
    tcIfaceExpr arg		`thenM` \ arg' ->
    returnM (App fun' arg')

730
tcIfaceExpr (IfaceCase scrut case_bndr ty alts) 
731
732
733
734
735
736
737
738
739
740
741
742
743
744
  = tcIfaceExpr scrut		`thenM` \ scrut' ->
    newIfaceName case_bndr	`thenM` \ case_bndr_name ->
    let
	scrut_ty   = exprType scrut'
	case_bndr' = mkLocalId case_bndr_name scrut_ty
	tc_app     = splitTyConApp scrut_ty
		-- NB: Won't always succeed (polymoprhic case)
		--     but won't be demanded in those cases
		-- NB: not tcSplitTyConApp; we are looking at Core here
		--     look through non-rec newtypes to find the tycon that
		--     corresponds to the datacon in this case alternative
    in
    extendIfaceIdEnv [case_bndr']	$
    mappM (tcIfaceAlt tc_app) alts	`thenM` \ alts' ->
745
746
    tcIfaceType ty		`thenM` \ ty' ->
    returnM (Case scrut' case_bndr' ty' alts')
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787

tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
  = tcIfaceExpr rhs		`thenM` \ rhs' ->
    bindIfaceId bndr 		$ \ bndr' ->
    tcIfaceExpr body		`thenM` \ body' ->
    returnM (Let (NonRec bndr' rhs') body')

tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
  = bindIfaceIds bndrs		$ \ bndrs' ->
    mappM tcIfaceExpr rhss	`thenM` \ rhss' ->
    tcIfaceExpr body		`thenM` \ body' ->
    returnM (Let (Rec (bndrs' `zip` rhss')) body')
  where
    (bndrs, rhss) = unzip pairs

tcIfaceExpr (IfaceNote note expr) 
  = tcIfaceExpr expr		`thenM` \ expr' ->
    case note of
	IfaceCoerce to_ty -> tcIfaceType to_ty	`thenM` \ to_ty' ->
			     returnM (Note (Coerce to_ty'
                                                   (exprType expr')) expr')
	IfaceInlineCall   -> returnM (Note InlineCall expr')
	IfaceInlineMe     -> returnM (Note InlineMe   expr')
	IfaceSCC cc       -> returnM (Note (SCC cc)   expr')
	IfaceCoreNote n   -> returnM (Note (CoreNote n) expr')

-------------------------
tcIfaceAlt _ (IfaceDefault, names, rhs)
  = ASSERT( null names )
    tcIfaceExpr rhs		`thenM` \ rhs' ->
    returnM (DEFAULT, [], rhs')
  
tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
  = ASSERT( null names )
    tcIfaceExpr rhs		`thenM` \ rhs' ->
    returnM (LitAlt lit, [], rhs')

-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out.  True enough, but its not that easy!
tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
788
  = do	{ let tycon_mod = nameModule (tyConName tycon)
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
	; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
	; ASSERT2( con `elem` tyConDataCons tycon,
		   ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
		  
	  if isVanillaDataCon con then
		tcVanillaAlt con inst_tys arg_occs rhs
	  else
    do 	{ 	-- General case
	  arg_names <- newIfaceNames arg_occs
	; let	tyvars   = [ mkTyVar name (tyVarKind tv) 
			   | (name,tv) <- arg_names `zip` dataConTyVars con] 
		arg_tys	 = dataConArgTys con (mkTyVarTys tyvars)
		id_names = dropList tyvars arg_names
		arg_ids  = ASSERT2( equalLength id_names arg_tys,
				    ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
			   zipWith mkLocalId id_names arg_tys

	; rhs' <- extendIfaceTyVarEnv tyvars	$
		  extendIfaceIdEnv arg_ids	$
		  tcIfaceExpr rhs
	; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
810
811

tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
812
813
814
815
816
817
818
819
820
821
822
823
  = ASSERT( isTupleTyCon tycon )
    do	{ let [data_con] = tyConDataCons tycon
	; tcVanillaAlt data_con inst_tys arg_occs rhs }

tcVanillaAlt data_con inst_tys arg_occs rhs
  = do	{ arg_names <- newIfaceNames arg_occs
	; let arg_tys = dataConArgTys data_con inst_tys
	; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
				 ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
			zipWith mkLocalId arg_names arg_tys
	; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
	; returnM (DataAlt data_con, arg_ids, rhs') }
824
825
826
827
\end{code}


\begin{code}
828
829
830
tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind]	-- Used for external core
tcExtCoreBindings []     = return []
tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
831

832
833
do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
do_one (IfaceNonRec bndr rhs) thing_inside
834
  = do	{ rhs' <- tcIfaceExpr rhs
835
	; bndr' <- newExtCoreBndr bndr
836
837
838
839
	; extendIfaceIdEnv [bndr'] $ do 
	{ core_binds <- thing_inside
	; return (NonRec bndr' rhs' : core_binds) }}

840
841
do_one (IfaceRec pairs) thing_inside
  = do	{ bndrs' <- mappM newExtCoreBndr bndrs
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
	; extendIfaceIdEnv bndrs' $ do
 	{ rhss' <- mappM tcIfaceExpr rhss
	; core_binds <- thing_inside
	; return (Rec (bndrs' `zip` rhss') : core_binds) }}
  where
    (bndrs,rhss) = unzip pairs
\end{code}


%************************************************************************
%*									*
		IdInfo
%*									*
%************************************************************************

\begin{code}
858
859
860
tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo name ty NoInfo		= return vanillaIdInfo
tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
  where
    -- Set the CgInfo to something sensible but uninformative before
    -- we start; default assumption is that it has CAFs
    init_info = vanillaIdInfo

    tcPrag info HsNoCafRefs         = returnM (info `setCafInfo`   NoCafRefs)
    tcPrag info (HsArity arity)     = returnM (info `setArityInfo` arity)
    tcPrag info (HsStrictness str)  = returnM (info `setAllStrictnessInfo` Just str)

	-- The next two are lazy, so they don't transitively suck stuff in
    tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
    tcPrag info (HsUnfold inline_prag expr)
	= tcPragExpr name expr 	`thenM` \ maybe_expr' ->
	  let
		-- maybe_expr' doesn't get looked at if the unfolding
		-- is never inspected; so the typecheck doesn't even happen
		unfold_info = case maybe_expr' of
				Nothing    -> noUnfolding
				Just expr' -> mkTopUnfolding expr' 
	  in
 	  returnM (info `setUnfoldingInfoLazily` unfold_info
			`setInlinePragInfo`      inline_prag)
\end{code}

\begin{code}
886
887
tcWorkerInfo ty info wkr arity
  = do 	{ mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
888
889
890
891
892
893
894
895
896
897
898
899

	-- We return without testing maybe_wkr_id, but as soon as info is
	-- looked at we will test it.  That's ok, because its outside the
	-- knot; and there seems no big reason to further defer the
	-- tcIfaceId lookup.  (Contrast with tcPragExpr, where postponing walking
	-- over the unfolding until it's actually used does seem worth while.)
	; us <- newUniqueSupply

	; returnM (case mb_wkr_id of
		     Nothing     -> info
		     Just wkr_id -> add_wkr_info us wkr_id info) }
  where
900
    doc = text "Worker for" <+> ppr wkr
901
902
903
904
905
906
907
908
909
910
    add_wkr_info us wkr_id info
	= info `setUnfoldingInfoLazily`  mk_unfolding us wkr_id
	       `setWorkerInfo`           HasWorker wkr_id arity

    mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)

    	-- We are relying here on strictness info always appearing 
	-- before worker info,  fingers crossed ....
    strict_sig = case newStrictnessInfo info of
		   Just sig -> sig
911
		   Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr)
912
913
914
915
916
917
918
919
920
921
922
923
924
\end{code}

For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.

\begin{code}
tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr name expr
  = forkM_maybe doc $
    tcIfaceExpr expr		`thenM` \ core_expr' ->

		-- Check for type consistency in the unfolding
    ifOptM Opt_DoCoreLinting (
925
926
	get_in_scope_ids			`thenM` \ in_scope -> 
	case lintUnfolding noSrcLoc in_scope core_expr' of
927
928
929
930
931
932
933
	  Nothing       -> returnM ()
	  Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
    )				`thenM_`

   returnM core_expr'	
  where
    doc = text "Unfolding of" <+> ppr name
934
935
936
937
938
939
940
941
    get_in_scope_ids 	-- Urgh; but just for linting
	= setLclEnv () $ 
	  do	{ env <- getGblEnv 
		; case if_rec_types env of {
			  Nothing -> return [] ;
			  Just (_, get_env) -> do
		{ type_env <- get_env
		; return (typeEnvIds type_env) }}}
942
943
944
945
\end{code}



946
947
948
949
950
951
952
%************************************************************************
%*									*
		Getting from Names to TyThings
%*									*
%************************************************************************

\begin{code}
953
tcIfaceGlobal :: Name -> IfL TyThing
954
955
956
957
tcIfaceGlobal name
  = do	{ (eps,hpt) <- getEpsAndHpt
	; case lookupType hpt (eps_PTE eps) name of {
	    Just thing -> return thing ;
958
	    Nothing    -> do
959
960

	{ env <- getGblEnv
961
	; case if_rec_types env of {
962
963
964
	    Just (mod, get_type_env) 
		| nameIsLocalOrFrom mod name
		-> do 		-- It's defined in the module being compiled
965
	  	{ type_env <- setLclEnv () get_type_env		-- yuk
966
967
968
969
970
		; case lookupNameEnv type_env name of
			Just thing -> return thing
			Nothing	   -> pprPanic "tcIfaceGlobal (local): not found:"  
						(ppr name $$ ppr type_env) }

971
	  ; other -> do
972
973
974
975
976

	{ mb_thing <- importDecl name 	-- It's imported; go get it
	; case mb_thing of
	    Failed err      -> failIfM err
	    Succeeded thing -> return thing
977
    }}}}}
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000

tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon IfaceIntTc  = return intTyCon
tcIfaceTyCon IfaceBoolTc = return boolTyCon
tcIfaceTyCon IfaceCharTc = return charTyCon
tcIfaceTyCon IfaceListTc = return listTyCon
tcIfaceTyCon IfacePArrTc = return parrTyCon
tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
				   ; thing <- tcIfaceGlobal name
				   ; return (tyThingTyCon thing) }

tcIfaceClass :: IfaceExtName -> IfL Class
tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
			   ; thing <- tcIfaceGlobal name
			   ; return (tyThingClass thing) }

tcIfaceDataCon :: IfaceExtName -> IfL DataCon
tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
			; thing <- tcIfaceGlobal name
		 	; case thing of
				ADataCon dc -> return dc
				other   -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
For faster browsing, not all history is shown. View entire blame