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,
12 #include "HsVersions.h"
15 import LoadIface ( loadHomeInterface, predInstGates, discardDeclPrags )
16 import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig,
17 extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
18 tcIfaceTyVar, tcIfaceLclId,
19 newIfaceName, newIfaceNames )
20 import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
21 mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
23 import Type ( liftedTypeKind, splitTyConApp,
24 mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
25 import TypeRep ( Type(..), PredType(..) )
26 import TyCon ( TyCon, tyConName )
27 import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
28 HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon,
29 ModIface(..), ModDetails(..), ModGuts,
30 mkTypeEnv, extendTypeEnv,
31 lookupTypeEnv, lookupType, typeEnvIds )
32 import InstEnv ( extendInstEnv )
34 import PprCore ( pprIdRules )
35 import Rules ( extendRuleBaseList )
36 import CoreUtils ( exprType )
38 import CoreLint ( lintUnfolding )
39 import WorkWrap ( mkWrapper )
40 import InstEnv ( DFunId )
41 import Id ( Id, mkVanillaGlobal, mkLocalId )
42 import MkId ( mkFCallId )
43 import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
44 setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo,
45 setArityInfo, setInlinePragInfo, setCafInfo,
46 vanillaIdInfo, newStrictnessInfo )
47 import Class ( Class )
48 import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
49 import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon )
50 import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
51 import Var ( TyVar, mkTyVar, tyVarKind )
52 import Name ( Name, nameModule, nameIsLocalOrFrom,
53 isWiredInName, wiredInNameTyThing_maybe, nameParent )
55 import OccName ( OccName )
56 import Module ( Module )
57 import UniqSupply ( initUs_ )
59 import SrcLoc ( noSrcLoc )
60 import Util ( zipWithEqual, dropList, equalLength, zipLazy )
61 import CmdLineOpts ( DynFlag(..) )
70 An IfaceDecl is populated with RdrNames, and these are not renamed to
71 Names before typechecking, because there should be no scope errors etc.
73 -- For (b) consider: f = $(...h....)
74 -- where h is imported, and calls f via an hi-boot file.
75 -- This is bad! But it is not seen as a staging error, because h
76 -- is indeed imported. We don't want the type-checker to black-hole
77 -- when simplifying and compiling the splice!
79 -- Simple solution: discard any unfolding that mentions a variable
80 -- bound in this module (and hence not yet processed).
81 -- The discarding happens when forkM finds a type error.
83 %************************************************************************
85 %* tcImportDecl is the key function for "faulting in" *
88 %************************************************************************
90 The main idea is this. We are chugging along type-checking source code, and
91 find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find
92 it in the EPS type envt. So it
94 2 gets the decl for GHC.Base.map
95 3 typechecks it via tcIfaceDecl
96 4 and adds it to the type env in the EPS
98 Note that DURING STEP 4, we may find that map's type mentions a type
101 Notice that for imported things we read the current version from the EPS
102 mutable variable. This is important in situations like
104 where the code that e1 expands to might import some defns that
105 also turn out to be needed by the code that e2 expands to.
108 tcImportDecl :: Name -> IfG TyThing
109 -- Get the TyThing for this Name from an interface file
111 | Just thing <- wiredInNameTyThing_maybe name
112 -- This case only happens for tuples, because we pre-populate the eps_PTE
113 -- with other wired-in things. We can't do that for tuples because we
114 -- don't know how many of them we'll find
115 = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing })
119 = do { traceIf nd_doc
121 -- Load the interface, which should populate the PTE
122 ; loadHomeInterface nd_doc name
124 -- Now look it up again; this time we should find it
126 ; case lookupTypeEnv (eps_PTE eps) name of
127 Just thing -> return thing
128 Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM }
129 -- Declaration not found!
130 -- No errors-var to accumulate errors in, so just
131 -- print out the error right now
134 nd_doc = ptext SLIT("Need decl for") <+> ppr name
135 msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
136 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
137 ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
140 %************************************************************************
142 Type-checking a complete interface
144 %************************************************************************
146 Suppose we discover we don't need to recompile. Then we must type
147 check the old interface file. This is a bit different to the
148 incremental type checking we do as we suck in interface files. Instead
149 we do things similarly as when we are typechecking source decls: we
150 bring into scope the type envt for the interface all at once, using a
151 knot. Remember, the decls aren't necessarily in dependency order --
152 and even if they were, the type decls might be mutually recursive.
155 typecheckIface :: HscEnv
156 -> ModIface -- Get the decls from here
158 typecheckIface hsc_env iface
159 = initIfaceTc hsc_env iface $ \ tc_env_var -> do
160 { -- Get the right set of decls and rules. If we are compiling without -O
161 -- we discard pragmas before typechecking, so that we don't "see"
162 -- information that we shouldn't. From a versioning point of view
163 -- It's not actually *wrong* to do so, but in fact GHCi is unable
164 -- to handle unboxed tuples, so it must not see unfoldings.
165 ignore_prags <- doptM Opt_IgnoreInterfacePragmas
166 ; let { decls | ignore_prags = map (discardDeclPrags . snd) (mi_decls iface)
167 | otherwise = map snd (mi_decls iface)
168 ; rules | ignore_prags = []
169 | otherwise = mi_rules iface
170 ; dfuns = mi_insts iface
171 ; mod = mi_module iface
173 -- Typecheck the decls
174 ; names <- mappM (lookupOrig mod . ifName) decls
175 ; ty_things <- fixM (\ rec_ty_things -> do
176 { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things))
177 -- This only makes available the "main" things,
178 -- but that's enough for the strictly-checked part
179 ; mapM tcIfaceDecl decls })
181 -- Now augment the type envt with all the implicit things
182 -- These will be needed when type-checking the unfoldings for
183 -- the IfaceIds, but this is done lazily, so writing the thing
185 ; let { add_implicits main_thing = main_thing : implicitTyThings main_thing
186 ; type_env = mkTypeEnv (concatMap add_implicits ty_things) }
187 ; writeMutVar tc_env_var type_env
189 -- Now do those rules and instances
190 ; dfuns <- mapM tcIfaceInst dfuns
191 ; rules <- mapM tcIfaceRule rules
194 ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules })
199 %************************************************************************
201 Type and class declarations
203 %************************************************************************
205 When typechecking a data type decl, we *lazily* (via forkM) typecheck
206 the constructor argument types. This is in the hope that we may never
207 poke on those argument types, and hence may never need to load the
208 interface files for types mentioned in the arg types.
211 data Foo.S = MkS Baz.T
212 Mabye we can get away without even loading the interface for Baz!
214 This is not just a performance thing. Suppose we have
215 data Foo.S = MkS Baz.T
216 data Baz.T = MkT Foo.S
217 (in different interface files, of course).
218 Now, first we load and typecheck Foo.S, and add it to the type envt.
219 If we do explore MkS's argument, we'll load and typecheck Baz.T.
220 If we explore MkT's argument we'll find Foo.S already in the envt.
222 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
223 typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S...
224 which isn't done yet.
226 All very cunning. However, there is a rather subtle gotcha which bit
227 me when developing this stuff. When we typecheck the decl for S, we
228 extend the type envt with S, MkS, and all its implicit Ids. Suppose
229 (a bug, but it happened) that the list of implicit Ids depended in
230 turn on the constructor arg types. Then the following sequence of
232 * we build a thunk <t> for the constructor arg tys
233 * we build a thunk for the extended type environment (depends on <t>)
234 * we write the extended type envt into the global EPS mutvar
236 Now we look something up in the type envt
238 * which reads the global type envt out of the global EPS mutvar
239 * but that depends in turn on <t>
241 It's subtle, because, it'd work fine if we typechecked the constructor args
242 eagerly -- they don't need the extended type envt. They just get the extended
243 type envt by accident, because they look at it later.
245 What this means is that the implicitTyThings MUST NOT DEPEND on any of
250 tcIfaceDecl :: IfaceDecl -> IfL TyThing
252 tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
253 = do { name <- lookupIfaceTop occ_name
254 ; ty <- tcIfaceType iface_type
255 ; info <- tcIdInfo name ty info
256 ; return (AnId (mkVanillaGlobal name ty info)) }
258 tcIfaceDecl (IfaceData {ifName = occ_name,
261 ifVrcs = arg_vrcs, ifRec = is_rec,
262 ifGeneric = want_generic })
263 = do { tc_name <- lookupIfaceTop occ_name
264 ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
266 { tycon <- fixM ( \ tycon -> do
267 { cons <- tcIfaceDataCons tycon tyvars rdr_cons
268 ; tycon <- buildAlgTyCon tc_name tyvars cons
269 arg_vrcs is_rec want_generic
272 ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
273 ; return (ATyCon tycon)
276 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
277 ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
278 = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
279 { tc_name <- lookupIfaceTop occ_name
280 ; rhs_ty <- tcIfaceType rdr_rhs_ty
281 ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
284 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
285 ifFDs = rdr_fds, ifSigs = rdr_sigs,
286 ifVrcs = tc_vrcs, ifRec = tc_isrec })
287 = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
288 { cls_name <- lookupIfaceTop occ_name
289 ; ctxt <- tcIfaceCtxt rdr_ctxt
290 ; sigs <- mappM tc_sig rdr_sigs
291 ; fds <- mappM tc_fd rdr_fds
292 ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
293 ; return (AClass cls) }
295 tc_sig (IfaceClassOp occ dm rdr_ty)
296 = do { op_name <- lookupIfaceTop occ
297 ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
298 -- Must be done lazily for just the same reason as the
299 -- context of a data decl: the type sig might mention the
300 -- class being defined
301 ; return (op_name, dm, op_ty) }
303 mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]
305 tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
306 ; tvs2' <- mappM tcIfaceTyVar tvs2
307 ; return (tvs1', tvs2') }
309 tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
310 = do { name <- lookupIfaceTop rdr_name
311 ; return (ATyCon (mkForeignTyCon name ext_name
312 liftedTypeKind 0 [])) }
314 tcIfaceDataCons tycon tc_tyvars if_cons
316 IfAbstractTyCon -> return mkAbstractTyConRhs
317 IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt
318 ; data_cons <- mappM tc_con_decl cons
319 ; return (mkDataTyConRhs mb_theta data_cons) }
320 IfNewTyCon con -> do { data_con <- tc_con_decl con
321 ; return (mkNewTyConRhs tycon data_con) }
323 tc_ctxt Nothing = return Nothing
324 tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) }
326 tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args,
327 ifConStricts = stricts, ifConFields = field_lbls})
328 = do { name <- lookupIfaceTop occ
329 -- Read the argument types, but lazily to avoid faulting in
330 -- the component types unless they are really needed
331 ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
332 ; lbl_names <- mappM lookupIfaceTop field_lbls
333 ; buildDataCon name is_infix True {- Vanilla -}
335 tc_tyvars [] arg_tys tycon
336 (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys
339 tc_con_decl (IfGadtCon { ifConTyVars = con_tvs,
340 ifConOcc = occ, ifConCtxt = ctxt,
341 ifConArgTys = args, ifConResTys = ress,
342 ifConStricts = stricts})
343 = bindIfaceTyVars con_tvs $ \ con_tyvars -> do
344 { name <- lookupIfaceTop occ
345 ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
346 -- At one stage I thought that this context checking *had*
347 -- to be lazy, because of possible mutual recursion between the
348 -- type and the classe:
350 -- class Real a where { toRat :: a -> Ratio Integer }
351 -- data (Real a) => Ratio a = ...
352 -- But now I think that the laziness in checking class ops breaks
353 -- the loop, so no laziness needed
355 -- Read the argument types, but lazily to avoid faulting in
356 -- the component types unless they are really needed
357 ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
358 ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
360 ; buildDataCon name False {- Not infix -} False {- Not vanilla -}
361 stricts [{- No fields -}]
363 arg_tys tycon res_tys
365 mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
369 %************************************************************************
373 %************************************************************************
375 The gating story for instance declarations
376 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
377 When we are looking for a dict (C t1..tn), we slurp in instance decls for
379 mention at least one of the type constructors
380 at the roots of t1..tn
382 Why "at least one" rather than "all"? Because functional dependencies
383 complicate the picture. Consider
384 class C a b | a->b where ...
385 instance C Foo Baz where ...
386 Here, the gates are really only C and Foo, *not* Baz.
387 That is, if C and Foo are visible, even if Baz isn't, we must
388 slurp the decl, even if Baz is thus far completely unknown to the
391 Why "roots of the types"? Reason is overlap. For example, suppose there
392 are interfaces in the pool for
396 Then, if we are trying to resolve (C Int x), we need (a)
397 if we are trying to resolve (C x [y]), we need *both* (b) and (c),
398 even though T is not involved yet, so that we spot the overlap.
401 NOTE: if you use an instance decl with NO type constructors
402 instance C a where ...
403 and look up an Inst that only has type variables such as (C (n o))
404 then GHC won't necessarily suck in the instances that overlap with this.
408 loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv
409 loadImportedInsts cls tys
410 = do { -- Get interfaces for wired-in things, such as Integer
411 -- Any non-wired-in tycons will already be loaded, else
412 -- we couldn't have them in the Type
413 ; this_mod <- getModule
414 ; let { (cls_gate, tc_gates) = predInstGates cls tys
415 ; imp_wi n = isWiredInName n && this_mod /= nameModule n
416 ; wired_tcs = filter imp_wi tc_gates }
417 -- Wired-in tycons not from this module. The "this-module"
418 -- test bites only when compiling Base etc, because loadHomeInterface
419 -- barfs if it's asked to load a non-existent interface
420 ; if null wired_tcs then returnM ()
421 else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs)
423 -- Now suck in the relevant instances
424 ; iface_insts <- updateEps (selectInsts cls_gate tc_gates)
426 -- Empty => finish up rapidly, without writing to eps
427 ; if null iface_insts then
428 do { eps <- getEps; return (eps_inst_env eps) }
430 { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
431 nest 2 (vcat (map ppr iface_insts))])
433 -- Typecheck the new instances
434 ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
436 -- And put them in the package instance environment
437 ; updateEps ( \ eps ->
439 inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns
441 (eps { eps_inst_env = inst_env' }, inst_env')
444 wired_doc = ptext SLIT("Need home inteface for wired-in thing")
446 tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst)
448 tcIfaceInst :: IfaceInst -> IfL DFunId
449 tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
450 = tcIfaceExtId (LocalTop dfun_occ)
452 selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(Module, IfaceInst)])
453 selectInsts cls tycons eps
454 = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts)
456 insts = eps_insts eps
457 stats = eps_stats eps
458 stats' = stats { n_insts_out = n_insts_out stats + length iface_insts }
460 (insts', iface_insts)
461 = case lookupNameEnv insts cls of {
462 Nothing -> (insts, []) ;
465 case choose1 gated_insts of {
466 (_, []) -> (insts, []) ; -- None picked
467 (gated_insts', iface_insts') ->
469 (extendNameEnv insts cls gated_insts', iface_insts') }}
472 | null tycons -- Bizarre special case of C (a b); then there are no tycons
473 = ([], map snd gated_insts) -- Just grab all the instances, no real alternative
474 | otherwise -- Normal case
475 = foldl choose2 ([],[]) gated_insts
477 -- Reverses the gated decls, but that doesn't matter
478 choose2 (gis, decls) (gates, decl)
479 | null gates -- Happens when we have 'instance T a where ...'
480 || any (`elem` tycons) gates = (gis, decl:decls)
481 | otherwise = ((gates,decl) : gis, decls)
484 %************************************************************************
488 %************************************************************************
490 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
491 are in the type environment. However, remember that typechecking a Rule may
492 (as a side effect) augment the type envt, and so we may need to iterate the process.
495 loadImportedRules :: HscEnv -> ModGuts -> IO [IdCoreRule]
496 -- Returns just the new rules added
497 loadImportedRules hsc_env guts
498 = initIfaceRules hsc_env guts $ do
500 if_rules <- updateEps selectRules
502 ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules))
504 ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
505 ; core_rules <- mapM tc_rule if_rules
508 ; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules)
510 -- Update the rule base and return it
511 ; updateEps (\ eps ->
512 let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
513 in (eps { eps_rule_base = new_rule_base }, new_rule_base)
516 -- Strictly speaking, at this point we should go round again, since
517 -- typechecking one set of rules may bring in new things which enable
518 -- some more rules to come in. But we call loadImportedRules several
519 -- times anyway, so I'm going to be lazy and ignore this.
524 selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, IfaceRule)])
525 -- Not terribly efficient. Look at each rule in the pool to see if
526 -- all its gates are in the type env. If so, take it out of the pool.
527 -- If not, trim its gates for next time.
529 = (eps { eps_rules = rules', eps_stats = stats' }, if_rules)
531 stats = eps_stats eps
532 rules = eps_rules eps
533 type_env = eps_PTE eps
534 stats' = stats { n_rules_out = n_rules_out stats + length if_rules }
536 (rules', if_rules) = foldl do_one ([], []) rules
538 do_one (pool, if_rules) (gates, rule)
539 | null gates' = (pool, rule:if_rules)
540 | otherwise = ((gates',rule) : pool, if_rules)
542 gates' = filter (not . (`elemNameEnv` type_env)) gates
545 tcIfaceRule :: IfaceRule -> IfL IdCoreRule
546 tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,
547 ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs })
548 = bindIfaceBndrs bndrs $ \ bndrs' ->
549 do { fn <- tcIfaceExtId fn_rdr
550 ; args' <- mappM tcIfaceExpr args
551 ; rhs' <- tcIfaceExpr rhs
552 ; let rule = Rule rule_name act bndrs' args' rhs'
553 ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) }
556 tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
557 = do { fn <- tcIfaceExtId fn_rdr
558 ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }
560 isOrphNm :: IfaceExtName -> Bool
561 isOrphNm (LocalTop _) = False
562 isOrphNm (LocalTopSub _ _) = False
563 isOrphNm other = True
567 %************************************************************************
571 %************************************************************************
574 tcIfaceType :: IfaceType -> IfL Type
575 tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
576 tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
577 tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
578 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkGenTyConApp tc' ts') }
579 tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
580 tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
582 tcIfaceTypes tys = mapM tcIfaceType tys
584 -----------------------------------------
585 tcIfacePredType :: IfacePredType -> IfL PredType
586 tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
587 tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
589 -----------------------------------------
590 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
591 tcIfaceCtxt sts = mappM tcIfacePredType sts
595 %************************************************************************
599 %************************************************************************
602 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
603 tcIfaceExpr (IfaceType ty)
604 = tcIfaceType ty `thenM` \ ty' ->
607 tcIfaceExpr (IfaceLcl name)
608 = tcIfaceLclId name `thenM` \ id ->
611 tcIfaceExpr (IfaceExt gbl)
612 = tcIfaceExtId gbl `thenM` \ id ->
615 tcIfaceExpr (IfaceLit lit)
618 tcIfaceExpr (IfaceFCall cc ty)
619 = tcIfaceType ty `thenM` \ ty' ->
620 newUnique `thenM` \ u ->
621 returnM (Var (mkFCallId u cc ty'))
623 tcIfaceExpr (IfaceTuple boxity args)
624 = mappM tcIfaceExpr args `thenM` \ args' ->
626 -- Put the missing type arguments back in
627 con_args = map (Type . exprType) args' ++ args'
629 returnM (mkApps (Var con_id) con_args)
632 con_id = dataConWorkId (tupleCon boxity arity)
635 tcIfaceExpr (IfaceLam bndr body)
636 = bindIfaceBndr bndr $ \ bndr' ->
637 tcIfaceExpr body `thenM` \ body' ->
638 returnM (Lam bndr' body')
640 tcIfaceExpr (IfaceApp fun arg)
641 = tcIfaceExpr fun `thenM` \ fun' ->
642 tcIfaceExpr arg `thenM` \ arg' ->
643 returnM (App fun' arg')
646 tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
647 = tcIfaceExpr scrut `thenM` \ scrut' ->
648 newIfaceName case_bndr `thenM` \ case_bndr_name ->
650 scrut_ty = exprType scrut'
651 case_bndr' = mkLocalId case_bndr_name scrut_ty
652 tc_app = splitTyConApp scrut_ty
653 -- NB: Won't always succeed (polymoprhic case)
654 -- but won't be demanded in those cases
655 -- NB: not tcSplitTyConApp; we are looking at Core here
656 -- look through non-rec newtypes to find the tycon that
657 -- corresponds to the datacon in this case alternative
659 extendIfaceIdEnv [case_bndr'] $
660 mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' ->
661 tcIfaceType ty `thenM` \ ty' ->
662 returnM (Case scrut' case_bndr' ty' alts')
664 tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
665 = tcIfaceExpr rhs `thenM` \ rhs' ->
666 bindIfaceId bndr $ \ bndr' ->
667 tcIfaceExpr body `thenM` \ body' ->
668 returnM (Let (NonRec bndr' rhs') body')
670 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
671 = bindIfaceIds bndrs $ \ bndrs' ->
672 mappM tcIfaceExpr rhss `thenM` \ rhss' ->
673 tcIfaceExpr body `thenM` \ body' ->
674 returnM (Let (Rec (bndrs' `zip` rhss')) body')
676 (bndrs, rhss) = unzip pairs
678 tcIfaceExpr (IfaceNote note expr)
679 = tcIfaceExpr expr `thenM` \ expr' ->
681 IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' ->
682 returnM (Note (Coerce to_ty'
683 (exprType expr')) expr')
684 IfaceInlineCall -> returnM (Note InlineCall expr')
685 IfaceInlineMe -> returnM (Note InlineMe expr')
686 IfaceSCC cc -> returnM (Note (SCC cc) expr')
687 IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
689 -------------------------
690 tcIfaceAlt _ (IfaceDefault, names, rhs)
691 = ASSERT( null names )
692 tcIfaceExpr rhs `thenM` \ rhs' ->
693 returnM (DEFAULT, [], rhs')
695 tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
696 = ASSERT( null names )
697 tcIfaceExpr rhs `thenM` \ rhs' ->
698 returnM (LitAlt lit, [], rhs')
700 -- A case alternative is made quite a bit more complicated
701 -- by the fact that we omit type annotations because we can
702 -- work them out. True enough, but its not that easy!
703 tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
704 = do { let tycon_mod = nameModule (tyConName tycon)
705 ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
706 ; ASSERT2( con `elem` tyConDataCons tycon,
707 ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
709 if isVanillaDataCon con then
710 tcVanillaAlt con inst_tys arg_occs rhs
713 arg_names <- newIfaceNames arg_occs
714 ; let tyvars = [ mkTyVar name (tyVarKind tv)
715 | (name,tv) <- arg_names `zip` dataConTyVars con]
716 arg_tys = dataConArgTys con (mkTyVarTys tyvars)
717 id_names = dropList tyvars arg_names
718 arg_ids = ASSERT2( equalLength id_names arg_tys,
719 ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
720 zipWith mkLocalId id_names arg_tys
722 ; rhs' <- extendIfaceTyVarEnv tyvars $
723 extendIfaceIdEnv arg_ids $
725 ; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
727 tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
728 = ASSERT( isTupleTyCon tycon )
729 do { let [data_con] = tyConDataCons tycon
730 ; tcVanillaAlt data_con inst_tys arg_occs rhs }
732 tcVanillaAlt data_con inst_tys arg_occs rhs
733 = do { arg_names <- newIfaceNames arg_occs
734 ; let arg_tys = dataConArgTys data_con inst_tys
735 ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
736 ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
737 zipWith mkLocalId arg_names arg_tys
738 ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
739 ; returnM (DataAlt data_con, arg_ids, rhs') }
744 tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core
745 tcExtCoreBindings mod [] = return []
746 tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs)
748 do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
749 do_one mod (IfaceNonRec bndr rhs) thing_inside
750 = do { rhs' <- tcIfaceExpr rhs
751 ; bndr' <- newExtCoreBndr mod bndr
752 ; extendIfaceIdEnv [bndr'] $ do
753 { core_binds <- thing_inside
754 ; return (NonRec bndr' rhs' : core_binds) }}
756 do_one mod (IfaceRec pairs) thing_inside
757 = do { bndrs' <- mappM (newExtCoreBndr mod) bndrs
758 ; extendIfaceIdEnv bndrs' $ do
759 { rhss' <- mappM tcIfaceExpr rhss
760 ; core_binds <- thing_inside
761 ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
763 (bndrs,rhss) = unzip pairs
767 %************************************************************************
771 %************************************************************************
774 tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo
775 tcIdInfo name ty NoInfo = return vanillaIdInfo
776 tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info
778 -- Set the CgInfo to something sensible but uninformative before
779 -- we start; default assumption is that it has CAFs
780 init_info = vanillaIdInfo
782 tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs)
783 tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity)
784 tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str)
786 -- The next two are lazy, so they don't transitively suck stuff in
787 tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
788 tcPrag info (HsUnfold inline_prag expr)
789 = tcPragExpr name expr `thenM` \ maybe_expr' ->
791 -- maybe_expr' doesn't get looked at if the unfolding
792 -- is never inspected; so the typecheck doesn't even happen
793 unfold_info = case maybe_expr' of
794 Nothing -> noUnfolding
795 Just expr' -> mkTopUnfolding expr'
797 returnM (info `setUnfoldingInfoLazily` unfold_info
798 `setInlinePragInfo` inline_prag)
802 tcWorkerInfo ty info wkr arity
803 = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
805 -- We return without testing maybe_wkr_id, but as soon as info is
806 -- looked at we will test it. That's ok, because its outside the
807 -- knot; and there seems no big reason to further defer the
808 -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking
809 -- over the unfolding until it's actually used does seem worth while.)
810 ; us <- newUniqueSupply
812 ; returnM (case mb_wkr_id of
814 Just wkr_id -> add_wkr_info us wkr_id info) }
816 doc = text "Worker for" <+> ppr wkr
817 add_wkr_info us wkr_id info
818 = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
819 `setWorkerInfo` HasWorker wkr_id arity
821 mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
823 -- We are relying here on strictness info always appearing
824 -- before worker info, fingers crossed ....
825 strict_sig = case newStrictnessInfo info of
827 Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr)
830 For unfoldings we try to do the job lazily, so that we never type check
831 an unfolding that isn't going to be looked at.
834 tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
837 tcIfaceExpr expr `thenM` \ core_expr' ->
839 -- Check for type consistency in the unfolding
840 ifOptM Opt_DoCoreLinting (
841 get_in_scope_ids `thenM` \ in_scope ->
842 case lintUnfolding noSrcLoc in_scope core_expr' of
843 Nothing -> returnM ()
844 Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
849 doc = text "Unfolding of" <+> ppr name
850 get_in_scope_ids -- Urgh; but just for linting
852 do { env <- getGblEnv
853 ; case if_rec_types env of {
854 Nothing -> return [] ;
855 Just (_, get_env) -> do
856 { type_env <- get_env
857 ; return (typeEnvIds type_env) }}}
862 %************************************************************************
864 Getting from Names to TyThings
866 %************************************************************************
869 tcIfaceGlobal :: Name -> IfM a TyThing
871 = do { (eps,hpt) <- getEpsAndHpt
872 ; case lookupType hpt (eps_PTE eps) name of {
873 Just thing -> return thing ;
876 setLclEnv () $ do -- This gets us back to IfG, mainly to
877 -- pacify get_type_env; rather untidy
879 ; case if_rec_types env of
880 Just (mod, get_type_env)
881 | nameIsLocalOrFrom mod name
882 -> do -- It's defined in the module being compiled
883 { type_env <- get_type_env
884 ; case lookupNameEnv type_env name of
885 Just thing -> return thing
886 Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
887 (ppr name $$ ppr type_env) }
889 other -> tcImportDecl name -- It's imported; go get it
892 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
893 tcIfaceTyCon IfaceIntTc = return intTyCon
894 tcIfaceTyCon IfaceBoolTc = return boolTyCon
895 tcIfaceTyCon IfaceCharTc = return charTyCon
896 tcIfaceTyCon IfaceListTc = return listTyCon
897 tcIfaceTyCon IfacePArrTc = return parrTyCon
898 tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
899 tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
900 ; thing <- tcIfaceGlobal name
901 ; return (tyThingTyCon thing) }
903 tcIfaceClass :: IfaceExtName -> IfL Class
904 tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
905 ; thing <- tcIfaceGlobal name
906 ; return (tyThingClass thing) }
908 tcIfaceDataCon :: IfaceExtName -> IfL DataCon
909 tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
910 ; thing <- tcIfaceGlobal name
912 ADataCon dc -> return dc
913 other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
915 tcIfaceExtId :: IfaceExtName -> IfL Id
916 tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
917 ; thing <- tcIfaceGlobal name
920 other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
923 %************************************************************************
927 %************************************************************************
930 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
931 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
932 = bindIfaceId bndr thing_inside
933 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
934 = bindIfaceTyVar bndr thing_inside
936 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
937 bindIfaceBndrs [] thing_inside = thing_inside []
938 bindIfaceBndrs (b:bs) thing_inside
939 = bindIfaceBndr b $ \ b' ->
940 bindIfaceBndrs bs $ \ bs' ->
941 thing_inside (b':bs')
943 -----------------------
944 bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a
945 bindIfaceId (occ, ty) thing_inside
946 = do { name <- newIfaceName occ
947 ; ty' <- tcIfaceType ty
948 ; let { id = mkLocalId name ty' }
949 ; extendIfaceIdEnv [id] (thing_inside id) }
951 bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a
952 bindIfaceIds bndrs thing_inside
953 = do { names <- newIfaceNames occs
954 ; tys' <- mappM tcIfaceType tys
955 ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
956 ; extendIfaceIdEnv ids (thing_inside ids) }
958 (occs,tys) = unzip bndrs
961 -----------------------
962 newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id
963 newExtCoreBndr mod (occ, ty)
964 = do { name <- newGlobalBinder mod occ Nothing noSrcLoc
965 ; ty' <- tcIfaceType ty
966 ; return (mkLocalId name ty') }
968 -----------------------
969 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
970 bindIfaceTyVar (occ,kind) thing_inside
971 = do { name <- newIfaceName occ
972 ; let tyvar = mk_iface_tyvar name kind
973 ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
975 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
976 bindIfaceTyVars bndrs thing_inside
977 = do { names <- newIfaceNames occs
978 ; let tyvars = zipWith mk_iface_tyvar names kinds
979 ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
981 (occs,kinds) = unzip bndrs
983 mk_iface_tyvar name kind = mkTyVar name kind