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