2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcIfaceSig]{Type checking of type signatures in interface files}
8 tcImportDecl, typecheckIface, tcIfaceDecl, tcIfaceGlobal,
9 loadImportedInsts, loadImportedRules,
13 #include "HsVersions.h"
16 import LoadIface ( loadHomeInterface, loadInterface, predInstGates,
17 discardDeclPrags, loadDecls )
18 import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig,
19 extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
20 tcIfaceTyVar, tcIfaceLclId,
21 newIfaceName, newIfaceNames )
22 import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
23 mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
25 import Type ( liftedTypeKind, splitTyConApp,
26 mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred )
27 import TypeRep ( Type(..), PredType(..) )
28 import TyCon ( TyCon, tyConName )
29 import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
30 HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon,
31 ModIface(..), ModDetails(..), ModGuts,
32 mkTypeEnv, extendTypeEnv,
33 lookupTypeEnv, lookupType, typeEnvIds )
34 import InstEnv ( extendInstEnvList )
36 import PprCore ( pprIdRules )
37 import Rules ( extendRuleBaseList )
38 import CoreUtils ( exprType )
40 import CoreLint ( lintUnfolding )
41 import WorkWrap ( mkWrapper )
42 import InstEnv ( DFunId )
43 import Id ( Id, mkVanillaGlobal, mkLocalId )
44 import MkId ( mkFCallId )
45 import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
46 setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo,
47 setArityInfo, setInlinePragInfo, setCafInfo,
48 vanillaIdInfo, newStrictnessInfo )
49 import Class ( Class )
50 import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
51 import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon )
52 import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
53 import Var ( TyVar, mkTyVar, tyVarKind )
54 import Name ( Name, nameModule, nameIsLocalOrFrom,
55 isWiredInName, wiredInNameTyThing_maybe, nameParent )
57 import OccName ( OccName )
58 import Module ( Module )
59 import UniqSupply ( initUs_ )
61 import ErrUtils ( Message )
62 import Maybes ( MaybeErr(..) )
63 import SrcLoc ( noSrcLoc )
64 import Util ( zipWithEqual, dropList, equalLength, zipLazy )
65 import CmdLineOpts ( DynFlag(..) )
74 An IfaceDecl is populated with RdrNames, and these are not renamed to
75 Names before typechecking, because there should be no scope errors etc.
77 -- For (b) consider: f = $(...h....)
78 -- where h is imported, and calls f via an hi-boot file.
79 -- This is bad! But it is not seen as a staging error, because h
80 -- is indeed imported. We don't want the type-checker to black-hole
81 -- when simplifying and compiling the splice!
83 -- Simple solution: discard any unfolding that mentions a variable
84 -- bound in this module (and hence not yet processed).
85 -- The discarding happens when forkM finds a type error.
87 %************************************************************************
89 %* tcImportDecl is the key function for "faulting in" *
92 %************************************************************************
94 The main idea is this. We are chugging along type-checking source code, and
95 find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find
96 it in the EPS type envt. So it
98 2 gets the decl for GHC.Base.map
99 3 typechecks it via tcIfaceDecl
100 4 and adds it to the type env in the EPS
102 Note that DURING STEP 4, we may find that map's type mentions a type
103 constructor that also
105 Notice that for imported things we read the current version from the EPS
106 mutable variable. This is important in situations like
108 where the code that e1 expands to might import some defns that
109 also turn out to be needed by the code that e2 expands to.
112 tcImportDecl :: Name -> TcM TyThing
113 -- Entry point for source-code uses of importDecl
115 = do { traceIf (text "tcLookupGlobal" <+> ppr name)
116 ; mb_thing <- initIfaceTcRn (importDecl name)
118 Succeeded thing -> return thing
119 Failed err -> failWithTc err }
121 importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
122 -- Get the TyThing for this Name from an interface file
124 | Just thing <- wiredInNameTyThing_maybe name
125 -- This case definitely happens for tuples, because we
126 -- don't know how many of them we'll find
127 -- It also now happens for all other wired in things. We used
128 -- to pre-populate the eps_PTE with other wired-in things, but
129 -- we don't seem to do that any more. I guess it keeps the PTE smaller?
130 = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing })
131 ; return (Succeeded thing) }
134 = do { traceIf nd_doc
136 -- Load the interface, which should populate the PTE
137 ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
139 Failed err_msg -> return (Failed err_msg) ;
140 Succeeded iface -> do
142 -- Now look it up again; this time we should find it
144 ; case lookupTypeEnv (eps_PTE eps) name of
145 Just thing -> return (Succeeded thing)
146 Nothing -> return (Failed not_found_msg)
149 nd_doc = ptext SLIT("Need decl for") <+> ppr name
150 not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
151 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
152 ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
155 %************************************************************************
157 Type-checking a complete interface
159 %************************************************************************
161 Suppose we discover we don't need to recompile. Then we must type
162 check the old interface file. This is a bit different to the
163 incremental type checking we do as we suck in interface files. Instead
164 we do things similarly as when we are typechecking source decls: we
165 bring into scope the type envt for the interface all at once, using a
166 knot. Remember, the decls aren't necessarily in dependency order --
167 and even if they were, the type decls might be mutually recursive.
170 typecheckIface :: HscEnv
171 -> ModIface -- Get the decls from here
173 typecheckIface hsc_env iface
174 = initIfaceTc hsc_env iface $ \ tc_env_var -> do
175 { -- Get the right set of decls and rules. If we are compiling without -O
176 -- we discard pragmas before typechecking, so that we don't "see"
177 -- information that we shouldn't. From a versioning point of view
178 -- It's not actually *wrong* to do so, but in fact GHCi is unable
179 -- to handle unboxed tuples, so it must not see unfoldings.
180 ignore_prags <- doptM Opt_IgnoreInterfacePragmas
182 -- Load & typecheck the decls
183 ; decl_things <- loadDecls ignore_prags (mi_decls iface)
185 ; let type_env = mkNameEnv decl_things
186 ; writeMutVar tc_env_var type_env
188 -- Now do those rules and instances
189 ; let { rules | ignore_prags = []
190 | otherwise = mi_rules iface
191 ; dfuns = mi_insts iface
193 ; dfuns <- mapM tcIfaceInst dfuns
194 ; rules <- mapM tcIfaceRule rules
197 ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules })
202 %************************************************************************
204 Type and class declarations
206 %************************************************************************
208 When typechecking a data type decl, we *lazily* (via forkM) typecheck
209 the constructor argument types. This is in the hope that we may never
210 poke on those argument types, and hence may never need to load the
211 interface files for types mentioned in the arg types.
214 data Foo.S = MkS Baz.T
215 Mabye we can get away without even loading the interface for Baz!
217 This is not just a performance thing. Suppose we have
218 data Foo.S = MkS Baz.T
219 data Baz.T = MkT Foo.S
220 (in different interface files, of course).
221 Now, first we load and typecheck Foo.S, and add it to the type envt.
222 If we do explore MkS's argument, we'll load and typecheck Baz.T.
223 If we explore MkT's argument we'll find Foo.S already in the envt.
225 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
226 typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S...
227 which isn't done yet.
229 All very cunning. However, there is a rather subtle gotcha which bit
230 me when developing this stuff. When we typecheck the decl for S, we
231 extend the type envt with S, MkS, and all its implicit Ids. Suppose
232 (a bug, but it happened) that the list of implicit Ids depended in
233 turn on the constructor arg types. Then the following sequence of
235 * we build a thunk <t> for the constructor arg tys
236 * we build a thunk for the extended type environment (depends on <t>)
237 * we write the extended type envt into the global EPS mutvar
239 Now we look something up in the type envt
241 * which reads the global type envt out of the global EPS mutvar
242 * but that depends in turn on <t>
244 It's subtle, because, it'd work fine if we typechecked the constructor args
245 eagerly -- they don't need the extended type envt. They just get the extended
246 type envt by accident, because they look at it later.
248 What this means is that the implicitTyThings MUST NOT DEPEND on any of
253 tcIfaceDecl :: IfaceDecl -> IfL TyThing
255 tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
256 = do { name <- lookupIfaceTop occ_name
257 ; ty <- tcIfaceType iface_type
258 ; info <- tcIdInfo name ty info
259 ; return (AnId (mkVanillaGlobal name ty info)) }
261 tcIfaceDecl (IfaceData {ifName = occ_name,
264 ifVrcs = arg_vrcs, ifRec = is_rec,
265 ifGeneric = want_generic })
266 = do { tc_name <- lookupIfaceTop occ_name
267 ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
269 { tycon <- fixM ( \ tycon -> do
270 { cons <- tcIfaceDataCons tycon tyvars rdr_cons
271 ; tycon <- buildAlgTyCon tc_name tyvars cons
272 arg_vrcs is_rec want_generic
275 ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
276 ; return (ATyCon tycon)
279 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
280 ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
281 = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
282 { tc_name <- lookupIfaceTop occ_name
283 ; rhs_ty <- tcIfaceType rdr_rhs_ty
284 ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
287 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
288 ifFDs = rdr_fds, ifSigs = rdr_sigs,
289 ifVrcs = tc_vrcs, ifRec = tc_isrec })
290 = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
291 { cls_name <- lookupIfaceTop occ_name
292 ; ctxt <- tcIfaceCtxt rdr_ctxt
293 ; sigs <- mappM tc_sig rdr_sigs
294 ; fds <- mappM tc_fd rdr_fds
295 ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
296 ; return (AClass cls) }
298 tc_sig (IfaceClassOp occ dm rdr_ty)
299 = do { op_name <- lookupIfaceTop occ
300 ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
301 -- Must be done lazily for just the same reason as the
302 -- context of a data decl: the type sig might mention the
303 -- class being defined
304 ; return (op_name, dm, op_ty) }
306 mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]
308 tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
309 ; tvs2' <- mappM tcIfaceTyVar tvs2
310 ; return (tvs1', tvs2') }
312 tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
313 = do { name <- lookupIfaceTop rdr_name
314 ; return (ATyCon (mkForeignTyCon name ext_name
315 liftedTypeKind 0 [])) }
317 tcIfaceDataCons tycon tc_tyvars if_cons
319 IfAbstractTyCon -> return mkAbstractTyConRhs
320 IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt
321 ; data_cons <- mappM tc_con_decl cons
322 ; return (mkDataTyConRhs mb_theta data_cons) }
323 IfNewTyCon con -> do { data_con <- tc_con_decl con
324 ; return (mkNewTyConRhs tycon data_con) }
326 tc_ctxt Nothing = return Nothing
327 tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) }
329 tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args,
330 ifConStricts = stricts, ifConFields = field_lbls})
331 = do { name <- lookupIfaceTop occ
332 -- Read the argument types, but lazily to avoid faulting in
333 -- the component types unless they are really needed
334 ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
335 ; lbl_names <- mappM lookupIfaceTop field_lbls
336 ; buildDataCon name is_infix True {- Vanilla -}
338 tc_tyvars [] arg_tys tycon
339 (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys
342 tc_con_decl (IfGadtCon { ifConTyVars = con_tvs,
343 ifConOcc = occ, ifConCtxt = ctxt,
344 ifConArgTys = args, ifConResTys = ress,
345 ifConStricts = stricts})
346 = bindIfaceTyVars con_tvs $ \ con_tyvars -> do
347 { name <- lookupIfaceTop occ
348 ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
349 -- At one stage I thought that this context checking *had*
350 -- to be lazy, because of possible mutual recursion between the
351 -- type and the classe:
353 -- class Real a where { toRat :: a -> Ratio Integer }
354 -- data (Real a) => Ratio a = ...
355 -- But now I think that the laziness in checking class ops breaks
356 -- the loop, so no laziness needed
358 -- Read the argument types, but lazily to avoid faulting in
359 -- the component types unless they are really needed
360 ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
361 ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
363 ; buildDataCon name False {- Not infix -} False {- Not vanilla -}
364 stricts [{- No fields -}]
366 arg_tys tycon res_tys
368 mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
372 %************************************************************************
376 %************************************************************************
378 The gating story for instance declarations
379 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
380 When we are looking for a dict (C t1..tn), we slurp in instance decls for
382 mention at least one of the type constructors
383 at the roots of t1..tn
385 Why "at least one" rather than "all"? Because functional dependencies
386 complicate the picture. Consider
387 class C a b | a->b where ...
388 instance C Foo Baz where ...
389 Here, the gates are really only C and Foo, *not* Baz.
390 That is, if C and Foo are visible, even if Baz isn't, we must
391 slurp the decl, even if Baz is thus far completely unknown to the
394 Why "roots of the types"? Reason is overlap. For example, suppose there
395 are interfaces in the pool for
399 Then, if we are trying to resolve (C Int x), we need (a)
400 if we are trying to resolve (C x [y]), we need *both* (b) and (c),
401 even though T is not involved yet, so that we spot the overlap.
404 NOTE: if you use an instance decl with NO type constructors
405 instance C a where ...
406 and look up an Inst that only has type variables such as (C (n o))
407 then GHC won't necessarily suck in the instances that overlap with this.
411 loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv
412 loadImportedInsts cls tys
413 = do { -- Get interfaces for wired-in things, such as Integer
414 -- Any non-wired-in tycons will already be loaded, else
415 -- we couldn't have them in the Type
416 ; this_mod <- getModule
417 ; let { (cls_gate, tc_gates) = predInstGates cls tys
418 ; imp_wi n = isWiredInName n && this_mod /= nameModule n
419 ; wired_tcs = filter imp_wi tc_gates }
420 -- Wired-in tycons not from this module. The "this-module"
421 -- test bites only when compiling Base etc, because loadHomeInterface
422 -- barfs if it's asked to load a non-existent interface
423 ; if null wired_tcs then returnM ()
424 else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs)
426 -- Now suck in the relevant instances
427 ; iface_insts <- updateEps (selectInsts cls_gate tc_gates)
429 -- Empty => finish up rapidly, without writing to eps
430 ; if null iface_insts then
431 do { eps <- getEps; return (eps_inst_env eps) }
433 { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
434 nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])])
436 -- Typecheck the new instances
437 ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
439 -- And put them in the package instance environment
440 ; updateEps ( \ eps ->
442 inst_env' = extendInstEnvList (eps_inst_env eps) dfuns
444 (eps { eps_inst_env = inst_env' }, inst_env')
447 wired_doc = ptext SLIT("Need home inteface for wired-in thing")
449 tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst)
451 full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr inst))
453 tcIfaceInst :: IfaceInst -> IfL DFunId
454 tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
455 = tcIfaceExtId (LocalTop dfun_occ)
457 selectInsts :: Name -> [Name] -> ExternalPackageState
458 -> (ExternalPackageState, [(Module, SDoc, IfaceInst)])
459 selectInsts cls tycons eps
460 = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts)
462 insts = eps_insts eps
463 stats = eps_stats eps
464 stats' = stats { n_insts_out = n_insts_out stats + length iface_insts }
466 (insts', iface_insts)
467 = case lookupNameEnv insts cls of {
468 Nothing -> (insts, []) ;
471 case choose1 gated_insts of {
472 (_, []) -> (insts, []) ; -- None picked
473 (gated_insts', iface_insts') ->
475 (extendNameEnv insts cls gated_insts', iface_insts') }}
478 | null tycons -- Bizarre special case of C (a b); then there are no tycons
479 = ([], map snd gated_insts) -- Just grab all the instances, no real alternative
480 | otherwise -- Normal case
481 = foldl choose2 ([],[]) gated_insts
483 -- Reverses the gated decls, but that doesn't matter
484 choose2 (gis, decls) (gates, decl)
485 | null gates -- Happens when we have 'instance T a where ...'
486 || any (`elem` tycons) gates = (gis, decl:decls)
487 | otherwise = ((gates,decl) : gis, decls)
490 %************************************************************************
494 %************************************************************************
496 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
497 are in the type environment. However, remember that typechecking a Rule may
498 (as a side effect) augment the type envt, and so we may need to iterate the process.
501 loadImportedRules :: HscEnv -> ModGuts -> IO [IdCoreRule]
502 -- Returns just the new rules added
503 loadImportedRules hsc_env guts
504 = initIfaceRules hsc_env guts $ do
506 if_rules <- updateEps selectRules
508 ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules])
510 ; core_rules <- mapM tc_rule if_rules
513 ; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules)
515 -- Update the rule base and return it
516 ; updateEps (\ eps ->
517 let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
518 in (eps { eps_rule_base = new_rule_base }, new_rule_base)
521 -- Strictly speaking, at this point we should go round again, since
522 -- typechecking one set of rules may bring in new things which enable
523 -- some more rules to come in. But we call loadImportedRules several
524 -- times anyway, so I'm going to be lazy and ignore this.
528 tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule)
530 full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule))
532 selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)])
533 -- Not terribly efficient. Look at each rule in the pool to see if
534 -- all its gates are in the type env. If so, take it out of the pool.
535 -- If not, trim its gates for next time.
537 = (eps { eps_rules = rules', eps_stats = stats' }, if_rules)
539 stats = eps_stats eps
540 rules = eps_rules eps
541 type_env = eps_PTE eps
542 stats' = stats { n_rules_out = n_rules_out stats + length if_rules }
544 (rules', if_rules) = foldl do_one ([], []) rules
546 do_one (pool, if_rules) (gates, rule)
547 | null gates' = (pool, rule:if_rules)
548 | otherwise = ((gates',rule) : pool, if_rules)
550 gates' = filter (not . (`elemNameEnv` type_env)) gates
553 tcIfaceRule :: IfaceRule -> IfL IdCoreRule
554 tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,
555 ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs })
556 = bindIfaceBndrs bndrs $ \ bndrs' ->
557 do { fn <- tcIfaceExtId fn_rdr
558 ; args' <- mappM tcIfaceExpr args
559 ; rhs' <- tcIfaceExpr rhs
560 ; let rule = Rule rule_name act bndrs' args' rhs'
561 ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) }
564 tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
565 = do { fn <- tcIfaceExtId fn_rdr
566 ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }
568 isOrphNm :: IfaceExtName -> Bool
569 -- An orphan name comes from somewhere other than this module,
570 -- so it has a non-local name
571 isOrphNm name = not (isLocalIfaceExtName name)
575 %************************************************************************
579 %************************************************************************
582 tcIfaceType :: IfaceType -> IfL Type
583 tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
584 tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
585 tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
586 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkGenTyConApp tc' ts') }
587 tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
588 tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
590 tcIfaceTypes tys = mapM tcIfaceType tys
592 -----------------------------------------
593 tcIfacePredType :: IfacePredType -> IfL PredType
594 tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
595 tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
597 -----------------------------------------
598 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
599 tcIfaceCtxt sts = mappM tcIfacePredType sts
603 %************************************************************************
607 %************************************************************************
610 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
611 tcIfaceExpr (IfaceType ty)
612 = tcIfaceType ty `thenM` \ ty' ->
615 tcIfaceExpr (IfaceLcl name)
616 = tcIfaceLclId name `thenM` \ id ->
619 tcIfaceExpr (IfaceExt gbl)
620 = tcIfaceExtId gbl `thenM` \ id ->
623 tcIfaceExpr (IfaceLit lit)
626 tcIfaceExpr (IfaceFCall cc ty)
627 = tcIfaceType ty `thenM` \ ty' ->
628 newUnique `thenM` \ u ->
629 returnM (Var (mkFCallId u cc ty'))
631 tcIfaceExpr (IfaceTuple boxity args)
632 = mappM tcIfaceExpr args `thenM` \ args' ->
634 -- Put the missing type arguments back in
635 con_args = map (Type . exprType) args' ++ args'
637 returnM (mkApps (Var con_id) con_args)
640 con_id = dataConWorkId (tupleCon boxity arity)
643 tcIfaceExpr (IfaceLam bndr body)
644 = bindIfaceBndr bndr $ \ bndr' ->
645 tcIfaceExpr body `thenM` \ body' ->
646 returnM (Lam bndr' body')
648 tcIfaceExpr (IfaceApp fun arg)
649 = tcIfaceExpr fun `thenM` \ fun' ->
650 tcIfaceExpr arg `thenM` \ arg' ->
651 returnM (App fun' arg')
653 tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
654 = tcIfaceExpr scrut `thenM` \ scrut' ->
655 newIfaceName case_bndr `thenM` \ case_bndr_name ->
657 scrut_ty = exprType scrut'
658 case_bndr' = mkLocalId case_bndr_name scrut_ty
659 tc_app = splitTyConApp scrut_ty
660 -- NB: Won't always succeed (polymoprhic case)
661 -- but won't be demanded in those cases
662 -- NB: not tcSplitTyConApp; we are looking at Core here
663 -- look through non-rec newtypes to find the tycon that
664 -- corresponds to the datacon in this case alternative
666 extendIfaceIdEnv [case_bndr'] $
667 mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' ->
668 tcIfaceType ty `thenM` \ ty' ->
669 returnM (Case scrut' case_bndr' ty' alts')
671 tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
672 = tcIfaceExpr rhs `thenM` \ rhs' ->
673 bindIfaceId bndr $ \ bndr' ->
674 tcIfaceExpr body `thenM` \ body' ->
675 returnM (Let (NonRec bndr' rhs') body')
677 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
678 = bindIfaceIds bndrs $ \ bndrs' ->
679 mappM tcIfaceExpr rhss `thenM` \ rhss' ->
680 tcIfaceExpr body `thenM` \ body' ->
681 returnM (Let (Rec (bndrs' `zip` rhss')) body')
683 (bndrs, rhss) = unzip pairs
685 tcIfaceExpr (IfaceNote note expr)
686 = tcIfaceExpr expr `thenM` \ expr' ->
688 IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' ->
689 returnM (Note (Coerce to_ty'
690 (exprType expr')) expr')
691 IfaceInlineCall -> returnM (Note InlineCall expr')
692 IfaceInlineMe -> returnM (Note InlineMe expr')
693 IfaceSCC cc -> returnM (Note (SCC cc) expr')
694 IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
696 -------------------------
697 tcIfaceAlt _ (IfaceDefault, names, rhs)
698 = ASSERT( null names )
699 tcIfaceExpr rhs `thenM` \ rhs' ->
700 returnM (DEFAULT, [], rhs')
702 tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
703 = ASSERT( null names )
704 tcIfaceExpr rhs `thenM` \ rhs' ->
705 returnM (LitAlt lit, [], rhs')
707 -- A case alternative is made quite a bit more complicated
708 -- by the fact that we omit type annotations because we can
709 -- work them out. True enough, but its not that easy!
710 tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
711 = do { let tycon_mod = nameModule (tyConName tycon)
712 ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
713 ; ASSERT2( con `elem` tyConDataCons tycon,
714 ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
716 if isVanillaDataCon con then
717 tcVanillaAlt con inst_tys arg_occs rhs
720 arg_names <- newIfaceNames arg_occs
721 ; let tyvars = [ mkTyVar name (tyVarKind tv)
722 | (name,tv) <- arg_names `zip` dataConTyVars con]
723 arg_tys = dataConArgTys con (mkTyVarTys tyvars)
724 id_names = dropList tyvars arg_names
725 arg_ids = ASSERT2( equalLength id_names arg_tys,
726 ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
727 zipWith mkLocalId id_names arg_tys
729 ; rhs' <- extendIfaceTyVarEnv tyvars $
730 extendIfaceIdEnv arg_ids $
732 ; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
734 tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
735 = ASSERT( isTupleTyCon tycon )
736 do { let [data_con] = tyConDataCons tycon
737 ; tcVanillaAlt data_con inst_tys arg_occs rhs }
739 tcVanillaAlt data_con inst_tys arg_occs rhs
740 = do { arg_names <- newIfaceNames arg_occs
741 ; let arg_tys = dataConArgTys data_con inst_tys
742 ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
743 ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
744 zipWith mkLocalId arg_names arg_tys
745 ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
746 ; returnM (DataAlt data_con, arg_ids, rhs') }
751 tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core
752 tcExtCoreBindings [] = return []
753 tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
755 do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
756 do_one (IfaceNonRec bndr rhs) thing_inside
757 = do { rhs' <- tcIfaceExpr rhs
758 ; bndr' <- newExtCoreBndr bndr
759 ; extendIfaceIdEnv [bndr'] $ do
760 { core_binds <- thing_inside
761 ; return (NonRec bndr' rhs' : core_binds) }}
763 do_one (IfaceRec pairs) thing_inside
764 = do { bndrs' <- mappM newExtCoreBndr bndrs
765 ; extendIfaceIdEnv bndrs' $ do
766 { rhss' <- mappM tcIfaceExpr rhss
767 ; core_binds <- thing_inside
768 ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
770 (bndrs,rhss) = unzip pairs
774 %************************************************************************
778 %************************************************************************
781 tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo
782 tcIdInfo name ty NoInfo = return vanillaIdInfo
783 tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info
785 -- Set the CgInfo to something sensible but uninformative before
786 -- we start; default assumption is that it has CAFs
787 init_info = vanillaIdInfo
789 tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs)
790 tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity)
791 tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str)
793 -- The next two are lazy, so they don't transitively suck stuff in
794 tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
795 tcPrag info (HsUnfold inline_prag expr)
796 = tcPragExpr name expr `thenM` \ maybe_expr' ->
798 -- maybe_expr' doesn't get looked at if the unfolding
799 -- is never inspected; so the typecheck doesn't even happen
800 unfold_info = case maybe_expr' of
801 Nothing -> noUnfolding
802 Just expr' -> mkTopUnfolding expr'
804 returnM (info `setUnfoldingInfoLazily` unfold_info
805 `setInlinePragInfo` inline_prag)
809 tcWorkerInfo ty info wkr arity
810 = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
812 -- We return without testing maybe_wkr_id, but as soon as info is
813 -- looked at we will test it. That's ok, because its outside the
814 -- knot; and there seems no big reason to further defer the
815 -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking
816 -- over the unfolding until it's actually used does seem worth while.)
817 ; us <- newUniqueSupply
819 ; returnM (case mb_wkr_id of
821 Just wkr_id -> add_wkr_info us wkr_id info) }
823 doc = text "Worker for" <+> ppr wkr
824 add_wkr_info us wkr_id info
825 = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
826 `setWorkerInfo` HasWorker wkr_id arity
828 mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
830 -- We are relying here on strictness info always appearing
831 -- before worker info, fingers crossed ....
832 strict_sig = case newStrictnessInfo info of
834 Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr)
837 For unfoldings we try to do the job lazily, so that we never type check
838 an unfolding that isn't going to be looked at.
841 tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
844 tcIfaceExpr expr `thenM` \ core_expr' ->
846 -- Check for type consistency in the unfolding
847 ifOptM Opt_DoCoreLinting (
848 get_in_scope_ids `thenM` \ in_scope ->
849 case lintUnfolding noSrcLoc in_scope core_expr' of
850 Nothing -> returnM ()
851 Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
856 doc = text "Unfolding of" <+> ppr name
857 get_in_scope_ids -- Urgh; but just for linting
859 do { env <- getGblEnv
860 ; case if_rec_types env of {
861 Nothing -> return [] ;
862 Just (_, get_env) -> do
863 { type_env <- get_env
864 ; return (typeEnvIds type_env) }}}
869 %************************************************************************
871 Getting from Names to TyThings
873 %************************************************************************
876 tcIfaceGlobal :: Name -> IfL TyThing
878 = do { (eps,hpt) <- getEpsAndHpt
879 ; case lookupType hpt (eps_PTE eps) name of {
880 Just thing -> return thing ;
884 ; case if_rec_types env of {
885 Just (mod, get_type_env)
886 | nameIsLocalOrFrom mod name
887 -> do -- It's defined in the module being compiled
888 { type_env <- setLclEnv () get_type_env -- yuk
889 ; case lookupNameEnv type_env name of
890 Just thing -> return thing
891 Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
892 (ppr name $$ ppr type_env) }
896 { mb_thing <- importDecl name -- It's imported; go get it
898 Failed err -> failIfM err
899 Succeeded thing -> return thing
902 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
903 tcIfaceTyCon IfaceIntTc = return intTyCon
904 tcIfaceTyCon IfaceBoolTc = return boolTyCon
905 tcIfaceTyCon IfaceCharTc = return charTyCon
906 tcIfaceTyCon IfaceListTc = return listTyCon
907 tcIfaceTyCon IfacePArrTc = return parrTyCon
908 tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
909 tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
910 ; thing <- tcIfaceGlobal name
911 ; return (tyThingTyCon thing) }
913 tcIfaceClass :: IfaceExtName -> IfL Class
914 tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
915 ; thing <- tcIfaceGlobal name
916 ; return (tyThingClass thing) }
918 tcIfaceDataCon :: IfaceExtName -> IfL DataCon
919 tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
920 ; thing <- tcIfaceGlobal name
922 ADataCon dc -> return dc
923 other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
925 tcIfaceExtId :: IfaceExtName -> IfL Id
926 tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
927 ; thing <- tcIfaceGlobal name
930 other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
933 %************************************************************************
937 %************************************************************************
940 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
941 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
942 = bindIfaceId bndr thing_inside
943 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
944 = bindIfaceTyVar bndr thing_inside
946 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
947 bindIfaceBndrs [] thing_inside = thing_inside []
948 bindIfaceBndrs (b:bs) thing_inside
949 = bindIfaceBndr b $ \ b' ->
950 bindIfaceBndrs bs $ \ bs' ->
951 thing_inside (b':bs')
953 -----------------------
954 bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a
955 bindIfaceId (occ, ty) thing_inside
956 = do { name <- newIfaceName occ
957 ; ty' <- tcIfaceType ty
958 ; let { id = mkLocalId name ty' }
959 ; extendIfaceIdEnv [id] (thing_inside id) }
961 bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a
962 bindIfaceIds bndrs thing_inside
963 = do { names <- newIfaceNames occs
964 ; tys' <- mappM tcIfaceType tys
965 ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
966 ; extendIfaceIdEnv ids (thing_inside ids) }
968 (occs,tys) = unzip bndrs
971 -----------------------
972 newExtCoreBndr :: (OccName, IfaceType) -> IfL Id
973 newExtCoreBndr (occ, ty)
974 = do { mod <- getIfModule
975 ; name <- newGlobalBinder mod occ Nothing noSrcLoc
976 ; ty' <- tcIfaceType ty
977 ; return (mkLocalId name ty') }
979 -----------------------
980 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
981 bindIfaceTyVar (occ,kind) thing_inside
982 = do { name <- newIfaceName occ
983 ; let tyvar = mk_iface_tyvar name kind
984 ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
986 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
987 bindIfaceTyVars bndrs thing_inside
988 = do { names <- newIfaceNames occs
989 ; let tyvars = zipWith mk_iface_tyvar names kinds
990 ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
992 (occs,kinds) = unzip bndrs
994 mk_iface_tyvar name kind = mkTyVar name kind