Update levity polymorphism
[ghc.git] / compiler / iface / TcIface.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Type checking of type signatures in interface files
7 -}
8
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE NondecreasingIndentation #-}
11
12 module TcIface (
13 tcLookupImported_maybe,
14 importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
15 typecheckIfacesForMerging,
16 typecheckIfaceForInstantiate,
17 tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
18 tcIfaceVectInfo, tcIfaceAnnotations,
19 tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
20 tcIfaceGlobal
21 ) where
22
23 #include "HsVersions.h"
24
25 import TcTypeNats(typeNatCoAxiomRules)
26 import IfaceSyn
27 import LoadIface
28 import IfaceEnv
29 import BuildTyCl
30 import TcRnMonad
31 import TcType
32 import Type
33 import Coercion
34 import CoAxiom
35 import TyCoRep -- needs to build types & coercions in a knot
36 import HscTypes
37 import Annotations
38 import InstEnv
39 import FamInstEnv
40 import CoreSyn
41 import CoreUtils
42 import CoreUnfold
43 import CoreLint
44 import MkCore
45 import Id
46 import MkId
47 import IdInfo
48 import Class
49 import TyCon
50 import ConLike
51 import DataCon
52 import PrelNames
53 import TysWiredIn
54 import Literal
55 import Var
56 import VarEnv
57 import VarSet
58 import Name
59 import NameEnv
60 import NameSet
61 import OccurAnal ( occurAnalyseExpr )
62 import Demand
63 import Module
64 import UniqFM
65 import UniqSupply
66 import Outputable
67 import Maybes
68 import SrcLoc
69 import DynFlags
70 import Util
71 import FastString
72 import BasicTypes hiding ( SuccessFlag(..) )
73 import ListSetOps
74 import GHC.Fingerprint
75 import qualified BooleanFormula as BF
76
77 import Data.List
78 import Control.Monad
79 import qualified Data.Map as Map
80
81 {-
82 This module takes
83
84 IfaceDecl -> TyThing
85 IfaceType -> Type
86 etc
87
88 An IfaceDecl is populated with RdrNames, and these are not renamed to
89 Names before typechecking, because there should be no scope errors etc.
90
91 -- For (b) consider: f = \$(...h....)
92 -- where h is imported, and calls f via an hi-boot file.
93 -- This is bad! But it is not seen as a staging error, because h
94 -- is indeed imported. We don't want the type-checker to black-hole
95 -- when simplifying and compiling the splice!
96 --
97 -- Simple solution: discard any unfolding that mentions a variable
98 -- bound in this module (and hence not yet processed).
99 -- The discarding happens when forkM finds a type error.
100
101
102 ************************************************************************
103 * *
104 Type-checking a complete interface
105 * *
106 ************************************************************************
107
108 Suppose we discover we don't need to recompile. Then we must type
109 check the old interface file. This is a bit different to the
110 incremental type checking we do as we suck in interface files. Instead
111 we do things similarly as when we are typechecking source decls: we
112 bring into scope the type envt for the interface all at once, using a
113 knot. Remember, the decls aren't necessarily in dependency order --
114 and even if they were, the type decls might be mutually recursive.
115
116 Note [Knot-tying typecheckIface]
117 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
118 Suppose we are typechecking an interface A.hi, and we come across
119 a Name for another entity defined in A.hi. How do we get the
120 'TyCon', in this case? There are three cases:
121
122 1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in
123 preparation of checking if the hs file we're building
124 is compatible. In this case, we want all of the internal
125 TyCons to MATCH the ones that we just constructed during
126 typechecking: the knot is thus tied through if_rec_types.
127
128 2) retypecheckLoop in GhcMake: We are retypechecking a
129 mutually recursive cluster of hi files, in order to ensure
130 that all of the references refer to each other correctly.
131 In this case, the knot is tied through the HPT passed in,
132 which contains all of the interfaces we are in the process
133 of typechecking.
134
135 3) genModDetails in HscMain: We are typechecking an
136 old interface to generate the ModDetails. In this case,
137 we do the same thing as (2) and pass in an HPT with
138 the HomeModInfo being generated to tie knots.
139
140 The upshot is that the CLIENT of this function is responsible
141 for making sure that the knot is tied correctly. If you don't,
142 then you'll get a message saying that we couldn't load the
143 declaration you wanted.
144
145 BTW, in one-shot mode we never call typecheckIface; instead,
146 loadInterface handles type-checking interface. In that case,
147 knots are tied through the EPS. No problem!
148 -}
149
150 -- Clients of this function be careful, see Note [Knot-tying typecheckIface]
151 typecheckIface :: ModIface -- Get the decls from here
152 -> IfG ModDetails
153 typecheckIface iface
154 = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do
155 { -- Get the right set of decls and rules. If we are compiling without -O
156 -- we discard pragmas before typechecking, so that we don't "see"
157 -- information that we shouldn't. From a versioning point of view
158 -- It's not actually *wrong* to do so, but in fact GHCi is unable
159 -- to handle unboxed tuples, so it must not see unfoldings.
160 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
161
162 -- Typecheck the decls. This is done lazily, so that the knot-tying
163 -- within this single module works out right. It's the callers
164 -- job to make sure the knot is tied.
165 ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
166 ; let type_env = mkNameEnv names_w_things
167
168 -- Now do those rules, instances and annotations
169 ; insts <- mapM tcIfaceInst (mi_insts iface)
170 ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
171 ; rules <- tcIfaceRules ignore_prags (mi_rules iface)
172 ; anns <- tcIfaceAnnotations (mi_anns iface)
173
174 -- Vectorisation information
175 ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
176
177 -- Exports
178 ; exports <- ifaceExportNames (mi_exports iface)
179
180 -- Finished
181 ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
182 -- Careful! If we tug on the TyThing thunks too early
183 -- we'll infinite loop with hs-boot. See #10083 for
184 -- an example where this would cause non-termination.
185 text "Type envt:" <+> ppr (map fst names_w_things)])
186 ; return $ ModDetails { md_types = type_env
187 , md_insts = insts
188 , md_fam_insts = fam_insts
189 , md_rules = rules
190 , md_anns = anns
191 , md_vect_info = vect_info
192 , md_exports = exports
193 }
194 }
195
196 {-
197 ************************************************************************
198 * *
199 Typechecking for merging
200 * *
201 ************************************************************************
202 -}
203
204 -- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
205 isAbstractIfaceDecl :: IfaceDecl -> Bool
206 isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon _ } = True
207 isAbstractIfaceDecl IfaceClass{ ifCtxt = [], ifSigs = [], ifATs = [] } = True
208 isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
209 isAbstractIfaceDecl _ = False
210
211 -- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If
212 -- both are non-abstract we pick one arbitrarily (and check for consistency
213 -- later.)
214 mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
215 mergeIfaceDecl d1 d2
216 | isAbstractIfaceDecl d1 = d2
217 | isAbstractIfaceDecl d2 = d1
218 | IfaceClass{ ifSigs = ops1, ifMinDef = bf1 } <- d1
219 , IfaceClass{ ifSigs = ops2, ifMinDef = bf2 } <- d2
220 = let ops = nameEnvElts $
221 plusNameEnv_C mergeIfaceClassOp
222 (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
223 (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
224 in d1 { ifSigs = ops
225 , ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
226 }
227 -- It doesn't matter; we'll check for consistency later when
228 -- we merge, see 'mergeSignatures'
229 | otherwise = d1
230
231 mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
232 mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1
233 mergeIfaceClassOp _ op2 = op2
234
235 -- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
236 mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
237 mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
238
239 -- | This is a very interesting function. Like typecheckIface, we want
240 -- to type check an interface file into a ModDetails. However, the use-case
241 -- for these ModDetails is different: we want to compare all of the
242 -- ModDetails to ensure they define compatible declarations, and then
243 -- merge them together. So in particular, we have to take a different
244 -- strategy for knot-tying: we first speculatively merge the declarations
245 -- to get the "base" truth for what we believe the types will be
246 -- (this is "type computation.") Then we read everything in relative
247 -- to this truth and check for compatibility.
248 --
249 -- During the merge process, we may need to nondeterministically
250 -- pick a particular declaration to use, if multiple signatures define
251 -- the declaration ('mergeIfaceDecl'). If, for all choices, there
252 -- are no type synonym cycles in the resulting merged graph, then
253 -- we can show that our choice cannot matter. Consider the
254 -- set of entities which the declarations depend on: by assumption
255 -- of acyclicity, we can assume that these have already been shown to be equal
256 -- to each other (otherwise merging will fail). Then it must
257 -- be the case that all candidate declarations here are type-equal
258 -- (the choice doesn't matter) or there is an inequality (in which
259 -- case merging will fail.)
260 --
261 -- Unfortunately, the choice can matter if there is a cycle. Consider the
262 -- following merge:
263 --
264 -- signature H where { type A = C; type B = A; data C }
265 -- signature H where { type A = (); data B; type C = B }
266 --
267 -- If we pick @type A = C@ as our representative, there will be
268 -- a cycle and merging will fail. But if we pick @type A = ()@ as
269 -- our representative, no cycle occurs, and we instead conclude
270 -- that all of the types are unit. So it seems that we either
271 -- (a) need a stronger acyclicity check which considers *all*
272 -- possible choices from a merge, or (b) we must find a selection
273 -- of declarations which is acyclic, and show that this is always
274 -- the "best" choice we could have made (ezyang conjectures this
275 -- is the case but does not have a proof). For now this is
276 -- not implemented.
277 --
278 -- It's worth noting that at the moment, a data constructor and a
279 -- type synonym are never compatible. Consider:
280 --
281 -- signature H where { type Int=C; type B = Int; data C = Int}
282 -- signature H where { export Prelude.Int; data B; type C = B; }
283 --
284 -- This will be rejected, because the reexported Int in the second
285 -- signature (a proper data type) is never considered equal to a
286 -- type synonym. Perhaps this should be relaxed, where a type synonym
287 -- in a signature is considered implemented by a data type declaration
288 -- which matches the reference of the type synonym.
289 typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
290 typecheckIfacesForMerging mod ifaces tc_env_var =
291 -- cannot be boot (False)
292 initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do
293 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
294 -- Build the initial environment
295 -- NB: Don't include dfuns here, because we don't want to
296 -- serialize them out. See Note [Bogus DFun renamings] in RnModIface
297 let mk_decl_env decls
298 = mkOccEnv [ (getOccName decl, decl)
299 | decl <- decls
300 , case decl of
301 IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns
302 _ -> True ]
303 decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces
304 :: [OccEnv IfaceDecl]
305 decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs
306 :: OccEnv IfaceDecl
307 -- TODO: change loadDecls to accept w/o Fingerprint
308 names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))
309 (occEnvElts decl_env))
310 let global_type_env = mkNameEnv names_w_things
311 writeMutVar tc_env_var global_type_env
312
313 -- OK, now typecheck each ModIface using this environment
314 details <- forM ifaces $ \iface -> do
315 -- See Note [The implicit TypeEnv]
316 type_env <- fixM $ \type_env -> do
317 setImplicitEnvM type_env $ do
318 decls <- loadDecls ignore_prags (mi_decls iface)
319 return (mkNameEnv decls)
320 -- But note that we use this type_env to typecheck references to DFun
321 -- in 'IfaceInst'
322 setImplicitEnvM type_env $ do
323 insts <- mapM tcIfaceInst (mi_insts iface)
324 fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
325 rules <- tcIfaceRules ignore_prags (mi_rules iface)
326 anns <- tcIfaceAnnotations (mi_anns iface)
327 vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
328 exports <- ifaceExportNames (mi_exports iface)
329 return $ ModDetails { md_types = type_env
330 , md_insts = insts
331 , md_fam_insts = fam_insts
332 , md_rules = rules
333 , md_anns = anns
334 , md_vect_info = vect_info
335 , md_exports = exports
336 }
337 return (global_type_env, details)
338
339 -- | Typecheck a signature 'ModIface' under the assumption that we have
340 -- instantiated it under some implementation (recorded in 'mi_semantic_module')
341 -- and want to check if the implementation fills the signature.
342 --
343 -- This needs to operate slightly differently than 'typecheckIface'
344 -- because (1) we have a 'NameShape', from the exports of the
345 -- implementing module, which we will use to give our top-level
346 -- declarations the correct 'Name's even when the implementor
347 -- provided them with a reexport, and (2) we have to deal with
348 -- DFun silliness (see Note [Bogus DFun renamings])
349 typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
350 typecheckIfaceForInstantiate nsubst iface =
351 initIfaceLclWithSubst (mi_semantic_module iface)
352 (text "typecheckIfaceForInstantiate")
353 (mi_boot iface) nsubst $ do
354 ignore_prags <- goptM Opt_IgnoreInterfacePragmas
355 -- See Note [The implicit TypeEnv]
356 type_env <- fixM $ \type_env -> do
357 setImplicitEnvM type_env $ do
358 decls <- loadDecls ignore_prags (mi_decls iface)
359 return (mkNameEnv decls)
360 -- See Note [Bogus DFun renamings]
361 setImplicitEnvM type_env $ do
362 insts <- mapM tcIfaceInst (mi_insts iface)
363 fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
364 rules <- tcIfaceRules ignore_prags (mi_rules iface)
365 anns <- tcIfaceAnnotations (mi_anns iface)
366 vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
367 exports <- ifaceExportNames (mi_exports iface)
368 return $ ModDetails { md_types = type_env
369 , md_insts = insts
370 , md_fam_insts = fam_insts
371 , md_rules = rules
372 , md_anns = anns
373 , md_vect_info = vect_info
374 , md_exports = exports
375 }
376
377 -- Note [The implicit TypeEnv]
378 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
379 -- As described in 'typecheckIfacesForMerging', the splendid innovation
380 -- of signature merging is to rewrite all Names in each of the signatures
381 -- we are merging together to a pre-merged structure; this is the key
382 -- ingredient that lets us solve some problems when merging type
383 -- synonyms.
384 --
385 -- However in the case of DFuns and CoAxioms, this strategy goes
386 -- *too far*. In particular, the reference to a DFun or CoAxiom in
387 -- an instance declaration or closed type family (respectively) will
388 -- refer to the merged declaration. However, checkBootDeclM only
389 -- ever looks at the embedded structure when performing its comparison;
390 -- by virtue of the fact that everything's been pointed to the merged
391 -- declaration, you'll never notice there's a difference even if there
392 -- is one.
393 --
394 -- The solution is, for reference to implicit entities, we go straight
395 -- for the local TypeEnv corresponding to the entities from this particular
396 -- signature; this logic is in 'tcIfaceImplicit'.
397 --
398 -- There is also some fixM business because families need to refer to
399 -- coercion axioms, which are all in the big pile of decls. I didn't
400 -- feel like untangling first so the fixM is a convenient way to get things
401 -- where they need to be.
402 --
403
404 {-
405 ************************************************************************
406 * *
407 Type and class declarations
408 * *
409 ************************************************************************
410 -}
411
412 tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
413 -- Load the hi-boot iface for the module being compiled,
414 -- if it indeed exists in the transitive closure of imports
415 -- Return the ModDetails; Nothing if no hi-boot iface
416 tcHiBootIface hsc_src mod
417 | HsBootFile <- hsc_src -- Already compiling a hs-boot file
418 = return NoSelfBoot
419 | otherwise
420 = do { traceIf (text "loadHiBootInterface" <+> ppr mod)
421
422 ; mode <- getGhcMode
423 ; if not (isOneShot mode)
424 -- In --make and interactive mode, if this module has an hs-boot file
425 -- we'll have compiled it already, and it'll be in the HPT
426 --
427 -- We check wheher the interface is a *boot* interface.
428 -- It can happen (when using GHC from Visual Studio) that we
429 -- compile a module in TypecheckOnly mode, with a stable,
430 -- fully-populated HPT. In that case the boot interface isn't there
431 -- (it's been replaced by the mother module) so we can't check it.
432 -- And that's fine, because if M's ModInfo is in the HPT, then
433 -- it's been compiled once, and we don't need to check the boot iface
434 then do { hpt <- getHpt
435 ; case lookupHpt hpt (moduleName mod) of
436 Just info | mi_boot (hm_iface info)
437 -> mkSelfBootInfo (hm_iface info) (hm_details info)
438 _ -> return NoSelfBoot }
439 else do
440
441 -- OK, so we're in one-shot mode.
442 -- Re #9245, we always check if there is an hi-boot interface
443 -- to check consistency against, rather than just when we notice
444 -- that an hi-boot is necessary due to a circular import.
445 { read_result <- findAndReadIface
446 need (fst (splitModuleInsts mod))
447 True -- Hi-boot file
448
449 ; case read_result of {
450 Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface
451 ; mkSelfBootInfo iface tc_iface } ;
452 Failed err ->
453
454 -- There was no hi-boot file. But if there is circularity in
455 -- the module graph, there really should have been one.
456 -- Since we've read all the direct imports by now,
457 -- eps_is_boot will record if any of our imports mention the
458 -- current module, which either means a module loop (not
459 -- a SOURCE import) or that our hi-boot file has mysteriously
460 -- disappeared.
461 do { eps <- getEps
462 ; case lookupUFM (eps_is_boot eps) (moduleName mod) of
463 Nothing -> return NoSelfBoot -- The typical case
464
465 Just (_, False) -> failWithTc moduleLoop
466 -- Someone below us imported us!
467 -- This is a loop with no hi-boot in the way
468
469 Just (_mod, True) -> failWithTc (elaborate err)
470 -- The hi-boot file has mysteriously disappeared.
471 }}}}
472 where
473 need = text "Need the hi-boot interface for" <+> ppr mod
474 <+> text "to compare against the Real Thing"
475
476 moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)
477 <+> text "depends on itself"
478
479 elaborate err = hang (text "Could not find hi-boot interface for" <+>
480 quotes (ppr mod) <> colon) 4 err
481
482
483 mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo
484 mkSelfBootInfo iface mds
485 = do -- NB: This is computed DIRECTLY from the ModIface rather
486 -- than from the ModDetails, so that we can query 'sb_tcs'
487 -- WITHOUT forcing the contents of the interface.
488 let tcs = map ifName
489 . filter isIfaceTyCon
490 . map snd
491 $ mi_decls iface
492 return $ SelfBoot { sb_mds = mds
493 , sb_tcs = mkNameSet tcs }
494 where
495 -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on
496 -- this 'IfaceDecl', an ATyCon would be returned.
497 -- NB: This code assumes that a TyCon cannot be implicit.
498 isIfaceTyCon IfaceId{} = False
499 isIfaceTyCon IfaceData{} = True
500 isIfaceTyCon IfaceSynonym{} = True
501 isIfaceTyCon IfaceFamily{} = True
502 isIfaceTyCon IfaceClass{} = True
503 isIfaceTyCon IfaceAxiom{} = False
504 isIfaceTyCon IfacePatSyn{} = False
505
506 {-
507 ************************************************************************
508 * *
509 Type and class declarations
510 * *
511 ************************************************************************
512
513 When typechecking a data type decl, we *lazily* (via forkM) typecheck
514 the constructor argument types. This is in the hope that we may never
515 poke on those argument types, and hence may never need to load the
516 interface files for types mentioned in the arg types.
517
518 E.g.
519 data Foo.S = MkS Baz.T
520 Maybe we can get away without even loading the interface for Baz!
521
522 This is not just a performance thing. Suppose we have
523 data Foo.S = MkS Baz.T
524 data Baz.T = MkT Foo.S
525 (in different interface files, of course).
526 Now, first we load and typecheck Foo.S, and add it to the type envt.
527 If we do explore MkS's argument, we'll load and typecheck Baz.T.
528 If we explore MkT's argument we'll find Foo.S already in the envt.
529
530 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
531 typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S...
532 which isn't done yet.
533
534 All very cunning. However, there is a rather subtle gotcha which bit
535 me when developing this stuff. When we typecheck the decl for S, we
536 extend the type envt with S, MkS, and all its implicit Ids. Suppose
537 (a bug, but it happened) that the list of implicit Ids depended in
538 turn on the constructor arg types. Then the following sequence of
539 events takes place:
540 * we build a thunk <t> for the constructor arg tys
541 * we build a thunk for the extended type environment (depends on <t>)
542 * we write the extended type envt into the global EPS mutvar
543
544 Now we look something up in the type envt
545 * that pulls on <t>
546 * which reads the global type envt out of the global EPS mutvar
547 * but that depends in turn on <t>
548
549 It's subtle, because, it'd work fine if we typechecked the constructor args
550 eagerly -- they don't need the extended type envt. They just get the extended
551 type envt by accident, because they look at it later.
552
553 What this means is that the implicitTyThings MUST NOT DEPEND on any of
554 the forkM stuff.
555 -}
556
557 tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings
558 -> IfaceDecl
559 -> IfL TyThing
560 tcIfaceDecl = tc_iface_decl Nothing
561
562 tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations
563 -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings
564 -> IfaceDecl
565 -> IfL TyThing
566 tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
567 ifIdDetails = details, ifIdInfo = info})
568 = do { ty <- tcIfaceType iface_type
569 ; details <- tcIdDetails ty details
570 ; info <- tcIdInfo ignore_prags name ty info
571 ; return (AnId (mkGlobalId details name ty info)) }
572
573 tc_iface_decl _ _ (IfaceData {ifName = tc_name,
574 ifCType = cType,
575 ifBinders = binders,
576 ifResKind = res_kind,
577 ifRoles = roles,
578 ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
579 ifCons = rdr_cons,
580 ifParent = mb_parent })
581 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
582 { res_kind' <- tcIfaceType res_kind
583
584 ; tycon <- fixM $ \ tycon -> do
585 { stupid_theta <- tcIfaceCtxt ctxt
586 ; parent' <- tc_parent tc_name mb_parent
587 ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
588 ; return (mkAlgTyCon tc_name binders' res_kind'
589 roles cType stupid_theta
590 cons parent' gadt_syn) }
591 ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
592 ; return (ATyCon tycon) }
593 where
594 tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
595 tc_parent tc_name IfNoParent
596 = do { tc_rep_name <- newTyConRepName tc_name
597 ; return (VanillaAlgTyCon tc_rep_name) }
598 tc_parent _ (IfDataInstance ax_name _ arg_tys)
599 = do { ax <- tcIfaceCoAxiom ax_name
600 ; let fam_tc = coAxiomTyCon ax
601 ax_unbr = toUnbranchedAxiom ax
602 ; lhs_tys <- tcIfaceTcArgs arg_tys
603 ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
604
605 tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
606 ifRoles = roles,
607 ifSynRhs = rhs_ty,
608 ifBinders = binders,
609 ifResKind = res_kind })
610 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
611 { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
612 ; rhs <- forkM (mk_doc tc_name) $
613 tcIfaceType rhs_ty
614 ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs
615 ; return (ATyCon tycon) }
616 where
617 mk_doc n = text "Type synonym" <+> ppr n
618
619 tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
620 ifFamFlav = fam_flav,
621 ifBinders = binders,
622 ifResKind = res_kind,
623 ifResVar = res, ifFamInj = inj })
624 = bindIfaceTyConBinders_AT binders $ \ binders' -> do
625 { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
626 ; rhs <- forkM (mk_doc tc_name) $
627 tc_fam_flav tc_name fam_flav
628 ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
629 ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
630 ; return (ATyCon tycon) }
631 where
632 mk_doc n = text "Type synonym" <+> ppr n
633
634 tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
635 tc_fam_flav tc_name IfaceDataFamilyTyCon
636 = do { tc_rep_name <- newTyConRepName tc_name
637 ; return (DataFamilyTyCon tc_rep_name) }
638 tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
639 tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
640 = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
641 ; return (ClosedSynFamilyTyCon ax) }
642 tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
643 = return AbstractClosedSynFamilyTyCon
644 tc_fam_flav _ IfaceBuiltInSynFamTyCon
645 = pprPanic "tc_iface_decl"
646 (text "IfaceBuiltInSynFamTyCon in interface file")
647
648 tc_iface_decl _parent ignore_prags
649 (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_name,
650 ifRoles = roles,
651 ifBinders = binders,
652 ifFDs = rdr_fds,
653 ifATs = rdr_ats, ifSigs = rdr_sigs,
654 ifMinDef = mindef_occ })
655 -- ToDo: in hs-boot files we should really treat abstract classes specially,
656 -- as we do abstract tycons
657 = bindIfaceTyConBinders binders $ \ binders' -> do
658 { traceIf (text "tc-iface-class1" <+> ppr tc_name)
659 ; ctxt <- mapM tc_sc rdr_ctxt
660 ; traceIf (text "tc-iface-class2" <+> ppr tc_name)
661 ; sigs <- mapM tc_sig rdr_sigs
662 ; fds <- mapM tc_fd rdr_fds
663 ; traceIf (text "tc-iface-class3" <+> ppr tc_name)
664 ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
665 ; cls <- fixM $ \ cls -> do
666 { ats <- mapM (tc_at cls) rdr_ats
667 ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
668 ; buildClass tc_name binders' roles ctxt fds ats sigs mindef }
669 ; return (ATyCon (classTyCon cls)) }
670 where
671 tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
672 -- The *length* of the superclasses is used by buildClass, and hence must
673 -- not be inside the thunk. But the *content* maybe recursive and hence
674 -- must be lazy (via forkM). Example:
675 -- class C (T a) => D a where
676 -- data T a
677 -- Here the associated type T is knot-tied with the class, and
678 -- so we must not pull on T too eagerly. See Trac #5970
679
680 tc_sig :: IfaceClassOp -> IfL TcMethInfo
681 tc_sig (IfaceClassOp op_name rdr_ty dm)
682 = do { let doc = mk_op_doc op_name rdr_ty
683 ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
684 -- Must be done lazily for just the same reason as the
685 -- type of a data con; to avoid sucking in types that
686 -- it mentions unless it's necessary to do so
687 ; dm' <- tc_dm doc dm
688 ; return (op_name, op_ty, dm') }
689
690 tc_dm :: SDoc
691 -> Maybe (DefMethSpec IfaceType)
692 -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
693 tc_dm _ Nothing = return Nothing
694 tc_dm _ (Just VanillaDM) = return (Just VanillaDM)
695 tc_dm doc (Just (GenericDM ty))
696 = do { -- Must be done lazily to avoid sucking in types
697 ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
698 ; return (Just (GenericDM (noSrcSpan, ty'))) }
699
700 tc_at cls (IfaceAT tc_decl if_def)
701 = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
702 mb_def <- case if_def of
703 Nothing -> return Nothing
704 Just def -> forkM (mk_at_doc tc) $
705 extendIfaceTyVarEnv (tyConTyVars tc) $
706 do { tc_def <- tcIfaceType def
707 ; return (Just (tc_def, noSrcSpan)) }
708 -- Must be done lazily in case the RHS of the defaults mention
709 -- the type constructor being defined here
710 -- e.g. type AT a; type AT b = AT [b] Trac #8002
711 return (ATI tc mb_def)
712
713 mk_sc_doc pred = text "Superclass" <+> ppr pred
714 mk_at_doc tc = text "Associated type" <+> ppr tc
715 mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
716
717 tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
718 ; tvs2' <- mapM tcIfaceTyVar tvs2
719 ; return (tvs1', tvs2') }
720
721 tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
722 , ifAxBranches = branches, ifRole = role })
723 = do { tc_tycon <- tcIfaceTyCon tc
724 ; tc_branches <- tc_ax_branches branches
725 ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
726 , co_ax_name = tc_name
727 , co_ax_tc = tc_tycon
728 , co_ax_role = role
729 , co_ax_branches = manyBranches tc_branches
730 , co_ax_implicit = False }
731 ; return (ACoAxiom axiom) }
732
733 tc_iface_decl _ _ (IfacePatSyn{ ifName = name
734 , ifPatMatcher = if_matcher
735 , ifPatBuilder = if_builder
736 , ifPatIsInfix = is_infix
737 , ifPatUnivBndrs = univ_bndrs
738 , ifPatExBndrs = ex_bndrs
739 , ifPatProvCtxt = prov_ctxt
740 , ifPatReqCtxt = req_ctxt
741 , ifPatArgs = args
742 , ifPatTy = pat_ty
743 , ifFieldLabels = field_labels })
744 = do { traceIf (text "tc_iface_decl" <+> ppr name)
745 ; matcher <- tc_pr if_matcher
746 ; builder <- fmapMaybeM tc_pr if_builder
747 ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do
748 { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do
749 { patsyn <- forkM (mk_doc name) $
750 do { prov_theta <- tcIfaceCtxt prov_ctxt
751 ; req_theta <- tcIfaceCtxt req_ctxt
752 ; pat_ty <- tcIfaceType pat_ty
753 ; arg_tys <- mapM tcIfaceType args
754 ; return $ buildPatSyn name is_infix matcher builder
755 (univ_tvs, req_theta)
756 (ex_tvs, prov_theta)
757 arg_tys pat_ty field_labels }
758 ; return $ AConLike . PatSynCon $ patsyn }}}
759 where
760 mk_doc n = text "Pattern synonym" <+> ppr n
761 tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
762 tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
763 ; return (id, b) }
764
765 tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
766 tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
767
768 tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
769 tc_ax_branch prev_branches
770 (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
771 , ifaxbLHS = lhs, ifaxbRHS = rhs
772 , ifaxbRoles = roles, ifaxbIncomps = incomps })
773 = bindIfaceTyConBinders_AT
774 (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
775 -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
776 bindIfaceIds cv_bndrs $ \ cvs -> do
777 { tc_lhs <- tcIfaceTcArgs lhs
778 ; tc_rhs <- tcIfaceType rhs
779 ; let br = CoAxBranch { cab_loc = noSrcSpan
780 , cab_tvs = binderVars tvs
781 , cab_cvs = cvs
782 , cab_lhs = tc_lhs
783 , cab_roles = roles
784 , cab_rhs = tc_rhs
785 , cab_incomps = map (prev_branches `getNth`) incomps }
786 ; return (prev_branches ++ [br]) }
787
788 tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
789 tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
790 = case if_cons of
791 IfAbstractTyCon dis -> return (AbstractTyCon dis)
792 IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
793 ; data_cons <- mapM (tc_con_decl field_lbls) cons
794 ; return (mkDataTyConRhs data_cons) }
795 IfNewTyCon con _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
796 ; data_con <- tc_con_decl field_lbls con
797 ; mkNewTyConRhs tycon_name tycon data_con }
798 where
799 univ_tv_bndrs :: [TyVarBinder]
800 univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders
801
802 tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
803 ifConExTvs = ex_bndrs,
804 ifConName = dc_name,
805 ifConCtxt = ctxt, ifConEqSpec = spec,
806 ifConArgTys = args, ifConFields = my_lbls,
807 ifConStricts = if_stricts,
808 ifConSrcStricts = if_src_stricts})
809 = -- Universally-quantified tyvars are shared with
810 -- parent TyCon, and are already in scope
811 bindIfaceForAllBndrs ex_bndrs $ \ ex_tv_bndrs -> do
812 { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
813
814 -- Read the context and argument types, but lazily for two reasons
815 -- (a) to avoid looking tugging on a recursive use of
816 -- the type itself, which is knot-tied
817 -- (b) to avoid faulting in the component types unless
818 -- they are really needed
819 ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
820 do { eq_spec <- tcIfaceEqSpec spec
821 ; theta <- tcIfaceCtxt ctxt
822 ; arg_tys <- mapM tcIfaceType args
823 ; stricts <- mapM tc_strict if_stricts
824 -- The IfBang field can mention
825 -- the type itself; hence inside forkM
826 ; return (eq_spec, theta, arg_tys, stricts) }
827
828 -- Look up the field labels for this constructor; note that
829 -- they should be in the same order as my_lbls!
830 ; let lbl_names = map find_lbl my_lbls
831 find_lbl x = case find (\ fl -> flSelector fl == x) field_lbls of
832 Just fl -> fl
833 Nothing -> pprPanic "TcIface.find_lbl" not_found
834 where
835 not_found = text "missing:" <+> ppr (occName x)
836 $$ text "known labels:" <+> ppr field_lbls
837
838 -- Remember, tycon is the representation tycon
839 ; let orig_res_ty = mkFamilyTyConApp tycon
840 (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
841 (binderVars tc_tybinders))
842
843 ; prom_rep_name <- newTyConRepName dc_name
844
845 ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
846 dc_name is_infix prom_rep_name
847 (map src_strict if_src_stricts)
848 (Just stricts)
849 -- Pass the HsImplBangs (i.e. final
850 -- decisions) to buildDataCon; it'll use
851 -- these to guide the construction of a
852 -- worker.
853 -- See Note [Bangs on imported data constructors] in MkId
854 lbl_names
855 univ_tv_bndrs ex_tv_bndrs
856 eq_spec theta
857 arg_tys orig_res_ty tycon
858 ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
859 ; return con }
860 mk_doc con_name = text "Constructor" <+> ppr con_name
861
862 tc_strict :: IfaceBang -> IfL HsImplBang
863 tc_strict IfNoBang = return (HsLazy)
864 tc_strict IfStrict = return (HsStrict)
865 tc_strict IfUnpack = return (HsUnpack Nothing)
866 tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
867 ; return (HsUnpack (Just co)) }
868
869 src_strict :: IfaceSrcBang -> HsSrcBang
870 src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
871
872 tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
873 tcIfaceEqSpec spec
874 = mapM do_item spec
875 where
876 do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
877 ; ty <- tcIfaceType if_ty
878 ; return (mkEqSpec tv ty) }
879
880 {-
881 Note [Synonym kind loop]
882 ~~~~~~~~~~~~~~~~~~~~~~~~
883 Notice that we eagerly grab the *kind* from the interface file, but
884 build a forkM thunk for the *rhs* (and family stuff). To see why,
885 consider this (Trac #2412)
886
887 M.hs: module M where { import X; data T = MkT S }
888 X.hs: module X where { import {-# SOURCE #-} M; type S = T }
889 M.hs-boot: module M where { data T }
890
891 When kind-checking M.hs we need S's kind. But we do not want to
892 find S's kind from (typeKind S-rhs), because we don't want to look at
893 S-rhs yet! Since S is imported from X.hi, S gets just one chance to
894 be defined, and we must not do that until we've finished with M.T.
895
896 Solution: record S's kind in the interface file; now we can safely
897 look at it.
898
899 ************************************************************************
900 * *
901 Instances
902 * *
903 ************************************************************************
904 -}
905
906 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
907 tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
908 , ifInstCls = cls, ifInstTys = mb_tcs
909 , ifInstOrph = orph })
910 = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
911 fmap tyThingId (tcIfaceImplicit dfun_name)
912 ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
913 ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
914
915 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
916 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
917 , ifFamInstAxiom = axiom_name } )
918 = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
919 tcIfaceCoAxiom axiom_name
920 -- will panic if branched, but that's OK
921 ; let axiom'' = toUnbranchedAxiom axiom'
922 mb_tcs' = map (fmap ifaceTyConName) mb_tcs
923 ; return (mkImportedFamInst fam mb_tcs' axiom'') }
924
925 {-
926 ************************************************************************
927 * *
928 Rules
929 * *
930 ************************************************************************
931
932 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
933 are in the type environment. However, remember that typechecking a Rule may
934 (as a side effect) augment the type envt, and so we may need to iterate the process.
935 -}
936
937 tcIfaceRules :: Bool -- True <=> ignore rules
938 -> [IfaceRule]
939 -> IfL [CoreRule]
940 tcIfaceRules ignore_prags if_rules
941 | ignore_prags = return []
942 | otherwise = mapM tcIfaceRule if_rules
943
944 tcIfaceRule :: IfaceRule -> IfL CoreRule
945 tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
946 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
947 ifRuleAuto = auto, ifRuleOrph = orph })
948 = do { ~(bndrs', args', rhs') <-
949 -- Typecheck the payload lazily, in the hope it'll never be looked at
950 forkM (text "Rule" <+> pprRuleName name) $
951 bindIfaceBndrs bndrs $ \ bndrs' ->
952 do { args' <- mapM tcIfaceExpr args
953 ; rhs' <- tcIfaceExpr rhs
954 ; return (bndrs', args', rhs') }
955 ; let mb_tcs = map ifTopFreeName args
956 ; this_mod <- getIfModule
957 ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
958 ru_bndrs = bndrs', ru_args = args',
959 ru_rhs = occurAnalyseExpr rhs',
960 ru_rough = mb_tcs,
961 ru_origin = this_mod,
962 ru_orphan = orph,
963 ru_auto = auto,
964 ru_local = False }) } -- An imported RULE is never for a local Id
965 -- or, even if it is (module loop, perhaps)
966 -- we'll just leave it in the non-local set
967 where
968 -- This function *must* mirror exactly what Rules.roughTopNames does
969 -- We could have stored the ru_rough field in the iface file
970 -- but that would be redundant, I think.
971 -- The only wrinkle is that we must not be deceived by
972 -- type synonyms at the top of a type arg. Since
973 -- we can't tell at this point, we are careful not
974 -- to write them out in coreRuleToIfaceRule
975 ifTopFreeName :: IfaceExpr -> Maybe Name
976 ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
977 ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts)))
978 ifTopFreeName (IfaceApp f _) = ifTopFreeName f
979 ifTopFreeName (IfaceExt n) = Just n
980 ifTopFreeName _ = Nothing
981
982 {-
983 ************************************************************************
984 * *
985 Annotations
986 * *
987 ************************************************************************
988 -}
989
990 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
991 tcIfaceAnnotations = mapM tcIfaceAnnotation
992
993 tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
994 tcIfaceAnnotation (IfaceAnnotation target serialized) = do
995 target' <- tcIfaceAnnTarget target
996 return $ Annotation {
997 ann_target = target',
998 ann_value = serialized
999 }
1000
1001 tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
1002 tcIfaceAnnTarget (NamedTarget occ) = do
1003 name <- lookupIfaceTop occ
1004 return $ NamedTarget name
1005 tcIfaceAnnTarget (ModuleTarget mod) = do
1006 return $ ModuleTarget mod
1007
1008 {-
1009 ************************************************************************
1010 * *
1011 Vectorisation information
1012 * *
1013 ************************************************************************
1014 -}
1015
1016 -- We need access to the type environment as we need to look up information about type constructors
1017 -- (i.e., their data constructors and whether they are class type constructors). If a vectorised
1018 -- type constructor or class is defined in the same module as where it is vectorised, we cannot
1019 -- look that information up from the type constructor that we obtained via a 'forkM'ed
1020 -- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
1021 -- and again and again...
1022 --
1023 tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
1024 tcIfaceVectInfo mod typeEnv (IfaceVectInfo
1025 { ifaceVectInfoVar = vars
1026 , ifaceVectInfoTyCon = tycons
1027 , ifaceVectInfoTyConReuse = tyconsReuse
1028 , ifaceVectInfoParallelVars = parallelVars
1029 , ifaceVectInfoParallelTyCons = parallelTyCons
1030 })
1031 = do { let parallelTyConsSet = mkNameSet parallelTyCons
1032 ; vVars <- mapM vectVarMapping vars
1033 ; let varsSet = mkVarSet (map fst vVars)
1034 ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
1035 ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
1036 ; vParallelVars <- mapM vectVar parallelVars
1037 ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
1038 ; return $ VectInfo
1039 { vectInfoVar = mkDVarEnv vVars `extendDVarEnvList` concat vScSels
1040 , vectInfoTyCon = mkNameEnv vTyCons
1041 , vectInfoDataCon = mkNameEnv (concat vDataCons)
1042 , vectInfoParallelVars = mkDVarSet vParallelVars
1043 , vectInfoParallelTyCons = parallelTyConsSet
1044 }
1045 }
1046 where
1047 vectVarMapping name
1048 = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name)
1049 ; var <- forkM (text "vect var" <+> ppr name) $
1050 tcIfaceExtId name
1051 ; vVar <- forkM (text "vect vVar [mod =" <+>
1052 ppr mod <> text "; nameModule =" <+>
1053 ppr (nameModule name) <> text "]" <+> ppr vName) $
1054 tcIfaceExtId vName
1055 ; return (var, (var, vVar))
1056 }
1057 -- where
1058 -- lookupLocalOrExternalId name
1059 -- = do { let mb_id = lookupTypeEnv typeEnv name
1060 -- ; case mb_id of
1061 -- -- id is local
1062 -- Just (AnId id) -> return id
1063 -- -- name is not an Id => internal inconsistency
1064 -- Just _ -> notAnIdErr
1065 -- -- Id is external
1066 -- Nothing -> tcIfaceExtId name
1067 -- }
1068 --
1069 -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
1070
1071 vectVar name
1072 = forkM (text "vect scalar var" <+> ppr name) $
1073 tcIfaceExtId name
1074
1075 vectTyConVectMapping vars name
1076 = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name)
1077 ; vectTyConMapping vars name vName
1078 }
1079
1080 vectTyConReuseMapping vars name
1081 = vectTyConMapping vars name name
1082
1083 vectTyConMapping vars name vName
1084 = do { tycon <- lookupLocalOrExternalTyCon name
1085 ; vTycon <- forkM (text "vTycon of" <+> ppr vName) $
1086 lookupLocalOrExternalTyCon vName
1087
1088 -- Map the data constructors of the original type constructor to those of the
1089 -- vectorised type constructor /unless/ the type constructor was vectorised
1090 -- abstractly; if it was vectorised abstractly, the workers of its data constructors
1091 -- do not appear in the set of vectorised variables.
1092 --
1093 -- NB: This is lazy! We don't pull at the type constructors before we actually use
1094 -- the data constructor mapping.
1095 ; let isAbstract | isClassTyCon tycon = False
1096 | datacon:_ <- tyConDataCons tycon
1097 = not $ dataConWrapId datacon `elemVarSet` vars
1098 | otherwise = True
1099 vDataCons | isAbstract = []
1100 | otherwise = [ (dataConName datacon, (datacon, vDatacon))
1101 | (datacon, vDatacon) <- zip (tyConDataCons tycon)
1102 (tyConDataCons vTycon)
1103 ]
1104
1105 -- Map the (implicit) superclass and methods selectors as they don't occur in
1106 -- the var map.
1107 vScSels | Just cls <- tyConClass_maybe tycon
1108 , Just vCls <- tyConClass_maybe vTycon
1109 = [ (sel, (sel, vSel))
1110 | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
1111 ]
1112 | otherwise
1113 = []
1114
1115 ; return ( (name, (tycon, vTycon)) -- (T, T_v)
1116 , vDataCons -- list of (Ci, Ci_v)
1117 , vScSels -- list of (seli, seli_v)
1118 )
1119 }
1120 where
1121 -- we need a fully defined version of the type constructor to be able to extract
1122 -- its data constructors etc.
1123 lookupLocalOrExternalTyCon name
1124 = do { let mb_tycon = lookupTypeEnv typeEnv name
1125 ; case mb_tycon of
1126 -- tycon is local
1127 Just (ATyCon tycon) -> return tycon
1128 -- name is not a tycon => internal inconsistency
1129 Just _ -> notATyConErr
1130 -- tycon is external
1131 Nothing -> tcIfaceTyConByName name
1132 }
1133
1134 notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
1135
1136 {-
1137 ************************************************************************
1138 * *
1139 Types
1140 * *
1141 ************************************************************************
1142 -}
1143
1144 tcIfaceType :: IfaceType -> IfL Type
1145 tcIfaceType = go
1146 where
1147 go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
1148 go (IfaceTcTyVar n) = pprPanic "tcIfaceType:IfaceTcTyVar" (ppr n)
1149 go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2
1150 go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
1151 go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2
1152 go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2
1153 go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
1154 go (IfaceTyConApp tc tks)
1155 = do { tc' <- tcIfaceTyCon tc
1156 ; tks' <- mapM go (tcArgsIfaceTypes tks)
1157 ; return (mkTyConApp tc' tks') }
1158 go (IfaceForAllTy bndr t)
1159 = bindIfaceForAllBndr bndr $ \ tv' vis ->
1160 ForAllTy (TvBndr tv' vis) <$> go t
1161 go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
1162 go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
1163
1164 tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type
1165 tcIfaceTupleTy sort is_promoted args
1166 = do { args' <- tcIfaceTcArgs args
1167 ; let arity = length args'
1168 ; base_tc <- tcTupleTyCon True sort arity
1169 ; case is_promoted of
1170 IsNotPromoted
1171 -> return (mkTyConApp base_tc args')
1172
1173 IsPromoted
1174 -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc)
1175 kind_args = map typeKind args'
1176 ; return (mkTyConApp tc (kind_args ++ args')) } }
1177
1178 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1179 tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr)
1180 -> TupleSort
1181 -> Arity -- the number of args. *not* the tuple arity.
1182 -> IfL TyCon
1183 tcTupleTyCon in_type sort arity
1184 = case sort of
1185 ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
1186 ; return (tyThingTyCon thing) }
1187 BoxedTuple -> return (tupleTyCon Boxed arity)
1188 UnboxedTuple -> return (tupleTyCon Unboxed arity')
1189 where arity' | in_type = arity `div` 2
1190 | otherwise = arity
1191 -- in expressions, we only have term args
1192
1193 tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
1194 tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes
1195
1196 -----------------------------------------
1197 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
1198 tcIfaceCtxt sts = mapM tcIfaceType sts
1199
1200 -----------------------------------------
1201 tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
1202 tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
1203 tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
1204
1205 {-
1206 %************************************************************************
1207 %* *
1208 Coercions
1209 * *
1210 ************************************************************************
1211 -}
1212
1213 tcIfaceCo :: IfaceCoercion -> IfL Coercion
1214 tcIfaceCo = go
1215 where
1216 go (IfaceReflCo r t) = Refl r <$> tcIfaceType t
1217 go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
1218 go (IfaceTyConAppCo r tc cs)
1219 = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
1220 go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
1221 go (IfaceForAllCo tv k c) = do { k' <- go k
1222 ; bindIfaceTyVar tv $ \ tv' ->
1223 ForAllCo tv' k' <$> go c }
1224 go (IfaceCoVarCo n) = CoVarCo <$> go_var n
1225 go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
1226 go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
1227 <*> tcIfaceType t1 <*> tcIfaceType t2
1228 go (IfaceSymCo c) = SymCo <$> go c
1229 go (IfaceTransCo c1 c2) = TransCo <$> go c1
1230 <*> go c2
1231 go (IfaceInstCo c1 t2) = InstCo <$> go c1
1232 <*> go t2
1233 go (IfaceNthCo d c) = NthCo d <$> go c
1234 go (IfaceLRCo lr c) = LRCo lr <$> go c
1235 go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1
1236 <*> go c2
1237 go (IfaceKindCo c) = KindCo <$> go c
1238 go (IfaceSubCo c) = SubCo <$> go c
1239 go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax
1240 <*> mapM go cos
1241
1242 go_var :: FastString -> IfL CoVar
1243 go_var = tcIfaceLclId
1244
1245 go_axiom_rule :: FastString -> IfL CoAxiomRule
1246 go_axiom_rule n =
1247 case Map.lookup n typeNatCoAxiomRules of
1248 Just ax -> return ax
1249 _ -> pprPanic "go_axiom_rule" (ppr n)
1250
1251 tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
1252 tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
1253 tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
1254 tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
1255 tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
1256 tcIfaceUnivCoProv (IfaceHoleProv _) =
1257 pprPanic "tcIfaceUnivCoProv" (text "holes can't occur in interface files")
1258
1259 {-
1260 ************************************************************************
1261 * *
1262 Core
1263 * *
1264 ************************************************************************
1265 -}
1266
1267 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
1268 tcIfaceExpr (IfaceType ty)
1269 = Type <$> tcIfaceType ty
1270
1271 tcIfaceExpr (IfaceCo co)
1272 = Coercion <$> tcIfaceCo co
1273
1274 tcIfaceExpr (IfaceCast expr co)
1275 = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
1276
1277 tcIfaceExpr (IfaceLcl name)
1278 = Var <$> tcIfaceLclId name
1279
1280 tcIfaceExpr (IfaceExt gbl)
1281 = Var <$> tcIfaceExtId gbl
1282
1283 tcIfaceExpr (IfaceLit lit)
1284 = do lit' <- tcIfaceLit lit
1285 return (Lit lit')
1286
1287 tcIfaceExpr (IfaceFCall cc ty) = do
1288 ty' <- tcIfaceType ty
1289 u <- newUnique
1290 dflags <- getDynFlags
1291 return (Var (mkFCallId dflags u cc ty'))
1292
1293 tcIfaceExpr (IfaceTuple sort args)
1294 = do { args' <- mapM tcIfaceExpr args
1295 ; tc <- tcTupleTyCon False sort arity
1296 ; let con_tys = map exprType args'
1297 some_con_args = map Type con_tys ++ args'
1298 con_args = case sort of
1299 UnboxedTuple -> map (Type . getRuntimeRep "tcIfaceExpr") con_tys ++ some_con_args
1300 _ -> some_con_args
1301 -- Put the missing type arguments back in
1302 con_id = dataConWorkId (tyConSingleDataCon tc)
1303 ; return (mkApps (Var con_id) con_args) }
1304 where
1305 arity = length args
1306
1307 tcIfaceExpr (IfaceLam (bndr, os) body)
1308 = bindIfaceBndr bndr $ \bndr' ->
1309 Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
1310 where
1311 tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
1312 tcIfaceOneShot _ b = b
1313
1314 tcIfaceExpr (IfaceApp fun arg)
1315 = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
1316
1317 tcIfaceExpr (IfaceECase scrut ty)
1318 = do { scrut' <- tcIfaceExpr scrut
1319 ; ty' <- tcIfaceType ty
1320 ; return (castBottomExpr scrut' ty') }
1321
1322 tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
1323 scrut' <- tcIfaceExpr scrut
1324 case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
1325 let
1326 scrut_ty = exprType scrut'
1327 case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
1328 tc_app = splitTyConApp scrut_ty
1329 -- NB: Won't always succeed (polymorphic case)
1330 -- but won't be demanded in those cases
1331 -- NB: not tcSplitTyConApp; we are looking at Core here
1332 -- look through non-rec newtypes to find the tycon that
1333 -- corresponds to the datacon in this case alternative
1334
1335 extendIfaceIdEnv [case_bndr'] $ do
1336 alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
1337 return (Case scrut' case_bndr' (coreAltsType alts') alts')
1338
1339 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
1340 = do { name <- newIfaceName (mkVarOccFS fs)
1341 ; ty' <- tcIfaceType ty
1342 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1343 name ty' info
1344 ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
1345 ; rhs' <- tcIfaceExpr rhs
1346 ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
1347 ; return (Let (NonRec id rhs') body') }
1348
1349 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
1350 = do { ids <- mapM tc_rec_bndr (map fst pairs)
1351 ; extendIfaceIdEnv ids $ do
1352 { pairs' <- zipWithM tc_pair pairs ids
1353 ; body' <- tcIfaceExpr body
1354 ; return (Let (Rec pairs') body') } }
1355 where
1356 tc_rec_bndr (IfLetBndr fs ty _)
1357 = do { name <- newIfaceName (mkVarOccFS fs)
1358 ; ty' <- tcIfaceType ty
1359 ; return (mkLocalIdOrCoVar name ty') }
1360 tc_pair (IfLetBndr _ _ info, rhs) id
1361 = do { rhs' <- tcIfaceExpr rhs
1362 ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
1363 (idName id) (idType id) info
1364 ; return (setIdInfo id id_info, rhs') }
1365
1366 tcIfaceExpr (IfaceTick tickish expr) = do
1367 expr' <- tcIfaceExpr expr
1368 -- If debug flag is not set: Ignore source notes
1369 dbgLvl <- fmap debugLevel getDynFlags
1370 case tickish of
1371 IfaceSource{} | dbgLvl > 0
1372 -> return expr'
1373 _otherwise -> do
1374 tickish' <- tcIfaceTickish tickish
1375 return (Tick tickish' expr')
1376
1377 -------------------------
1378 tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
1379 tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
1380 tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
1381 tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
1382
1383 -------------------------
1384 tcIfaceLit :: Literal -> IfL Literal
1385 -- Integer literals deserialise to (LitInteger i <error thunk>)
1386 -- so tcIfaceLit just fills in the type.
1387 -- See Note [Integer literals] in Literal
1388 tcIfaceLit (LitInteger i _)
1389 = do t <- tcIfaceTyConByName integerTyConName
1390 return (mkLitInteger i (mkTyConTy t))
1391 tcIfaceLit lit = return lit
1392
1393 -------------------------
1394 tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
1395 -> (IfaceConAlt, [FastString], IfaceExpr)
1396 -> IfL (AltCon, [TyVar], CoreExpr)
1397 tcIfaceAlt _ _ (IfaceDefault, names, rhs)
1398 = ASSERT( null names ) do
1399 rhs' <- tcIfaceExpr rhs
1400 return (DEFAULT, [], rhs')
1401
1402 tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
1403 = ASSERT( null names ) do
1404 lit' <- tcIfaceLit lit
1405 rhs' <- tcIfaceExpr rhs
1406 return (LitAlt lit', [], rhs')
1407
1408 -- A case alternative is made quite a bit more complicated
1409 -- by the fact that we omit type annotations because we can
1410 -- work them out. True enough, but its not that easy!
1411 tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
1412 = do { con <- tcIfaceDataCon data_occ
1413 ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
1414 (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
1415 ; tcIfaceDataAlt con inst_tys arg_strs rhs }
1416
1417 tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
1418 -> IfL (AltCon, [TyVar], CoreExpr)
1419 tcIfaceDataAlt con inst_tys arg_strs rhs
1420 = do { us <- newUniqueSupply
1421 ; let uniqs = uniqsFromSupply us
1422 ; let (ex_tvs, arg_ids)
1423 = dataConRepFSInstPat arg_strs uniqs con inst_tys
1424
1425 ; rhs' <- extendIfaceEnvs ex_tvs $
1426 extendIfaceIdEnv arg_ids $
1427 tcIfaceExpr rhs
1428 ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
1429
1430 {-
1431 ************************************************************************
1432 * *
1433 IdInfo
1434 * *
1435 ************************************************************************
1436 -}
1437
1438 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
1439 tcIdDetails _ IfVanillaId = return VanillaId
1440 tcIdDetails ty IfDFunId
1441 = return (DFunId (isNewTyCon (classTyCon cls)))
1442 where
1443 (_, _, cls, _) = tcSplitDFunTy ty
1444
1445 tcIdDetails _ (IfRecSelId tc naughty)
1446 = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
1447 (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
1448 tc
1449 ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
1450 where
1451 tyThingPatSyn (AConLike (PatSynCon ps)) = ps
1452 tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
1453
1454 tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
1455 tcIdInfo ignore_prags name ty info = do
1456 lcl_env <- getLclEnv
1457 -- Set the CgInfo to something sensible but uninformative before
1458 -- we start; default assumption is that it has CAFs
1459 let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
1460 | otherwise = vanillaIdInfo
1461 if ignore_prags
1462 then return init_info
1463 else case info of
1464 NoInfo -> return init_info
1465 HasInfo info -> foldlM tcPrag init_info info
1466 where
1467 tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
1468 tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
1469 tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
1470 tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
1471 tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
1472 tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
1473
1474 -- The next two are lazy, so they don't transitively suck stuff in
1475 tcPrag info (HsUnfold lb if_unf)
1476 = do { unf <- tcUnfolding name ty info if_unf
1477 ; let info1 | lb = info `setOccInfo` strongLoopBreaker
1478 | otherwise = info
1479 ; return (info1 `setUnfoldingInfo` unf) }
1480
1481 tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
1482 tcUnfolding name _ info (IfCoreUnfold stable if_expr)
1483 = do { dflags <- getDynFlags
1484 ; mb_expr <- tcPragExpr name if_expr
1485 ; let unf_src | stable = InlineStable
1486 | otherwise = InlineRhs
1487 ; return $ case mb_expr of
1488 Nothing -> NoUnfolding
1489 Just expr -> mkUnfolding dflags unf_src
1490 True {- Top level -}
1491 (isBottomingSig strict_sig)
1492 expr
1493 }
1494 where
1495 -- Strictness should occur before unfolding!
1496 strict_sig = strictnessInfo info
1497 tcUnfolding name _ _ (IfCompulsory if_expr)
1498 = do { mb_expr <- tcPragExpr name if_expr
1499 ; return (case mb_expr of
1500 Nothing -> NoUnfolding
1501 Just expr -> mkCompulsoryUnfolding expr) }
1502
1503 tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
1504 = do { mb_expr <- tcPragExpr name if_expr
1505 ; return (case mb_expr of
1506 Nothing -> NoUnfolding
1507 Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
1508 where
1509 guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
1510
1511 tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
1512 = bindIfaceBndrs bs $ \ bs' ->
1513 do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
1514 ; return (case mb_ops1 of
1515 Nothing -> noUnfolding
1516 Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
1517 where
1518 doc = text "Class ops for dfun" <+> ppr name
1519 (_, _, cls, _) = tcSplitDFunTy dfun_ty
1520
1521 {-
1522 For unfoldings we try to do the job lazily, so that we never type check
1523 an unfolding that isn't going to be looked at.
1524 -}
1525
1526 tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
1527 tcPragExpr name expr
1528 = forkM_maybe doc $ do
1529 core_expr' <- tcIfaceExpr expr
1530
1531 -- Check for type consistency in the unfolding
1532 whenGOptM Opt_DoCoreLinting $ do
1533 in_scope <- get_in_scope
1534 dflags <- getDynFlags
1535 case lintUnfolding dflags noSrcLoc in_scope core_expr' of
1536 Nothing -> return ()
1537 Just fail_msg -> do { mod <- getIfModule
1538 ; pprPanic "Iface Lint failure"
1539 (vcat [ text "In interface for" <+> ppr mod
1540 , hang doc 2 fail_msg
1541 , ppr name <+> equals <+> ppr core_expr'
1542 , text "Iface expr =" <+> ppr expr ]) }
1543 return core_expr'
1544 where
1545 doc = text "Unfolding of" <+> ppr name
1546
1547 get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
1548 get_in_scope
1549 = do { (gbl_env, lcl_env) <- getEnvs
1550 ; rec_ids <- case if_rec_types gbl_env of
1551 Nothing -> return []
1552 Just (_, get_env) -> do
1553 { type_env <- setLclEnv () get_env
1554 ; return (typeEnvIds type_env) }
1555 ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
1556 bindingsVars (if_id_env lcl_env) `unionVarSet`
1557 mkVarSet rec_ids) }
1558
1559 bindingsVars :: FastStringEnv Var -> VarSet
1560 bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
1561 -- It's OK to use nonDetEltsUFM here because we immediately forget
1562 -- the ordering by creating a set
1563
1564 {-
1565 ************************************************************************
1566 * *
1567 Getting from Names to TyThings
1568 * *
1569 ************************************************************************
1570 -}
1571
1572 tcIfaceGlobal :: Name -> IfL TyThing
1573 tcIfaceGlobal name
1574 | Just thing <- wiredInNameTyThing_maybe name
1575 -- Wired-in things include TyCons, DataCons, and Ids
1576 -- Even though we are in an interface file, we want to make
1577 -- sure the instances and RULES of this thing (particularly TyCon) are loaded
1578 -- Imagine: f :: Double -> Double
1579 = do { ifCheckWiredInThing thing; return thing }
1580
1581 | otherwise
1582 = do { env <- getGblEnv
1583 ; case if_rec_types env of { -- Note [Tying the knot]
1584 Just (mod, get_type_env)
1585 | nameIsLocalOrFrom mod name
1586 -> do -- It's defined in the module being compiled
1587 { type_env <- setLclEnv () get_type_env -- yuk
1588 ; case lookupNameEnv type_env name of
1589 Just thing -> return thing
1590 Nothing ->
1591 pprPanic "tcIfaceGlobal (local): not found"
1592 (ifKnotErr name (if_doc env) type_env)
1593 }
1594
1595 ; _ -> do
1596
1597 { hsc_env <- getTopEnv
1598 ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
1599 ; case mb_thing of {
1600 Just thing -> return thing ;
1601 Nothing -> do
1602
1603 { mb_thing <- importDecl name -- It's imported; go get it
1604 ; case mb_thing of
1605 Failed err -> failIfM err
1606 Succeeded thing -> return thing
1607 }}}}}
1608
1609 ifKnotErr :: Name -> SDoc -> TypeEnv -> SDoc
1610 ifKnotErr name env_doc type_env = vcat
1611 [ text "You are in a maze of twisty little passages, all alike."
1612 , text "While forcing the thunk for TyThing" <+> ppr name
1613 , text "which was lazily initialized by" <+> env_doc <> text ","
1614 , text "I tried to tie the knot, but I couldn't find" <+> ppr name
1615 , text "in the current type environment."
1616 , text "If you are developing GHC, please read Note [Tying the knot]"
1617 , text "and Note [Type-checking inside the knot]."
1618 , text "Consider rebuilding GHC with profiling for a better stack trace."
1619 , hang (text "Contents of current type environment:")
1620 2 (ppr type_env)
1621 ]
1622
1623 -- Note [Tying the knot]
1624 -- ~~~~~~~~~~~~~~~~~~~~~
1625 -- The if_rec_types field is used when we are compiling M.hs, which indirectly
1626 -- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
1627 -- environment, which is splatted into if_rec_types after we've built M's type
1628 -- envt.
1629 --
1630 -- This is a dark and complicated part of GHC type checking, with a lot
1631 -- of moving parts. Interested readers should also look at:
1632 --
1633 -- * Note [Knot-tying typecheckIface]
1634 -- * Note [DFun knot-tying]
1635 -- * Note [hsc_type_env_var hack]
1636 --
1637 -- There is also a wiki page on the subject, see:
1638 --
1639 -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot
1640
1641 tcIfaceTyConByName :: IfExtName -> IfL TyCon
1642 tcIfaceTyConByName name
1643 = do { thing <- tcIfaceGlobal name
1644 ; return (tyThingTyCon thing) }
1645
1646 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
1647 tcIfaceTyCon (IfaceTyCon name info)
1648 = do { thing <- tcIfaceGlobal name
1649 ; return $ case ifaceTyConIsPromoted info of
1650 IsNotPromoted -> tyThingTyCon thing
1651 IsPromoted -> promoteDataCon $ tyThingDataCon thing }
1652
1653 tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
1654 tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
1655 ; return (tyThingCoAxiom thing) }
1656
1657 tcIfaceDataCon :: Name -> IfL DataCon
1658 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
1659 ; case thing of
1660 AConLike (RealDataCon dc) -> return dc
1661 _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
1662
1663 tcIfaceExtId :: Name -> IfL Id
1664 tcIfaceExtId name = do { thing <- tcIfaceGlobal name
1665 ; case thing of
1666 AnId id -> return id
1667 _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
1668
1669 -- See Note [The implicit TypeEnv]
1670 tcIfaceImplicit :: Name -> IfL TyThing
1671 tcIfaceImplicit n = do
1672 lcl_env <- getLclEnv
1673 case if_implicits_env lcl_env of
1674 Nothing -> tcIfaceGlobal n
1675 Just tenv ->
1676 case lookupTypeEnv tenv n of
1677 Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
1678 Just tything -> return tything
1679
1680 {-
1681 ************************************************************************
1682 * *
1683 Bindings
1684 * *
1685 ************************************************************************
1686 -}
1687
1688 bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
1689 bindIfaceId (fs, ty) thing_inside
1690 = do { name <- newIfaceName (mkVarOccFS fs)
1691 ; ty' <- tcIfaceType ty
1692 ; let id = mkLocalIdOrCoVar name ty'
1693 ; extendIfaceIdEnv [id] (thing_inside id) }
1694
1695 bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
1696 bindIfaceIds [] thing_inside = thing_inside []
1697 bindIfaceIds (b:bs) thing_inside
1698 = bindIfaceId b $ \b' ->
1699 bindIfaceIds bs $ \bs' ->
1700 thing_inside (b':bs')
1701
1702 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
1703 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
1704 = bindIfaceId bndr thing_inside
1705 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
1706 = bindIfaceTyVar bndr thing_inside
1707
1708 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
1709 bindIfaceBndrs [] thing_inside = thing_inside []
1710 bindIfaceBndrs (b:bs) thing_inside
1711 = bindIfaceBndr b $ \ b' ->
1712 bindIfaceBndrs bs $ \ bs' ->
1713 thing_inside (b':bs')
1714
1715 -----------------------
1716 bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a
1717 bindIfaceForAllBndrs [] thing_inside = thing_inside []
1718 bindIfaceForAllBndrs (bndr:bndrs) thing_inside
1719 = bindIfaceForAllBndr bndr $ \tv vis ->
1720 bindIfaceForAllBndrs bndrs $ \bndrs' ->
1721 thing_inside (mkTyVarBinder vis tv : bndrs')
1722
1723 bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a
1724 bindIfaceForAllBndr (TvBndr tv vis) thing_inside
1725 = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
1726
1727 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
1728 bindIfaceTyVar (occ,kind) thing_inside
1729 = do { name <- newIfaceName (mkTyVarOccFS occ)
1730 ; tyvar <- mk_iface_tyvar name kind
1731 ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
1732
1733 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
1734 mk_iface_tyvar name ifKind
1735 = do { kind <- tcIfaceType ifKind
1736 ; return (Var.mkTyVar name kind) }
1737
1738 bindIfaceTyConBinders :: [IfaceTyConBinder]
1739 -> ([TyConBinder] -> IfL a) -> IfL a
1740 bindIfaceTyConBinders [] thing_inside = thing_inside []
1741 bindIfaceTyConBinders (b:bs) thing_inside
1742 = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' ->
1743 bindIfaceTyConBinders bs $ \ bs' ->
1744 thing_inside (b':bs')
1745
1746 bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
1747 -> ([TyConBinder] -> IfL a) -> IfL a
1748 -- Used for type variable in nested associated data/type declarations
1749 -- where some of the type variables are already in scope
1750 -- class C a where { data T a b }
1751 -- Here 'a' is in scope when we look at the 'data T'
1752 bindIfaceTyConBinders_AT [] thing_inside
1753 = thing_inside []
1754 bindIfaceTyConBinders_AT (b : bs) thing_inside
1755 = bindIfaceTyConBinderX bind_tv b $ \b' ->
1756 bindIfaceTyConBinders_AT bs $ \bs' ->
1757 thing_inside (b':bs')
1758 where
1759 bind_tv tv thing
1760 = do { mb_tv <- lookupIfaceTyVar tv
1761 ; case mb_tv of
1762 Just b' -> thing b'
1763 Nothing -> bindIfaceTyVar tv thing }
1764
1765 bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)
1766 -> IfaceTyConBinder
1767 -> (TyConBinder -> IfL a) -> IfL a
1768 bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside
1769 = bind_tv tv $ \tv' ->
1770 thing_inside (TvBndr tv' vis)