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