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, discardDeclPrags )
17 import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig,
18 extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
19 tcIfaceTyVar, tcIfaceLclId,
20 newIfaceName, newIfaceNames )
21 import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
22 mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
24 import Type ( liftedTypeKind, splitTyConApp,
25 mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
26 import TypeRep ( Type(..), PredType(..) )
27 import TyCon ( TyCon, tyConName )
28 import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
29 HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon,
30 ModIface(..), ModDetails(..), ModGuts,
31 mkTypeEnv, extendTypeEnv,
32 lookupTypeEnv, lookupType, typeEnvIds )
33 import InstEnv ( extendInstEnvList )
35 import PprCore ( pprIdRules )
36 import Rules ( extendRuleBaseList )
37 import CoreUtils ( exprType )
39 import CoreLint ( lintUnfolding )
40 import WorkWrap ( mkWrapper )
41 import InstEnv ( DFunId )
42 import Id ( Id, mkVanillaGlobal, mkLocalId )
43 import MkId ( mkFCallId )
44 import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
45 setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo,
46 setArityInfo, setInlinePragInfo, setCafInfo,
47 vanillaIdInfo, newStrictnessInfo )
48 import Class ( Class )
49 import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
50 import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon )
51 import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
52 import Var ( TyVar, mkTyVar, tyVarKind )
53 import Name ( Name, nameModule, nameIsLocalOrFrom,
54 isWiredInName, wiredInNameTyThing_maybe, nameParent )
56 import OccName ( OccName )
57 import Module ( Module )
58 import UniqSupply ( initUs_ )
60 import ErrUtils ( Message )
61 import Maybes ( MaybeErr(..) )
62 import SrcLoc ( noSrcLoc )
63 import Util ( zipWithEqual, dropList, equalLength, zipLazy )
64 import CmdLineOpts ( DynFlag(..) )
73 An IfaceDecl is populated with RdrNames, and these are not renamed to
74 Names before typechecking, because there should be no scope errors etc.
76 -- For (b) consider: f = $(...h....)
77 -- where h is imported, and calls f via an hi-boot file.
78 -- This is bad! But it is not seen as a staging error, because h
79 -- is indeed imported. We don't want the type-checker to black-hole
80 -- when simplifying and compiling the splice!
82 -- Simple solution: discard any unfolding that mentions a variable
83 -- bound in this module (and hence not yet processed).
84 -- The discarding happens when forkM finds a type error.
86 %************************************************************************
88 %* tcImportDecl is the key function for "faulting in" *
91 %************************************************************************
93 The main idea is this. We are chugging along type-checking source code, and
94 find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find
95 it in the EPS type envt. So it
97 2 gets the decl for GHC.Base.map
98 3 typechecks it via tcIfaceDecl
99 4 and adds it to the type env in the EPS
101 Note that DURING STEP 4, we may find that map's type mentions a type
102 constructor that also
104 Notice that for imported things we read the current version from the EPS
105 mutable variable. This is important in situations like
107 where the code that e1 expands to might import some defns that
108 also turn out to be needed by the code that e2 expands to.
111 tcImportDecl :: Name -> TcM TyThing
112 -- Entry point for source-code uses of importDecl
114 = do { traceIf (text "tcLookupGlobal" <+> ppr name)
115 ; mb_thing <- initIfaceTcRn (importDecl name)
117 Succeeded thing -> return thing
118 Failed err -> failWithTc err }
120 importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
121 -- Get the TyThing for this Name from an interface file
123 | Just thing <- wiredInNameTyThing_maybe name
124 -- This case definitely happens for tuples, because we
125 -- don't know how many of them we'll find
126 -- It also now happens for all other wired in things. We used
127 -- to pre-populate the eps_PTE with other wired-in things, but
128 -- we don't seem to do that any more. I guess it keeps the PTE smaller?
129 = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing })
130 ; return (Succeeded thing) }
133 = do { traceIf nd_doc
135 -- Load the interface, which should populate the PTE
136 ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
138 Failed err_msg -> return (Failed err_msg) ;
139 Succeeded iface -> do
141 -- Now look it up again; this time we should find it
143 ; case lookupTypeEnv (eps_PTE eps) name of
144 Just thing -> return (Succeeded thing)
145 Nothing -> return (Failed not_found_msg)
148 nd_doc = ptext SLIT("Need decl for") <+> ppr name
149 not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
150 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
151 ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
154 %************************************************************************
156 Type-checking a complete interface
158 %************************************************************************
160 Suppose we discover we don't need to recompile. Then we must type
161 check the old interface file. This is a bit different to the
162 incremental type checking we do as we suck in interface files. Instead
163 we do things similarly as when we are typechecking source decls: we
164 bring into scope the type envt for the interface all at once, using a
165 knot. Remember, the decls aren't necessarily in dependency order --
166 and even if they were, the type decls might be mutually recursive.
169 typecheckIface :: HscEnv
170 -> ModIface -- Get the decls from here
172 typecheckIface hsc_env iface
173 = initIfaceTc hsc_env iface $ \ tc_env_var -> do
174 { -- Get the right set of decls and rules. If we are compiling without -O
175 -- we discard pragmas before typechecking, so that we don't "see"
176 -- information that we shouldn't. From a versioning point of view
177 -- It's not actually *wrong* to do so, but in fact GHCi is unable
178 -- to handle unboxed tuples, so it must not see unfoldings.
179 ignore_prags <- doptM Opt_IgnoreInterfacePragmas
180 ; let { decls | ignore_prags = map (discardDeclPrags . snd) (mi_decls iface)
181 | otherwise = map snd (mi_decls iface)
182 ; rules | ignore_prags = []
183 | otherwise = mi_rules iface
184 ; dfuns = mi_insts iface
185 ; mod = mi_module iface
187 -- Typecheck the decls
188 ; names <- mappM (lookupOrig mod . ifName) decls
189 ; ty_things <- fixM (\ rec_ty_things -> do
190 { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things))
191 -- This only makes available the "main" things,
192 -- but that's enough for the strictly-checked part
193 ; mapM tcIfaceDecl decls })
195 -- Now augment the type envt with all the implicit things
196 -- These will be needed when type-checking the unfoldings for
197 -- the IfaceIds, but this is done lazily, so writing the thing
199 ; let { add_implicits main_thing = main_thing : implicitTyThings main_thing
200 ; type_env = mkTypeEnv (concatMap add_implicits ty_things) }
201 ; writeMutVar tc_env_var type_env
203 -- Now do those rules and instances
204 ; dfuns <- mapM tcIfaceInst dfuns
205 ; rules <- mapM tcIfaceRule rules
208 ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules })
213 %************************************************************************
215 Type and class declarations
217 %************************************************************************
219 When typechecking a data type decl, we *lazily* (via forkM) typecheck
220 the constructor argument types. This is in the hope that we may never
221 poke on those argument types, and hence may never need to load the
222 interface files for types mentioned in the arg types.
225 data Foo.S = MkS Baz.T
226 Mabye we can get away without even loading the interface for Baz!
228 This is not just a performance thing. Suppose we have
229 data Foo.S = MkS Baz.T
230 data Baz.T = MkT Foo.S
231 (in different interface files, of course).
232 Now, first we load and typecheck Foo.S, and add it to the type envt.
233 If we do explore MkS's argument, we'll load and typecheck Baz.T.
234 If we explore MkT's argument we'll find Foo.S already in the envt.
236 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
237 typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S...
238 which isn't done yet.
240 All very cunning. However, there is a rather subtle gotcha which bit
241 me when developing this stuff. When we typecheck the decl for S, we
242 extend the type envt with S, MkS, and all its implicit Ids. Suppose
243 (a bug, but it happened) that the list of implicit Ids depended in
244 turn on the constructor arg types. Then the following sequence of
246 * we build a thunk <t> for the constructor arg tys
247 * we build a thunk for the extended type environment (depends on <t>)
248 * we write the extended type envt into the global EPS mutvar
250 Now we look something up in the type envt
252 * which reads the global type envt out of the global EPS mutvar
253 * but that depends in turn on <t>
255 It's subtle, because, it'd work fine if we typechecked the constructor args
256 eagerly -- they don't need the extended type envt. They just get the extended
257 type envt by accident, because they look at it later.
259 What this means is that the implicitTyThings MUST NOT DEPEND on any of
264 tcIfaceDecl :: IfaceDecl -> IfL TyThing
266 tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
267 = do { name <- lookupIfaceTop occ_name
268 ; ty <- tcIfaceType iface_type
269 ; info <- tcIdInfo name ty info
270 ; return (AnId (mkVanillaGlobal name ty info)) }
272 tcIfaceDecl (IfaceData {ifName = occ_name,
275 ifVrcs = arg_vrcs, ifRec = is_rec,
276 ifGeneric = want_generic })
277 = do { tc_name <- lookupIfaceTop occ_name
278 ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
280 { tycon <- fixM ( \ tycon -> do
281 { cons <- tcIfaceDataCons tycon tyvars rdr_cons
282 ; tycon <- buildAlgTyCon tc_name tyvars cons
283 arg_vrcs is_rec want_generic
286 ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
287 ; return (ATyCon tycon)
290 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
291 ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
292 = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
293 { tc_name <- lookupIfaceTop occ_name
294 ; rhs_ty <- tcIfaceType rdr_rhs_ty
295 ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
298 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
299 ifFDs = rdr_fds, ifSigs = rdr_sigs,
300 ifVrcs = tc_vrcs, ifRec = tc_isrec })
301 = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
302 { cls_name <- lookupIfaceTop occ_name
303 ; ctxt <- tcIfaceCtxt rdr_ctxt
304 ; sigs <- mappM tc_sig rdr_sigs
305 ; fds <- mappM tc_fd rdr_fds
306 ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
307 ; return (AClass cls) }
309 tc_sig (IfaceClassOp occ dm rdr_ty)
310 = do { op_name <- lookupIfaceTop occ
311 ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
312 -- Must be done lazily for just the same reason as the
313 -- context of a data decl: the type sig might mention the
314 -- class being defined
315 ; return (op_name, dm, op_ty) }
317 mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]
319 tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
320 ; tvs2' <- mappM tcIfaceTyVar tvs2
321 ; return (tvs1', tvs2') }
323 tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
324 = do { name <- lookupIfaceTop rdr_name
325 ; return (ATyCon (mkForeignTyCon name ext_name
326 liftedTypeKind 0 [])) }
328 tcIfaceDataCons tycon tc_tyvars if_cons
330 IfAbstractTyCon -> return mkAbstractTyConRhs
331 IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt
332 ; data_cons <- mappM tc_con_decl cons
333 ; return (mkDataTyConRhs mb_theta data_cons) }
334 IfNewTyCon con -> do { data_con <- tc_con_decl con
335 ; return (mkNewTyConRhs tycon data_con) }
337 tc_ctxt Nothing = return Nothing
338 tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) }
340 tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args,
341 ifConStricts = stricts, ifConFields = field_lbls})
342 = do { name <- lookupIfaceTop occ
343 -- Read the argument types, but lazily to avoid faulting in
344 -- the component types unless they are really needed
345 ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
346 ; lbl_names <- mappM lookupIfaceTop field_lbls
347 ; buildDataCon name is_infix True {- Vanilla -}
349 tc_tyvars [] arg_tys tycon
350 (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys
353 tc_con_decl (IfGadtCon { ifConTyVars = con_tvs,
354 ifConOcc = occ, ifConCtxt = ctxt,
355 ifConArgTys = args, ifConResTys = ress,
356 ifConStricts = stricts})
357 = bindIfaceTyVars con_tvs $ \ con_tyvars -> do
358 { name <- lookupIfaceTop occ
359 ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
360 -- At one stage I thought that this context checking *had*
361 -- to be lazy, because of possible mutual recursion between the
362 -- type and the classe:
364 -- class Real a where { toRat :: a -> Ratio Integer }
365 -- data (Real a) => Ratio a = ...
366 -- But now I think that the laziness in checking class ops breaks
367 -- the loop, so no laziness needed
369 -- Read the argument types, but lazily to avoid faulting in
370 -- the component types unless they are really needed
371 ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
372 ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
374 ; buildDataCon name False {- Not infix -} False {- Not vanilla -}
375 stricts [{- No fields -}]
377 arg_tys tycon res_tys
379 mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
383 %************************************************************************
387 %************************************************************************
389 The gating story for instance declarations
390 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
391 When we are looking for a dict (C t1..tn), we slurp in instance decls for
393 mention at least one of the type constructors
394 at the roots of t1..tn
396 Why "at least one" rather than "all"? Because functional dependencies
397 complicate the picture. Consider
398 class C a b | a->b where ...
399 instance C Foo Baz where ...
400 Here, the gates are really only C and Foo, *not* Baz.
401 That is, if C and Foo are visible, even if Baz isn't, we must
402 slurp the decl, even if Baz is thus far completely unknown to the
405 Why "roots of the types"? Reason is overlap. For example, suppose there
406 are interfaces in the pool for
410 Then, if we are trying to resolve (C Int x), we need (a)
411 if we are trying to resolve (C x [y]), we need *both* (b) and (c),
412 even though T is not involved yet, so that we spot the overlap.
415 NOTE: if you use an instance decl with NO type constructors
416 instance C a where ...
417 and look up an Inst that only has type variables such as (C (n o))
418 then GHC won't necessarily suck in the instances that overlap with this.
422 loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv
423 loadImportedInsts cls tys
424 = do { -- Get interfaces for wired-in things, such as Integer
425 -- Any non-wired-in tycons will already be loaded, else
426 -- we couldn't have them in the Type
427 ; this_mod <- getModule
428 ; let { (cls_gate, tc_gates) = predInstGates cls tys
429 ; imp_wi n = isWiredInName n && this_mod /= nameModule n
430 ; wired_tcs = filter imp_wi tc_gates }
431 -- Wired-in tycons not from this module. The "this-module"
432 -- test bites only when compiling Base etc, because loadHomeInterface
433 -- barfs if it's asked to load a non-existent interface
434 ; if null wired_tcs then returnM ()
435 else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs)
437 -- Now suck in the relevant instances
438 ; iface_insts <- updateEps (selectInsts cls_gate tc_gates)
440 -- Empty => finish up rapidly, without writing to eps
441 ; if null iface_insts then
442 do { eps <- getEps; return (eps_inst_env eps) }
444 { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
445 nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])])
447 -- Typecheck the new instances
448 ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
450 -- And put them in the package instance environment
451 ; updateEps ( \ eps ->
453 inst_env' = extendInstEnvList (eps_inst_env eps) dfuns
455 (eps { eps_inst_env = inst_env' }, inst_env')
458 wired_doc = ptext SLIT("Need home inteface for wired-in thing")
460 tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst)
462 full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr inst))
464 tcIfaceInst :: IfaceInst -> IfL DFunId
465 tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
466 = tcIfaceExtId (LocalTop dfun_occ)
468 selectInsts :: Name -> [Name] -> ExternalPackageState
469 -> (ExternalPackageState, [(Module, SDoc, IfaceInst)])
470 selectInsts cls tycons eps
471 = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts)
473 insts = eps_insts eps
474 stats = eps_stats eps
475 stats' = stats { n_insts_out = n_insts_out stats + length iface_insts }
477 (insts', iface_insts)
478 = case lookupNameEnv insts cls of {
479 Nothing -> (insts, []) ;
482 case choose1 gated_insts of {
483 (_, []) -> (insts, []) ; -- None picked
484 (gated_insts', iface_insts') ->
486 (extendNameEnv insts cls gated_insts', iface_insts') }}
489 | null tycons -- Bizarre special case of C (a b); then there are no tycons
490 = ([], map snd gated_insts) -- Just grab all the instances, no real alternative
491 | otherwise -- Normal case
492 = foldl choose2 ([],[]) gated_insts
494 -- Reverses the gated decls, but that doesn't matter
495 choose2 (gis, decls) (gates, decl)
496 | null gates -- Happens when we have 'instance T a where ...'
497 || any (`elem` tycons) gates = (gis, decl:decls)
498 | otherwise = ((gates,decl) : gis, decls)
501 %************************************************************************
505 %************************************************************************
507 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
508 are in the type environment. However, remember that typechecking a Rule may
509 (as a side effect) augment the type envt, and so we may need to iterate the process.
512 loadImportedRules :: HscEnv -> ModGuts -> IO [IdCoreRule]
513 -- Returns just the new rules added
514 loadImportedRules hsc_env guts
515 = initIfaceRules hsc_env guts $ do
517 if_rules <- updateEps selectRules
519 ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules])
521 ; core_rules <- mapM tc_rule if_rules
524 ; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules)
526 -- Update the rule base and return it
527 ; updateEps (\ eps ->
528 let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
529 in (eps { eps_rule_base = new_rule_base }, new_rule_base)
532 -- Strictly speaking, at this point we should go round again, since
533 -- typechecking one set of rules may bring in new things which enable
534 -- some more rules to come in. But we call loadImportedRules several
535 -- times anyway, so I'm going to be lazy and ignore this.
539 tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule)
541 full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule))
543 selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)])
544 -- Not terribly efficient. Look at each rule in the pool to see if
545 -- all its gates are in the type env. If so, take it out of the pool.
546 -- If not, trim its gates for next time.
548 = (eps { eps_rules = rules', eps_stats = stats' }, if_rules)
550 stats = eps_stats eps
551 rules = eps_rules eps
552 type_env = eps_PTE eps
553 stats' = stats { n_rules_out = n_rules_out stats + length if_rules }
555 (rules', if_rules) = foldl do_one ([], []) rules
557 do_one (pool, if_rules) (gates, rule)
558 | null gates' = (pool, rule:if_rules)
559 | otherwise = ((gates',rule) : pool, if_rules)
561 gates' = filter (not . (`elemNameEnv` type_env)) gates
564 tcIfaceRule :: IfaceRule -> IfL IdCoreRule
565 tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,
566 ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs })
567 = bindIfaceBndrs bndrs $ \ bndrs' ->
568 do { fn <- tcIfaceExtId fn_rdr
569 ; args' <- mappM tcIfaceExpr args
570 ; rhs' <- tcIfaceExpr rhs
571 ; let rule = Rule rule_name act bndrs' args' rhs'
572 ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) }
575 tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
576 = do { fn <- tcIfaceExtId fn_rdr
577 ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }
579 isOrphNm :: IfaceExtName -> Bool
580 isOrphNm (LocalTop _) = False
581 isOrphNm (LocalTopSub _ _) = False
582 isOrphNm other = True
586 %************************************************************************
590 %************************************************************************
593 tcIfaceType :: IfaceType -> IfL Type
594 tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
595 tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
596 tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
597 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkGenTyConApp tc' ts') }
598 tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
599 tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
601 tcIfaceTypes tys = mapM tcIfaceType tys
603 -----------------------------------------
604 tcIfacePredType :: IfacePredType -> IfL PredType
605 tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
606 tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
608 -----------------------------------------
609 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
610 tcIfaceCtxt sts = mappM tcIfacePredType sts
614 %************************************************************************
618 %************************************************************************
621 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
622 tcIfaceExpr (IfaceType ty)
623 = tcIfaceType ty `thenM` \ ty' ->
626 tcIfaceExpr (IfaceLcl name)
627 = tcIfaceLclId name `thenM` \ id ->
630 tcIfaceExpr (IfaceExt gbl)
631 = tcIfaceExtId gbl `thenM` \ id ->
634 tcIfaceExpr (IfaceLit lit)
637 tcIfaceExpr (IfaceFCall cc ty)
638 = tcIfaceType ty `thenM` \ ty' ->
639 newUnique `thenM` \ u ->
640 returnM (Var (mkFCallId u cc ty'))
642 tcIfaceExpr (IfaceTuple boxity args)
643 = mappM tcIfaceExpr args `thenM` \ args' ->
645 -- Put the missing type arguments back in
646 con_args = map (Type . exprType) args' ++ args'
648 returnM (mkApps (Var con_id) con_args)
651 con_id = dataConWorkId (tupleCon boxity arity)
654 tcIfaceExpr (IfaceLam bndr body)
655 = bindIfaceBndr bndr $ \ bndr' ->
656 tcIfaceExpr body `thenM` \ body' ->
657 returnM (Lam bndr' body')
659 tcIfaceExpr (IfaceApp fun arg)
660 = tcIfaceExpr fun `thenM` \ fun' ->
661 tcIfaceExpr arg `thenM` \ arg' ->
662 returnM (App fun' arg')
664 tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
665 = tcIfaceExpr scrut `thenM` \ scrut' ->
666 newIfaceName case_bndr `thenM` \ case_bndr_name ->
668 scrut_ty = exprType scrut'
669 case_bndr' = mkLocalId case_bndr_name scrut_ty
670 tc_app = splitTyConApp scrut_ty
671 -- NB: Won't always succeed (polymoprhic case)
672 -- but won't be demanded in those cases
673 -- NB: not tcSplitTyConApp; we are looking at Core here
674 -- look through non-rec newtypes to find the tycon that
675 -- corresponds to the datacon in this case alternative
677 extendIfaceIdEnv [case_bndr'] $
678 mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' ->
679 tcIfaceType ty `thenM` \ ty' ->
680 returnM (Case scrut' case_bndr' ty' alts')
682 tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
683 = tcIfaceExpr rhs `thenM` \ rhs' ->
684 bindIfaceId bndr $ \ bndr' ->
685 tcIfaceExpr body `thenM` \ body' ->
686 returnM (Let (NonRec bndr' rhs') body')
688 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
689 = bindIfaceIds bndrs $ \ bndrs' ->
690 mappM tcIfaceExpr rhss `thenM` \ rhss' ->
691 tcIfaceExpr body `thenM` \ body' ->
692 returnM (Let (Rec (bndrs' `zip` rhss')) body')
694 (bndrs, rhss) = unzip pairs
696 tcIfaceExpr (IfaceNote note expr)
697 = tcIfaceExpr expr `thenM` \ expr' ->
699 IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' ->
700 returnM (Note (Coerce to_ty'
701 (exprType expr')) expr')
702 IfaceInlineCall -> returnM (Note InlineCall expr')
703 IfaceInlineMe -> returnM (Note InlineMe expr')
704 IfaceSCC cc -> returnM (Note (SCC cc) expr')
705 IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
707 -------------------------
708 tcIfaceAlt _ (IfaceDefault, names, rhs)
709 = ASSERT( null names )
710 tcIfaceExpr rhs `thenM` \ rhs' ->
711 returnM (DEFAULT, [], rhs')
713 tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
714 = ASSERT( null names )
715 tcIfaceExpr rhs `thenM` \ rhs' ->
716 returnM (LitAlt lit, [], rhs')
718 -- A case alternative is made quite a bit more complicated
719 -- by the fact that we omit type annotations because we can
720 -- work them out. True enough, but its not that easy!
721 tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
722 = do { let tycon_mod = nameModule (tyConName tycon)
723 ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
724 ; ASSERT2( con `elem` tyConDataCons tycon,
725 ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
727 if isVanillaDataCon con then
728 tcVanillaAlt con inst_tys arg_occs rhs
731 arg_names <- newIfaceNames arg_occs
732 ; let tyvars = [ mkTyVar name (tyVarKind tv)
733 | (name,tv) <- arg_names `zip` dataConTyVars con]
734 arg_tys = dataConArgTys con (mkTyVarTys tyvars)
735 id_names = dropList tyvars arg_names
736 arg_ids = ASSERT2( equalLength id_names arg_tys,
737 ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
738 zipWith mkLocalId id_names arg_tys
740 ; rhs' <- extendIfaceTyVarEnv tyvars $
741 extendIfaceIdEnv arg_ids $
743 ; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
745 tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
746 = ASSERT( isTupleTyCon tycon )
747 do { let [data_con] = tyConDataCons tycon
748 ; tcVanillaAlt data_con inst_tys arg_occs rhs }
750 tcVanillaAlt data_con inst_tys arg_occs rhs
751 = do { arg_names <- newIfaceNames arg_occs
752 ; let arg_tys = dataConArgTys data_con inst_tys
753 ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
754 ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
755 zipWith mkLocalId arg_names arg_tys
756 ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
757 ; returnM (DataAlt data_con, arg_ids, rhs') }
762 tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core
763 tcExtCoreBindings [] = return []
764 tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
766 do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
767 do_one (IfaceNonRec bndr rhs) thing_inside
768 = do { rhs' <- tcIfaceExpr rhs
769 ; bndr' <- newExtCoreBndr bndr
770 ; extendIfaceIdEnv [bndr'] $ do
771 { core_binds <- thing_inside
772 ; return (NonRec bndr' rhs' : core_binds) }}
774 do_one (IfaceRec pairs) thing_inside
775 = do { bndrs' <- mappM newExtCoreBndr bndrs
776 ; extendIfaceIdEnv bndrs' $ do
777 { rhss' <- mappM tcIfaceExpr rhss
778 ; core_binds <- thing_inside
779 ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
781 (bndrs,rhss) = unzip pairs
785 %************************************************************************
789 %************************************************************************
792 tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo
793 tcIdInfo name ty NoInfo = return vanillaIdInfo
794 tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info
796 -- Set the CgInfo to something sensible but uninformative before
797 -- we start; default assumption is that it has CAFs
798 init_info = vanillaIdInfo
800 tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs)
801 tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity)
802 tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str)
804 -- The next two are lazy, so they don't transitively suck stuff in
805 tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
806 tcPrag info (HsUnfold inline_prag expr)
807 = tcPragExpr name expr `thenM` \ maybe_expr' ->
809 -- maybe_expr' doesn't get looked at if the unfolding
810 -- is never inspected; so the typecheck doesn't even happen
811 unfold_info = case maybe_expr' of
812 Nothing -> noUnfolding
813 Just expr' -> mkTopUnfolding expr'
815 returnM (info `setUnfoldingInfoLazily` unfold_info
816 `setInlinePragInfo` inline_prag)
820 tcWorkerInfo ty info wkr arity
821 = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
823 -- We return without testing maybe_wkr_id, but as soon as info is
824 -- looked at we will test it. That's ok, because its outside the
825 -- knot; and there seems no big reason to further defer the
826 -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking
827 -- over the unfolding until it's actually used does seem worth while.)
828 ; us <- newUniqueSupply
830 ; returnM (case mb_wkr_id of
832 Just wkr_id -> add_wkr_info us wkr_id info) }
834 doc = text "Worker for" <+> ppr wkr
835 add_wkr_info us wkr_id info
836 = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
837 `setWorkerInfo` HasWorker wkr_id arity
839 mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
841 -- We are relying here on strictness info always appearing
842 -- before worker info, fingers crossed ....
843 strict_sig = case newStrictnessInfo info of
845 Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr)
848 For unfoldings we try to do the job lazily, so that we never type check
849 an unfolding that isn't going to be looked at.
852 tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
855 tcIfaceExpr expr `thenM` \ core_expr' ->
857 -- Check for type consistency in the unfolding
858 ifOptM Opt_DoCoreLinting (
859 get_in_scope_ids `thenM` \ in_scope ->
860 case lintUnfolding noSrcLoc in_scope core_expr' of
861 Nothing -> returnM ()
862 Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
867 doc = text "Unfolding of" <+> ppr name
868 get_in_scope_ids -- Urgh; but just for linting
870 do { env <- getGblEnv
871 ; case if_rec_types env of {
872 Nothing -> return [] ;
873 Just (_, get_env) -> do
874 { type_env <- get_env
875 ; return (typeEnvIds type_env) }}}
880 %************************************************************************
882 Getting from Names to TyThings
884 %************************************************************************
887 tcIfaceGlobal :: Name -> IfL TyThing
889 = do { (eps,hpt) <- getEpsAndHpt
890 ; case lookupType hpt (eps_PTE eps) name of {
891 Just thing -> return thing ;
895 ; case if_rec_types env of {
896 Just (mod, get_type_env)
897 | nameIsLocalOrFrom mod name
898 -> do -- It's defined in the module being compiled
899 { type_env <- setLclEnv () get_type_env -- yuk
900 ; case lookupNameEnv type_env name of
901 Just thing -> return thing
902 Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
903 (ppr name $$ ppr type_env) }
907 { mb_thing <- importDecl name -- It's imported; go get it
909 Failed err -> failIfM err
910 Succeeded thing -> return thing
913 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
914 tcIfaceTyCon IfaceIntTc = return intTyCon
915 tcIfaceTyCon IfaceBoolTc = return boolTyCon
916 tcIfaceTyCon IfaceCharTc = return charTyCon
917 tcIfaceTyCon IfaceListTc = return listTyCon
918 tcIfaceTyCon IfacePArrTc = return parrTyCon
919 tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
920 tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
921 ; thing <- tcIfaceGlobal name
922 ; return (tyThingTyCon thing) }
924 tcIfaceClass :: IfaceExtName -> IfL Class
925 tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
926 ; thing <- tcIfaceGlobal name
927 ; return (tyThingClass thing) }
929 tcIfaceDataCon :: IfaceExtName -> IfL DataCon
930 tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
931 ; thing <- tcIfaceGlobal name
933 ADataCon dc -> return dc
934 other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
936 tcIfaceExtId :: IfaceExtName -> IfL Id
937 tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
938 ; thing <- tcIfaceGlobal name
941 other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
944 %************************************************************************
948 %************************************************************************
951 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
952 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
953 = bindIfaceId bndr thing_inside
954 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
955 = bindIfaceTyVar bndr thing_inside
957 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
958 bindIfaceBndrs [] thing_inside = thing_inside []
959 bindIfaceBndrs (b:bs) thing_inside
960 = bindIfaceBndr b $ \ b' ->
961 bindIfaceBndrs bs $ \ bs' ->
962 thing_inside (b':bs')
964 -----------------------
965 bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a
966 bindIfaceId (occ, ty) thing_inside
967 = do { name <- newIfaceName occ
968 ; ty' <- tcIfaceType ty
969 ; let { id = mkLocalId name ty' }
970 ; extendIfaceIdEnv [id] (thing_inside id) }
972 bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a
973 bindIfaceIds bndrs thing_inside
974 = do { names <- newIfaceNames occs
975 ; tys' <- mappM tcIfaceType tys
976 ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
977 ; extendIfaceIdEnv ids (thing_inside ids) }
979 (occs,tys) = unzip bndrs
982 -----------------------
983 newExtCoreBndr :: (OccName, IfaceType) -> IfL Id
984 newExtCoreBndr (occ, ty)
985 = do { mod <- getIfModule
986 ; name <- newGlobalBinder mod occ Nothing noSrcLoc
987 ; ty' <- tcIfaceType ty
988 ; return (mkLocalId name ty') }
990 -----------------------
991 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
992 bindIfaceTyVar (occ,kind) thing_inside
993 = do { name <- newIfaceName occ
994 ; let tyvar = mk_iface_tyvar name kind
995 ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
997 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
998 bindIfaceTyVars bndrs thing_inside
999 = do { names <- newIfaceNames occs
1000 ; let tyvars = zipWith mk_iface_tyvar names kinds
1001 ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
1003 (occs,kinds) = unzip bndrs
1005 mk_iface_tyvar name kind = mkTyVar name kind