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