Fix recompilation avoidance bug for implementor of hsig.
[ghc.git] / compiler / iface / MkIface.hs
1 {-
2 (c) The University of Glasgow 2006-2008
3 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 -}
5
6 {-# LANGUAGE CPP, NondecreasingIndentation #-}
7
8 -- | Module for constructing @ModIface@ values (interface files),
9 -- writing them to disk and comparing two versions to see if
10 -- recompilation is required.
11 module MkIface (
12 mkIface, -- Build a ModIface from a ModGuts,
13 -- including computing version information
14
15 mkIfaceTc,
16
17 writeIfaceFile, -- Write the interface file
18
19 checkOldIface, -- See if recompilation is required, by
20 -- comparing version information
21 RecompileRequired(..), recompileRequired,
22 mkIfaceExports,
23
24 tyThingToIfaceDecl -- Converting things to their Iface equivalents
25 ) where
26
27 {-
28 -----------------------------------------------
29 Recompilation checking
30 -----------------------------------------------
31
32 A complete description of how recompilation checking works can be
33 found in the wiki commentary:
34
35 http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
36
37 Please read the above page for a top-down description of how this all
38 works. Notes below cover specific issues related to the implementation.
39
40 Basic idea:
41
42 * In the mi_usages information in an interface, we record the
43 fingerprint of each free variable of the module
44
45 * In mkIface, we compute the fingerprint of each exported thing A.f.
46 For each external thing that A.f refers to, we include the fingerprint
47 of the external reference when computing the fingerprint of A.f. So
48 if anything that A.f depends on changes, then A.f's fingerprint will
49 change.
50 Also record any dependent files added with
51 * addDependentFile
52 * #include
53 * -optP-include
54
55 * In checkOldIface we compare the mi_usages for the module with
56 the actual fingerprint for all each thing recorded in mi_usages
57 -}
58
59 #include "HsVersions.h"
60
61 import IfaceSyn
62 import BinFingerprint
63 import LoadIface
64 import ToIface
65 import FlagChecker
66
67 import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )
68 import Id
69 import Annotations
70 import CoreSyn
71 import Class
72 import TyCon
73 import CoAxiom
74 import ConLike
75 import DataCon
76 import Type
77 import TcType
78 import InstEnv
79 import FamInstEnv
80 import TcRnMonad
81 import HsSyn
82 import HscTypes
83 import Finder
84 import DynFlags
85 import VarEnv
86 import VarSet
87 import Var
88 import Name
89 import Avail
90 import RdrName
91 import NameEnv
92 import NameSet
93 import Module
94 import BinIface
95 import ErrUtils
96 import Digraph
97 import SrcLoc
98 import Outputable
99 import BasicTypes hiding ( SuccessFlag(..) )
100 import Unique
101 import Util hiding ( eqListBy )
102 import FastString
103 import Maybes
104 import Binary
105 import Fingerprint
106 import Exception
107 import UniqSet
108 import UniqDFM
109 import Packages
110
111 import Control.Monad
112 import Data.Function
113 import Data.List
114 import qualified Data.Map as Map
115 import Data.Ord
116 import Data.IORef
117 import System.Directory
118 import System.FilePath
119
120 {-
121 ************************************************************************
122 * *
123 \subsection{Completing an interface}
124 * *
125 ************************************************************************
126 -}
127
128 mkIface :: HscEnv
129 -> Maybe Fingerprint -- The old fingerprint, if we have it
130 -> ModDetails -- The trimmed, tidied interface
131 -> ModGuts -- Usages, deprecations, etc
132 -> IO (ModIface, -- The new one
133 Bool) -- True <=> there was an old Iface, and the
134 -- new one is identical, so no need
135 -- to write it
136
137 mkIface hsc_env maybe_old_fingerprint mod_details
138 ModGuts{ mg_module = this_mod,
139 mg_hsc_src = hsc_src,
140 mg_usages = usages,
141 mg_used_th = used_th,
142 mg_deps = deps,
143 mg_rdr_env = rdr_env,
144 mg_fix_env = fix_env,
145 mg_warns = warns,
146 mg_hpc_info = hpc_info,
147 mg_safe_haskell = safe_mode,
148 mg_trust_pkg = self_trust
149 }
150 = mkIface_ hsc_env maybe_old_fingerprint
151 this_mod hsc_src used_th deps rdr_env fix_env
152 warns hpc_info self_trust
153 safe_mode usages mod_details
154
155 -- | make an interface from the results of typechecking only. Useful
156 -- for non-optimising compilation, or where we aren't generating any
157 -- object code at all ('HscNothing').
158 mkIfaceTc :: HscEnv
159 -> Maybe Fingerprint -- The old fingerprint, if we have it
160 -> SafeHaskellMode -- The safe haskell mode
161 -> ModDetails -- gotten from mkBootModDetails, probably
162 -> TcGblEnv -- Usages, deprecations, etc
163 -> IO (ModIface, Bool)
164 mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
165 tc_result@TcGblEnv{ tcg_mod = this_mod,
166 tcg_src = hsc_src,
167 tcg_imports = imports,
168 tcg_rdr_env = rdr_env,
169 tcg_fix_env = fix_env,
170 tcg_merged = merged,
171 tcg_warns = warns,
172 tcg_hpc = other_hpc_info,
173 tcg_th_splice_used = tc_splice_used,
174 tcg_dependent_files = dependent_files
175 }
176 = do
177 let used_names = mkUsedNames tc_result
178 deps <- mkDependencies tc_result
179 let hpc_info = emptyHpcInfo other_hpc_info
180 used_th <- readIORef tc_splice_used
181 dep_files <- (readIORef dependent_files)
182 -- Do NOT use semantic module here; this_mod in mkUsageInfo
183 -- is used solely to decide if we should record a dependency
184 -- or not. When we instantiate a signature, the semantic
185 -- module is something we want to record dependencies for,
186 -- but if you pass that in here, we'll decide it's the local
187 -- module and does not need to be recorded as a dependency.
188 -- See Note [Identity versus semantic module]
189 usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged
190 mkIface_ hsc_env maybe_old_fingerprint
191 this_mod hsc_src
192 used_th deps rdr_env
193 fix_env warns hpc_info
194 (imp_trust_own_pkg imports) safe_mode usages mod_details
195
196
197 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
198 -> Bool -> Dependencies -> GlobalRdrEnv
199 -> NameEnv FixItem -> Warnings -> HpcInfo
200 -> Bool
201 -> SafeHaskellMode
202 -> [Usage]
203 -> ModDetails
204 -> IO (ModIface, Bool)
205 mkIface_ hsc_env maybe_old_fingerprint
206 this_mod hsc_src used_th deps rdr_env fix_env src_warns
207 hpc_info pkg_trust_req safe_mode usages
208 ModDetails{ md_insts = insts,
209 md_fam_insts = fam_insts,
210 md_rules = rules,
211 md_anns = anns,
212 md_vect_info = vect_info,
213 md_types = type_env,
214 md_exports = exports,
215 md_complete_sigs = complete_sigs }
216 -- NB: notice that mkIface does not look at the bindings
217 -- only at the TypeEnv. The previous Tidy phase has
218 -- put exactly the info into the TypeEnv that we want
219 -- to expose in the interface
220
221 = do
222 let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
223 entities = typeEnvElts type_env
224 decls = [ tyThingToIfaceDecl entity
225 | entity <- entities,
226 let name = getName entity,
227 not (isImplicitTyThing entity),
228 -- No implicit Ids and class tycons in the interface file
229 not (isWiredInName name),
230 -- Nor wired-in things; the compiler knows about them anyhow
231 nameIsLocalOrFrom semantic_mod name ]
232 -- Sigh: see Note [Root-main Id] in TcRnDriver
233 -- NB: ABSOLUTELY need to check against semantic_mod,
234 -- because all of the names in an hsig p[H=<H>]:H
235 -- are going to be for <H>, not the former id!
236 -- See Note [Identity versus semantic module]
237
238 fixities = sortBy (comparing fst)
239 [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
240 -- The order of fixities returned from nameEnvElts is not
241 -- deterministic, so we sort by OccName to canonicalize it.
242 -- See Note [Deterministic UniqFM] in UniqDFM for more details.
243 warns = src_warns
244 iface_rules = map coreRuleToIfaceRule rules
245 iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
246 iface_fam_insts = map famInstToIfaceFamInst fam_insts
247 iface_vect_info = flattenVectInfo vect_info
248 trust_info = setSafeMode safe_mode
249 annotations = map mkIfaceAnnotation anns
250 icomplete_sigs = map mkIfaceCompleteSig complete_sigs
251
252 intermediate_iface = ModIface {
253 mi_module = this_mod,
254 -- Need to record this because it depends on the -instantiated-with flag
255 -- which could change
256 mi_sig_of = if semantic_mod == this_mod
257 then Nothing
258 else Just semantic_mod,
259 mi_hsc_src = hsc_src,
260 mi_deps = deps,
261 mi_usages = usages,
262 mi_exports = mkIfaceExports exports,
263
264 -- Sort these lexicographically, so that
265 -- the result is stable across compilations
266 mi_insts = sortBy cmp_inst iface_insts,
267 mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts,
268 mi_rules = sortBy cmp_rule iface_rules,
269
270 mi_vect_info = iface_vect_info,
271
272 mi_fixities = fixities,
273 mi_warns = warns,
274 mi_anns = annotations,
275 mi_globals = maybeGlobalRdrEnv rdr_env,
276
277 -- Left out deliberately: filled in by addFingerprints
278 mi_iface_hash = fingerprint0,
279 mi_mod_hash = fingerprint0,
280 mi_flag_hash = fingerprint0,
281 mi_exp_hash = fingerprint0,
282 mi_used_th = used_th,
283 mi_orphan_hash = fingerprint0,
284 mi_orphan = False, -- Always set by addFingerprints, but
285 -- it's a strict field, so we can't omit it.
286 mi_finsts = False, -- Ditto
287 mi_decls = deliberatelyOmitted "decls",
288 mi_hash_fn = deliberatelyOmitted "hash_fn",
289 mi_hpc = isHpcUsed hpc_info,
290 mi_trust = trust_info,
291 mi_trust_pkg = pkg_trust_req,
292
293 -- And build the cached values
294 mi_warn_fn = mkIfaceWarnCache warns,
295 mi_fix_fn = mkIfaceFixCache fixities,
296 mi_complete_sigs = icomplete_sigs }
297
298 (new_iface, no_change_at_all)
299 <- {-# SCC "versioninfo" #-}
300 addFingerprints hsc_env maybe_old_fingerprint
301 intermediate_iface decls
302
303 -- Debug printing
304 dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
305 (pprModIface new_iface)
306
307 -- bug #1617: on reload we weren't updating the PrintUnqualified
308 -- correctly. This stems from the fact that the interface had
309 -- not changed, so addFingerprints returns the old ModIface
310 -- with the old GlobalRdrEnv (mi_globals).
311 let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
312
313 return (final_iface, no_change_at_all)
314 where
315 cmp_rule = comparing ifRuleName
316 -- Compare these lexicographically by OccName, *not* by unique,
317 -- because the latter is not stable across compilations:
318 cmp_inst = comparing (nameOccName . ifDFun)
319 cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
320
321 dflags = hsc_dflags hsc_env
322
323 -- We only fill in mi_globals if the module was compiled to byte
324 -- code. Otherwise, the compiler may not have retained all the
325 -- top-level bindings and they won't be in the TypeEnv (see
326 -- Desugar.addExportFlagsAndRules). The mi_globals field is used
327 -- by GHCi to decide whether the module has its full top-level
328 -- scope available. (#5534)
329 maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
330 maybeGlobalRdrEnv rdr_env
331 | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
332 | otherwise = Nothing
333
334 deliberatelyOmitted :: String -> a
335 deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
336
337 ifFamInstTcName = ifFamInstFam
338
339 flattenVectInfo (VectInfo { vectInfoVar = vVar
340 , vectInfoTyCon = vTyCon
341 , vectInfoParallelVars = vParallelVars
342 , vectInfoParallelTyCons = vParallelTyCons
343 }) =
344 IfaceVectInfo
345 { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- dVarEnvElts vVar]
346 , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
347 , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
348 , ifaceVectInfoParallelVars = [Var.varName v | v <- dVarSetElems vParallelVars]
349 , ifaceVectInfoParallelTyCons = nameSetElemsStable vParallelTyCons
350 }
351
352 -----------------------------
353 writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
354 writeIfaceFile dflags hi_file_path new_iface
355 = do createDirectoryIfMissing True (takeDirectory hi_file_path)
356 writeBinIface dflags hi_file_path new_iface
357
358
359 -- -----------------------------------------------------------------------------
360 -- Look up parents and versions of Names
361
362 -- This is like a global version of the mi_hash_fn field in each ModIface.
363 -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
364 -- the parent and version info.
365
366 mkHashFun
367 :: HscEnv -- needed to look up versions
368 -> ExternalPackageState -- ditto
369 -> (Name -> IO Fingerprint)
370 mkHashFun hsc_env eps name
371 | isHoleModule orig_mod
372 = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))
373 | otherwise
374 = lookup orig_mod
375 where
376 dflags = hsc_dflags hsc_env
377 hpt = hsc_HPT hsc_env
378 pit = eps_PIT eps
379 occ = nameOccName name
380 orig_mod = nameModule name
381 lookup mod = do
382 MASSERT2( isExternalName name, ppr name )
383 iface <- case lookupIfaceByModule dflags hpt pit mod of
384 Just iface -> return iface
385 Nothing -> do
386 -- This can occur when we're writing out ifaces for
387 -- requirements; we didn't do any /real/ typechecking
388 -- so there's no guarantee everything is loaded.
389 -- Kind of a heinous hack.
390 iface <- initIfaceLoad hsc_env . withException
391 $ loadInterface (text "lookupVers2") mod ImportBySystem
392 return iface
393 return $ snd (mi_hash_fn iface occ `orElse`
394 pprPanic "lookupVers1" (ppr mod <+> ppr occ))
395
396 -- ---------------------------------------------------------------------------
397 -- Compute fingerprints for the interface
398
399 {-
400 Note [Fingerprinting IfaceDecls]
401 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
402
403 The general idea here is that we first examine the 'IfaceDecl's and determine
404 the recursive groups of them. We then walk these groups in dependency order,
405 serializing each contained 'IfaceDecl' to a "Binary" buffer which we then
406 hash using MD5 to produce a fingerprint for the group.
407
408 However, the serialization that we use is a bit funny: we override the @putName@
409 operation with our own which serializes the hash of a 'Name' instead of the
410 'Name' itself. This ensures that the fingerprint of a decl changes if anything
411 in its transitive closure changes. This trick is why we must be careful about
412 traversing in dependency order: we need to ensure that we have hashes for
413 everything referenced by the decl which we are fingerprinting.
414
415 Moreover, we need to be careful to distinguish between serialization of binding
416 Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls
417 field of a IfaceClsInst): only in the non-binding case should we include the
418 fingerprint; in the binding case we shouldn't since it is merely the name of the
419 thing that we are currently fingerprinting.
420 -}
421
422 -- | Add fingerprints for top-level declarations to a 'ModIface'.
423 --
424 -- See Note [Fingerprinting IfaceDecls]
425 addFingerprints
426 :: HscEnv
427 -> Maybe Fingerprint -- the old fingerprint, if any
428 -> ModIface -- The new interface (lacking decls)
429 -> [IfaceDecl] -- The new decls
430 -> IO (ModIface, -- Updated interface
431 Bool) -- True <=> no changes at all;
432 -- no need to write Iface
433
434 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
435 = do
436 eps <- hscEPS hsc_env
437 let
438 -- The ABI of a declaration represents everything that is made
439 -- visible about the declaration that a client can depend on.
440 -- see IfaceDeclABI below.
441 declABI :: IfaceDecl -> IfaceDeclABI
442 -- TODO: I'm not sure if this should be semantic_mod or this_mod.
443 -- See also Note [Identity versus semantic module]
444 declABI decl = (this_mod, decl, extras)
445 where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
446 non_orph_fis decl
447
448 edges :: [(IfaceDeclABI, Unique, [Unique])]
449 edges = [ (abi, getUnique (getOccName decl), out)
450 | decl <- new_decls
451 , let abi = declABI decl
452 , let out = localOccs $ freeNamesDeclABI abi
453 ]
454
455 name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
456 localOccs =
457 map (getUnique . getParent . getOccName)
458 -- NB: names always use semantic module, so
459 -- filtering must be on the semantic module!
460 -- See Note [Identity versus semantic module]
461 . filter ((== semantic_mod) . name_module)
462 . nonDetEltsUniqSet
463 -- It's OK to use nonDetEltsUFM as localOccs is only
464 -- used to construct the edges and
465 -- stronglyConnCompFromEdgedVertices is deterministic
466 -- even with non-deterministic order of edges as
467 -- explained in Note [Deterministic SCC] in Digraph.
468 where getParent :: OccName -> OccName
469 getParent occ = lookupOccEnv parent_map occ `orElse` occ
470
471 -- maps OccNames to their parents in the current module.
472 -- e.g. a reference to a constructor must be turned into a reference
473 -- to the TyCon for the purposes of calculating dependencies.
474 parent_map :: OccEnv OccName
475 parent_map = foldl' extend emptyOccEnv new_decls
476 where extend env d =
477 extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
478 where n = getOccName d
479
480 -- strongly-connected groups of declarations, in dependency order
481 groups :: [SCC IfaceDeclABI]
482 groups =
483 stronglyConnCompFromEdgedVerticesUniq edges
484
485 global_hash_fn = mkHashFun hsc_env eps
486
487 -- How to output Names when generating the data to fingerprint.
488 -- Here we want to output the fingerprint for each top-level
489 -- Name, whether it comes from the current module or another
490 -- module. In this way, the fingerprint for a declaration will
491 -- change if the fingerprint for anything it refers to (transitively)
492 -- changes.
493 mk_put_name :: OccEnv (OccName,Fingerprint)
494 -> BinHandle -> Name -> IO ()
495 mk_put_name local_env bh name
496 | isWiredInName name = putNameLiterally bh name
497 -- wired-in names don't have fingerprints
498 | otherwise
499 = ASSERT2( isExternalName name, ppr name )
500 let hash | nameModule name /= semantic_mod = global_hash_fn name
501 -- Get it from the REAL interface!!
502 -- This will trigger when we compile an hsig file
503 -- and we know a backing impl for it.
504 -- See Note [Identity versus semantic module]
505 | semantic_mod /= this_mod
506 , not (isHoleModule semantic_mod) = global_hash_fn name
507 | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
508 `orElse` pprPanic "urk! lookup local fingerprint"
509 (ppr name $$ ppr local_env)))
510 -- This panic indicates that we got the dependency
511 -- analysis wrong, because we needed a fingerprint for
512 -- an entity that wasn't in the environment. To debug
513 -- it, turn the panic into a trace, uncomment the
514 -- pprTraces below, run the compile again, and inspect
515 -- the output and the generated .hi file with
516 -- --show-iface.
517 in hash >>= put_ bh
518
519 -- take a strongly-connected group of declarations and compute
520 -- its fingerprint.
521
522 fingerprint_group :: (OccEnv (OccName,Fingerprint),
523 [(Fingerprint,IfaceDecl)])
524 -> SCC IfaceDeclABI
525 -> IO (OccEnv (OccName,Fingerprint),
526 [(Fingerprint,IfaceDecl)])
527
528 fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
529 = do let hash_fn = mk_put_name local_env
530 decl = abiDecl abi
531 --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
532 hash <- computeFingerprint hash_fn abi
533 env' <- extend_hash_env local_env (hash,decl)
534 return (env', (hash,decl) : decls_w_hashes)
535
536 fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
537 = do let decls = map abiDecl abis
538 local_env1 <- foldM extend_hash_env local_env
539 (zip (repeat fingerprint0) decls)
540 let hash_fn = mk_put_name local_env1
541 -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
542 let stable_abis = sortBy cmp_abiNames abis
543 -- put the cycle in a canonical order
544 hash <- computeFingerprint hash_fn stable_abis
545 let pairs = zip (repeat hash) decls
546 local_env2 <- foldM extend_hash_env local_env pairs
547 return (local_env2, pairs ++ decls_w_hashes)
548
549 -- we have fingerprinted the whole declaration, but we now need
550 -- to assign fingerprints to all the OccNames that it binds, to
551 -- use when referencing those OccNames in later declarations.
552 --
553 extend_hash_env :: OccEnv (OccName,Fingerprint)
554 -> (Fingerprint,IfaceDecl)
555 -> IO (OccEnv (OccName,Fingerprint))
556 extend_hash_env env0 (hash,d) = do
557 return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
558 (ifaceDeclFingerprints hash d))
559
560 --
561 (local_env, decls_w_hashes) <-
562 foldM fingerprint_group (emptyOccEnv, []) groups
563
564 -- when calculating fingerprints, we always need to use canonical
565 -- ordering for lists of things. In particular, the mi_deps has various
566 -- lists of modules and suchlike, so put these all in canonical order:
567 let sorted_deps = sortDependencies (mi_deps iface0)
568
569 -- The export hash of a module depends on the orphan hashes of the
570 -- orphan modules below us in the dependency tree. This is the way
571 -- that changes in orphans get propagated all the way up the
572 -- dependency tree.
573 --
574 -- Note [A bad dep_orphs optimization]
575 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
576 -- In a previous version of this code, we filtered out orphan modules which
577 -- were not from the home package, justifying it by saying that "we'd
578 -- pick up the ABI hashes of the external module instead". This is wrong.
579 -- Suppose that we have:
580 --
581 -- module External where
582 -- instance Show (a -> b)
583 --
584 -- module Home1 where
585 -- import External
586 --
587 -- module Home2 where
588 -- import Home1
589 --
590 -- The export hash of Home1 needs to reflect the orphan instances of
591 -- External. It's true that Home1 will get rebuilt if the orphans
592 -- of External, but we also need to make sure Home2 gets rebuilt
593 -- as well. See #12733 for more details.
594 let orph_mods
595 = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]
596 $ dep_orphs sorted_deps
597 dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
598
599 -- Note [Do not update EPS with your own hi-boot]
600 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
601 -- (See also Trac #10182). When your hs-boot file includes an orphan
602 -- instance declaration, you may find that the dep_orphs of a module you
603 -- import contains reference to yourself. DO NOT actually load this module
604 -- or add it to the orphan hashes: you're going to provide the orphan
605 -- instances yourself, no need to consult hs-boot; if you do load the
606 -- interface into EPS, you will see a duplicate orphan instance.
607
608 orphan_hash <- computeFingerprint (mk_put_name local_env)
609 (map ifDFun orph_insts, orph_rules, orph_fis)
610
611 -- the export list hash doesn't depend on the fingerprints of
612 -- the Names it mentions, only the Names themselves, hence putNameLiterally.
613 export_hash <- computeFingerprint putNameLiterally
614 (mi_exports iface0,
615 orphan_hash,
616 dep_orphan_hashes,
617 dep_pkgs (mi_deps iface0),
618 -- See Note [Export hash depends on non-orphan family instances]
619 dep_finsts (mi_deps iface0),
620 -- dep_pkgs: see "Package Version Changes" on
621 -- wiki/Commentary/Compiler/RecompilationAvoidance
622 mi_trust iface0)
623 -- Make sure change of Safe Haskell mode causes recomp.
624
625 -- Note [Export hash depends on non-orphan family instances]
626 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
627 --
628 -- Suppose we have:
629 --
630 -- module A where
631 -- type instance F Int = Bool
632 --
633 -- module B where
634 -- import A
635 --
636 -- module C where
637 -- import B
638 --
639 -- The family instance consistency check for C depends on the dep_finsts of
640 -- B. If we rename module A to A2, when the dep_finsts of B changes, we need
641 -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of
642 -- the exports of B, because C always considers them when checking
643 -- consistency.
644 --
645 -- A full discussion is in #12723.
646 --
647 -- We do NOT need to hash dep_orphs, because this is implied by
648 -- dep_orphan_hashes, and we do not need to hash ordinary class instances,
649 -- because there is no eager consistency check as there is with type families
650 -- (also we didn't store it anywhere!)
651 --
652
653 -- put the declarations in a canonical order, sorted by OccName
654 let sorted_decls = Map.elems $ Map.fromList $
655 [(getOccName d, e) | e@(_, d) <- decls_w_hashes]
656
657 -- the flag hash depends on:
658 -- - (some of) dflags
659 -- it returns two hashes, one that shouldn't change
660 -- the abi hash and one that should
661 flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
662
663 -- the ABI hash depends on:
664 -- - decls
665 -- - export list
666 -- - orphans
667 -- - deprecations
668 -- - vect info
669 -- - flag abi hash
670 mod_hash <- computeFingerprint putNameLiterally
671 (map fst sorted_decls,
672 export_hash, -- includes orphan_hash
673 mi_warns iface0,
674 mi_vect_info iface0)
675
676 -- The interface hash depends on:
677 -- - the ABI hash, plus
678 -- - the module level annotations,
679 -- - usages
680 -- - deps (home and external packages, dependent files)
681 -- - hpc
682 iface_hash <- computeFingerprint putNameLiterally
683 (mod_hash,
684 ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache
685 mi_usages iface0,
686 sorted_deps,
687 mi_hpc iface0)
688
689 let
690 no_change_at_all = Just iface_hash == mb_old_fingerprint
691
692 final_iface = iface0 {
693 mi_mod_hash = mod_hash,
694 mi_iface_hash = iface_hash,
695 mi_exp_hash = export_hash,
696 mi_orphan_hash = orphan_hash,
697 mi_flag_hash = flag_hash,
698 mi_orphan = not ( all ifRuleAuto orph_rules
699 -- See Note [Orphans and auto-generated rules]
700 && null orph_insts
701 && null orph_fis
702 && isNoIfaceVectInfo (mi_vect_info iface0)),
703 mi_finsts = not . null $ mi_fam_insts iface0,
704 mi_decls = sorted_decls,
705 mi_hash_fn = lookupOccEnv local_env }
706 --
707 return (final_iface, no_change_at_all)
708
709 where
710 this_mod = mi_module iface0
711 semantic_mod = mi_semantic_module iface0
712 dflags = hsc_dflags hsc_env
713 (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
714 (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
715 (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
716 fix_fn = mi_fix_fn iface0
717 ann_fn = mkIfaceAnnCache (mi_anns iface0)
718
719 -- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules
720 -- (in particular, the orphan modules which are transitively imported by the
721 -- current module).
722 --
723 -- Q: Why do we need the hash at all, doesn't the list of transitively
724 -- imported orphan modules suffice?
725 --
726 -- A: If one of our transitive imports adds a new orphan instance, our
727 -- export hash must change so that modules which import us rebuild. If we just
728 -- hashed the [Module], the hash would not change even when a new instance was
729 -- added to a module that already had an orphan instance.
730 --
731 -- Q: Why don't we just hash the orphan hashes of our direct dependencies?
732 -- Why the full transitive closure?
733 --
734 -- A: Suppose we have these modules:
735 --
736 -- module A where
737 -- instance Show (a -> b) where
738 -- module B where
739 -- import A -- **
740 -- module C where
741 -- import A
742 -- import B
743 --
744 -- Whether or not we add or remove the import to A in B affects the
745 -- orphan hash of B. But it shouldn't really affect the orphan hash
746 -- of C. If we hashed only direct dependencies, there would be no
747 -- way to tell that the net effect was a wash, and we'd be forced
748 -- to recompile C and everything else.
749 getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
750 getOrphanHashes hsc_env mods = do
751 eps <- hscEPS hsc_env
752 let
753 hpt = hsc_HPT hsc_env
754 pit = eps_PIT eps
755 dflags = hsc_dflags hsc_env
756 get_orph_hash mod =
757 case lookupIfaceByModule dflags hpt pit mod of
758 Just iface -> return (mi_orphan_hash iface)
759 Nothing -> do -- similar to 'mkHashFun'
760 iface <- initIfaceLoad hsc_env . withException
761 $ loadInterface (text "getOrphanHashes") mod ImportBySystem
762 return (mi_orphan_hash iface)
763
764 --
765 mapM get_orph_hash mods
766
767
768 sortDependencies :: Dependencies -> Dependencies
769 sortDependencies d
770 = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
771 dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
772 dep_orphs = sortBy stableModuleCmp (dep_orphs d),
773 dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
774
775 -- | Creates cached lookup for the 'mi_anns' field of ModIface
776 -- Hackily, we use "module" as the OccName for any module-level annotations
777 mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
778 mkIfaceAnnCache anns
779 = \n -> lookupOccEnv env n `orElse` []
780 where
781 pair (IfaceAnnotation target value) =
782 (case target of
783 NamedTarget occn -> occn
784 ModuleTarget _ -> mkVarOcc "module"
785 , [value])
786 -- flipping (++), so the first argument is always short
787 env = mkOccEnv_C (flip (++)) (map pair anns)
788
789 {-
790 ************************************************************************
791 * *
792 The ABI of an IfaceDecl
793 * *
794 ************************************************************************
795
796 Note [The ABI of an IfaceDecl]
797 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
798 The ABI of a declaration consists of:
799
800 (a) the full name of the identifier (inc. module and package,
801 because these are used to construct the symbol name by which
802 the identifier is known externally).
803
804 (b) the declaration itself, as exposed to clients. That is, the
805 definition of an Id is included in the fingerprint only if
806 it is made available as an unfolding in the interface.
807
808 (c) the fixity of the identifier (if it exists)
809 (d) for Ids: rules
810 (e) for classes: instances, fixity & rules for methods
811 (f) for datatypes: instances, fixity & rules for constrs
812
813 Items (c)-(f) are not stored in the IfaceDecl, but instead appear
814 elsewhere in the interface file. But they are *fingerprinted* with
815 the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
816 and fingerprinting that as part of the declaration.
817 -}
818
819 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
820
821 data IfaceDeclExtras
822 = IfaceIdExtras IfaceIdExtras
823
824 | IfaceDataExtras
825 (Maybe Fixity) -- Fixity of the tycon itself (if it exists)
826 [IfaceInstABI] -- Local class and family instances of this tycon
827 -- See Note [Orphans] in InstEnv
828 [AnnPayload] -- Annotations of the type itself
829 [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations
830
831 | IfaceClassExtras
832 (Maybe Fixity) -- Fixity of the class itself (if it exists)
833 [IfaceInstABI] -- Local instances of this class *or*
834 -- of its associated data types
835 -- See Note [Orphans] in InstEnv
836 [AnnPayload] -- Annotations of the type itself
837 [IfaceIdExtras] -- For each class method: fixity, RULES and annotations
838
839 | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]
840
841 | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload]
842
843 | IfaceOtherDeclExtras
844
845 data IfaceIdExtras
846 = IdExtras
847 (Maybe Fixity) -- Fixity of the Id (if it exists)
848 [IfaceRule] -- Rules for the Id
849 [AnnPayload] -- Annotations for the Id
850
851 -- When hashing a class or family instance, we hash only the
852 -- DFunId or CoAxiom, because that depends on all the
853 -- information about the instance.
854 --
855 type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance
856
857 abiDecl :: IfaceDeclABI -> IfaceDecl
858 abiDecl (_, decl, _) = decl
859
860 cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
861 cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`
862 getOccName (abiDecl abi2)
863
864 freeNamesDeclABI :: IfaceDeclABI -> NameSet
865 freeNamesDeclABI (_mod, decl, extras) =
866 freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras
867
868 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
869 freeNamesDeclExtras (IfaceIdExtras id_extras)
870 = freeNamesIdExtras id_extras
871 freeNamesDeclExtras (IfaceDataExtras _ insts _ subs)
872 = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
873 freeNamesDeclExtras (IfaceClassExtras _ insts _ subs)
874 = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
875 freeNamesDeclExtras (IfaceSynonymExtras _ _)
876 = emptyNameSet
877 freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
878 = mkNameSet insts
879 freeNamesDeclExtras IfaceOtherDeclExtras
880 = emptyNameSet
881
882 freeNamesIdExtras :: IfaceIdExtras -> NameSet
883 freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)
884
885 instance Outputable IfaceDeclExtras where
886 ppr IfaceOtherDeclExtras = Outputable.empty
887 ppr (IfaceIdExtras extras) = ppr_id_extras extras
888 ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
889 ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
890 ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
891 ppr_id_extras_s stuff]
892 ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
893 ppr_id_extras_s stuff]
894
895 ppr_insts :: [IfaceInstABI] -> SDoc
896 ppr_insts _ = text "<insts>"
897
898 ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
899 ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
900
901 ppr_id_extras :: IfaceIdExtras -> SDoc
902 ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
903
904 -- This instance is used only to compute fingerprints
905 instance Binary IfaceDeclExtras where
906 get _bh = panic "no get for IfaceDeclExtras"
907 put_ bh (IfaceIdExtras extras) = do
908 putByte bh 1; put_ bh extras
909 put_ bh (IfaceDataExtras fix insts anns cons) = do
910 putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
911 put_ bh (IfaceClassExtras fix insts anns methods) = do
912 putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods
913 put_ bh (IfaceSynonymExtras fix anns) = do
914 putByte bh 4; put_ bh fix; put_ bh anns
915 put_ bh (IfaceFamilyExtras fix finsts anns) = do
916 putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
917 put_ bh IfaceOtherDeclExtras = putByte bh 6
918
919 instance Binary IfaceIdExtras where
920 get _bh = panic "no get for IfaceIdExtras"
921 put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
922
923 declExtras :: (OccName -> Maybe Fixity)
924 -> (OccName -> [AnnPayload])
925 -> OccEnv [IfaceRule]
926 -> OccEnv [IfaceClsInst]
927 -> OccEnv [IfaceFamInst]
928 -> IfaceDecl
929 -> IfaceDeclExtras
930
931 declExtras fix_fn ann_fn rule_env inst_env fi_env decl
932 = case decl of
933 IfaceId{} -> IfaceIdExtras (id_extras n)
934 IfaceData{ifCons=cons} ->
935 IfaceDataExtras (fix_fn n)
936 (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
937 map ifDFun (lookupOccEnvL inst_env n))
938 (ann_fn n)
939 (map (id_extras . occName . ifConName) (visibleIfConDecls cons))
940 IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
941 IfaceClassExtras (fix_fn n)
942 (map ifDFun $ (concatMap at_extras ats)
943 ++ lookupOccEnvL inst_env n)
944 -- Include instances of the associated types
945 -- as well as instances of the class (Trac #5147)
946 (ann_fn n)
947 [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
948 IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
949 (ann_fn n)
950 IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
951 (map ifFamInstAxiom (lookupOccEnvL fi_env n))
952 (ann_fn n)
953 _other -> IfaceOtherDeclExtras
954 where
955 n = getOccName decl
956 id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
957 at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)
958
959
960 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
961 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
962
963 {-
964 -- for testing: use the md5sum command to generate fingerprints and
965 -- compare the results against our built-in version.
966 fp' <- oldMD5 dflags bh
967 if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
968 else return fp
969
970 oldMD5 dflags bh = do
971 tmp <- newTempName dflags "bin"
972 writeBinMem bh tmp
973 tmp2 <- newTempName dflags "md5"
974 let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
975 r <- system cmd
976 case r of
977 ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
978 ExitSuccess -> do
979 hash_str <- readFile tmp2
980 return $! readHexFingerprint hash_str
981 -}
982
983 ----------------------
984 -- mkOrphMap partitions instance decls or rules into
985 -- (a) an OccEnv for ones that are not orphans,
986 -- mapping the local OccName to a list of its decls
987 -- (b) a list of orphan decls
988 mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
989 -> [decl] -- Sorted into canonical order
990 -> (OccEnv [decl], -- Non-orphan decls associated with their key;
991 -- each sublist in canonical order
992 [decl]) -- Orphan decls; in canonical order
993 mkOrphMap get_key decls
994 = foldl go (emptyOccEnv, []) decls
995 where
996 go (non_orphs, orphs) d
997 | NotOrphan occ <- get_key d
998 = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
999 | otherwise = (non_orphs, d:orphs)
1000
1001 {-
1002 ************************************************************************
1003 * *
1004 COMPLETE Pragmas
1005 * *
1006 ************************************************************************
1007 -}
1008
1009 mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
1010 mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
1011
1012
1013 {-
1014 ************************************************************************
1015 * *
1016 Keeping track of what we've slurped, and fingerprints
1017 * *
1018 ************************************************************************
1019 -}
1020
1021
1022 mkIfaceAnnotation :: Annotation -> IfaceAnnotation
1023 mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
1024 = IfaceAnnotation {
1025 ifAnnotatedTarget = fmap nameOccName target,
1026 ifAnnotatedValue = payload
1027 }
1028
1029 mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical
1030 mkIfaceExports exports
1031 = sortBy stableAvailCmp (map sort_subs exports)
1032 where
1033 sort_subs :: AvailInfo -> AvailInfo
1034 sort_subs (Avail n) = Avail n
1035 sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
1036 sort_subs (AvailTC n (m:ms) fs)
1037 | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
1038 | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
1039 -- Maintain the AvailTC Invariant
1040
1041 sort_flds = sortBy (stableNameCmp `on` flSelector)
1042
1043 {-
1044 Note [Original module]
1045 ~~~~~~~~~~~~~~~~~~~~~
1046 Consider this:
1047 module X where { data family T }
1048 module Y( T(..) ) where { import X; data instance T Int = MkT Int }
1049 The exported Avail from Y will look like
1050 X.T{X.T, Y.MkT}
1051 That is, in Y,
1052 - only MkT is brought into scope by the data instance;
1053 - but the parent (used for grouping and naming in T(..) exports) is X.T
1054 - and in this case we export X.T too
1055
1056 In the result of MkIfaceExports, the names are grouped by defining module,
1057 so we may need to split up a single Avail into multiple ones.
1058
1059 Note [Internal used_names]
1060 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1061 Most of the used_names are External Names, but we can have Internal
1062 Names too: see Note [Binders in Template Haskell] in Convert, and
1063 Trac #5362 for an example. Such Names are always
1064 - Such Names are always for locally-defined things, for which we
1065 don't gather usage info, so we can just ignore them in ent_map
1066 - They are always System Names, hence the assert, just as a double check.
1067
1068
1069 ************************************************************************
1070 * *
1071 Load the old interface file for this module (unless
1072 we have it already), and check whether it is up to date
1073 * *
1074 ************************************************************************
1075 -}
1076
1077 data RecompileRequired
1078 = UpToDate
1079 -- ^ everything is up to date, recompilation is not required
1080 | MustCompile
1081 -- ^ The .hs file has been touched, or the .o/.hi file does not exist
1082 | RecompBecause String
1083 -- ^ The .o/.hi files are up to date, but something else has changed
1084 -- to force recompilation; the String says what (one-line summary)
1085 deriving Eq
1086
1087 recompileRequired :: RecompileRequired -> Bool
1088 recompileRequired UpToDate = False
1089 recompileRequired _ = True
1090
1091
1092
1093 -- | Top level function to check if the version of an old interface file
1094 -- is equivalent to the current source file the user asked us to compile.
1095 -- If the same, we can avoid recompilation. We return a tuple where the
1096 -- first element is a bool saying if we should recompile the object file
1097 -- and the second is maybe the interface file, where Nothng means to
1098 -- rebuild the interface file not use the exisitng one.
1099 checkOldIface
1100 :: HscEnv
1101 -> ModSummary
1102 -> SourceModified
1103 -> Maybe ModIface -- Old interface from compilation manager, if any
1104 -> IO (RecompileRequired, Maybe ModIface)
1105
1106 checkOldIface hsc_env mod_summary source_modified maybe_iface
1107 = do let dflags = hsc_dflags hsc_env
1108 showPass dflags $
1109 "Checking old interface for " ++
1110 (showPpr dflags $ ms_mod mod_summary) ++
1111 " (use -ddump-hi-diffs for more details)"
1112 initIfaceCheck (text "checkOldIface") hsc_env $
1113 check_old_iface hsc_env mod_summary source_modified maybe_iface
1114
1115 check_old_iface
1116 :: HscEnv
1117 -> ModSummary
1118 -> SourceModified
1119 -> Maybe ModIface
1120 -> IfG (RecompileRequired, Maybe ModIface)
1121
1122 check_old_iface hsc_env mod_summary src_modified maybe_iface
1123 = let dflags = hsc_dflags hsc_env
1124 getIface =
1125 case maybe_iface of
1126 Just _ -> do
1127 traceIf (text "We already have the old interface for" <+>
1128 ppr (ms_mod mod_summary))
1129 return maybe_iface
1130 Nothing -> loadIface
1131
1132 loadIface = do
1133 let iface_path = msHiFilePath mod_summary
1134 read_result <- readIface (ms_mod mod_summary) iface_path
1135 case read_result of
1136 Failed err -> do
1137 traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
1138 traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)
1139 return Nothing
1140 Succeeded iface -> do
1141 traceIf (text "Read the interface file" <+> text iface_path)
1142 return $ Just iface
1143
1144 src_changed
1145 | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
1146 | SourceModified <- src_modified = True
1147 | otherwise = False
1148 in do
1149 when src_changed $
1150 traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
1151
1152 case src_changed of
1153 -- If the source has changed and we're in interactive mode,
1154 -- avoid reading an interface; just return the one we might
1155 -- have been supplied with.
1156 True | not (isObjectTarget $ hscTarget dflags) ->
1157 return (MustCompile, maybe_iface)
1158
1159 -- Try and read the old interface for the current module
1160 -- from the .hi file left from the last time we compiled it
1161 True -> do
1162 maybe_iface' <- getIface
1163 return (MustCompile, maybe_iface')
1164
1165 False -> do
1166 maybe_iface' <- getIface
1167 case maybe_iface' of
1168 -- We can't retrieve the iface
1169 Nothing -> return (MustCompile, Nothing)
1170
1171 -- We have got the old iface; check its versions
1172 -- even in the SourceUnmodifiedAndStable case we
1173 -- should check versions because some packages
1174 -- might have changed or gone away.
1175 Just iface -> checkVersions hsc_env mod_summary iface
1176
1177 -- | Check if a module is still the same 'version'.
1178 --
1179 -- This function is called in the recompilation checker after we have
1180 -- determined that the module M being checked hasn't had any changes
1181 -- to its source file since we last compiled M. So at this point in general
1182 -- two things may have changed that mean we should recompile M:
1183 -- * The interface export by a dependency of M has changed.
1184 -- * The compiler flags specified this time for M have changed
1185 -- in a manner that is significant for recompilation.
1186 -- We return not just if we should recompile the object file but also
1187 -- if we should rebuild the interface file.
1188 checkVersions :: HscEnv
1189 -> ModSummary
1190 -> ModIface -- Old interface
1191 -> IfG (RecompileRequired, Maybe ModIface)
1192 checkVersions hsc_env mod_summary iface
1193 = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
1194 ppr (mi_module iface) <> colon)
1195
1196 -- readIface will have verified that the InstalledUnitId matches,
1197 -- but we ALSO must make sure the instantiation matches up. See
1198 -- test case bkpcabal04!
1199 ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)
1200 then return (RecompBecause "-this-unit-id changed", Nothing) else do {
1201 ; recomp <- checkFlagHash hsc_env iface
1202 ; if recompileRequired recomp then return (recomp, Nothing) else do {
1203 ; recomp <- checkMergedSignatures mod_summary iface
1204 ; if recompileRequired recomp then return (recomp, Nothing) else do {
1205 ; recomp <- checkHsig mod_summary iface
1206 ; if recompileRequired recomp then return (recomp, Nothing) else do {
1207 ; recomp <- checkDependencies hsc_env mod_summary iface
1208 ; if recompileRequired recomp then return (recomp, Just iface) else do {
1209
1210 -- Source code unchanged and no errors yet... carry on
1211 --
1212 -- First put the dependent-module info, read from the old
1213 -- interface, into the envt, so that when we look for
1214 -- interfaces we look for the right one (.hi or .hi-boot)
1215 --
1216 -- It's just temporary because either the usage check will succeed
1217 -- (in which case we are done with this module) or it'll fail (in which
1218 -- case we'll compile the module from scratch anyhow).
1219 --
1220 -- We do this regardless of compilation mode, although in --make mode
1221 -- all the dependent modules should be in the HPT already, so it's
1222 -- quite redundant
1223 ; updateEps_ $ \eps -> eps { eps_is_boot = udfmToUfm mod_deps }
1224 ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1225 ; return (recomp, Just iface)
1226 }}}}}}
1227 where
1228 this_pkg = thisPackage (hsc_dflags hsc_env)
1229 -- This is a bit of a hack really
1230 mod_deps :: DModuleNameEnv (ModuleName, IsBootInterface)
1231 mod_deps = mkModDeps (dep_mods (mi_deps iface))
1232
1233 -- | Check if an hsig file needs recompilation because its
1234 -- implementing module has changed.
1235 checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
1236 checkHsig mod_summary iface = do
1237 dflags <- getDynFlags
1238 let outer_mod = ms_mod mod_summary
1239 inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
1240 MASSERT( moduleUnitId outer_mod == thisPackage dflags )
1241 case inner_mod == mi_semantic_module iface of
1242 True -> up_to_date (text "implementing module unchanged")
1243 False -> return (RecompBecause "implementing module changed")
1244
1245 -- | Check the flags haven't changed
1246 checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
1247 checkFlagHash hsc_env iface = do
1248 let old_hash = mi_flag_hash iface
1249 new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
1250 (mi_module iface)
1251 putNameLiterally
1252 case old_hash == new_hash of
1253 True -> up_to_date (text "Module flags unchanged")
1254 False -> out_of_date_hash "flags changed"
1255 (text " Module flags have changed")
1256 old_hash new_hash
1257
1258 -- Check that the set of signatures we are merging in match.
1259 -- If the -unit-id flags change, this can change too.
1260 checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
1261 checkMergedSignatures mod_summary iface = do
1262 dflags <- getDynFlags
1263 let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
1264 new_merged = case Map.lookup (ms_mod_name mod_summary)
1265 (requirementContext (pkgState dflags)) of
1266 Nothing -> []
1267 Just r -> sort $ map (indefModuleToModule dflags) r
1268 if old_merged == new_merged
1269 then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)
1270 else return (RecompBecause "signatures to merge in changed")
1271
1272 -- If the direct imports of this module are resolved to targets that
1273 -- are not among the dependencies of the previous interface file,
1274 -- then we definitely need to recompile. This catches cases like
1275 -- - an exposed package has been upgraded
1276 -- - we are compiling with different package flags
1277 -- - a home module that was shadowing a package module has been removed
1278 -- - a new home module has been added that shadows a package module
1279 -- See bug #1372.
1280 --
1281 -- Returns (RecompBecause <textual reason>) if recompilation is required.
1282 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1283 checkDependencies hsc_env summary iface
1284 = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1285 where
1286 prev_dep_mods = dep_mods (mi_deps iface)
1287 prev_dep_pkgs = dep_pkgs (mi_deps iface)
1288
1289 this_pkg = thisPackage (hsc_dflags hsc_env)
1290
1291 dep_missing (mb_pkg, L _ mod) = do
1292 find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
1293 let reason = moduleNameString mod ++ " changed"
1294 case find_res of
1295 Found _ mod
1296 | pkg == this_pkg
1297 -> if moduleName mod `notElem` map fst prev_dep_mods
1298 then do traceHiDiffs $
1299 text "imported module " <> quotes (ppr mod) <>
1300 text " not among previous dependencies"
1301 return (RecompBecause reason)
1302 else
1303 return UpToDate
1304 | otherwise
1305 -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)
1306 then do traceHiDiffs $
1307 text "imported module " <> quotes (ppr mod) <>
1308 text " is from package " <> quotes (ppr pkg) <>
1309 text ", which is not among previous dependencies"
1310 return (RecompBecause reason)
1311 else
1312 return UpToDate
1313 where pkg = moduleUnitId mod
1314 _otherwise -> return (RecompBecause reason)
1315
1316 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1317 -> IfG RecompileRequired
1318 needInterface mod continue
1319 = do -- Load the imported interface if possible
1320 let doc_str = sep [text "need version info for", ppr mod]
1321 traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1322
1323 mb_iface <- loadInterface doc_str mod ImportBySystem
1324 -- Load the interface, but don't complain on failure;
1325 -- Instead, get an Either back which we can test
1326
1327 case mb_iface of
1328 Failed _ -> do
1329 traceHiDiffs (sep [text "Couldn't load interface for module",
1330 ppr mod])
1331 return MustCompile
1332 -- Couldn't find or parse a module mentioned in the
1333 -- old interface file. Don't complain: it might
1334 -- just be that the current module doesn't need that
1335 -- import and it's been deleted
1336 Succeeded iface -> continue iface
1337
1338 -- | Given the usage information extracted from the old
1339 -- M.hi file for the module being compiled, figure out
1340 -- whether M needs to be recompiled.
1341 checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
1342 checkModUsage _this_pkg UsagePackageModule{
1343 usg_mod = mod,
1344 usg_mod_hash = old_mod_hash }
1345 = needInterface mod $ \iface -> do
1346 let reason = moduleNameString (moduleName mod) ++ " changed"
1347 checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
1348 -- We only track the ABI hash of package modules, rather than
1349 -- individual entity usages, so if the ABI hash changes we must
1350 -- recompile. This is safe but may entail more recompilation when
1351 -- a dependent package has changed.
1352
1353 checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }
1354 = needInterface mod $ \iface -> do
1355 let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
1356 checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
1357
1358 checkModUsage this_pkg UsageHomeModule{
1359 usg_mod_name = mod_name,
1360 usg_mod_hash = old_mod_hash,
1361 usg_exports = maybe_old_export_hash,
1362 usg_entities = old_decl_hash }
1363 = do
1364 let mod = mkModule this_pkg mod_name
1365 needInterface mod $ \iface -> do
1366
1367 let
1368 new_mod_hash = mi_mod_hash iface
1369 new_decl_hash = mi_hash_fn iface
1370 new_export_hash = mi_exp_hash iface
1371
1372 reason = moduleNameString mod_name ++ " changed"
1373
1374 -- CHECK MODULE
1375 recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
1376 if not (recompileRequired recompile)
1377 then return UpToDate
1378 else do
1379
1380 -- CHECK EXPORT LIST
1381 checkMaybeHash reason maybe_old_export_hash new_export_hash
1382 (text " Export list changed") $ do
1383
1384 -- CHECK ITEMS ONE BY ONE
1385 recompile <- checkList [ checkEntityUsage reason new_decl_hash u
1386 | u <- old_decl_hash]
1387 if recompileRequired recompile
1388 then return recompile -- This one failed, so just bail out now
1389 else up_to_date (text " Great! The bits I use are up to date")
1390
1391
1392 checkModUsage _this_pkg UsageFile{ usg_file_path = file,
1393 usg_file_hash = old_hash } =
1394 liftIO $
1395 handleIO handle $ do
1396 new_hash <- getFileHash file
1397 if (old_hash /= new_hash)
1398 then return recomp
1399 else return UpToDate
1400 where
1401 recomp = RecompBecause (file ++ " changed")
1402 handle =
1403 #ifdef DEBUG
1404 \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
1405 #else
1406 \_ -> return recomp -- if we can't find the file, just recompile, don't fail
1407 #endif
1408
1409 ------------------------
1410 checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
1411 -> IfG RecompileRequired
1412 checkModuleFingerprint reason old_mod_hash new_mod_hash
1413 | new_mod_hash == old_mod_hash
1414 = up_to_date (text "Module fingerprint unchanged")
1415
1416 | otherwise
1417 = out_of_date_hash reason (text " Module fingerprint has changed")
1418 old_mod_hash new_mod_hash
1419
1420 ------------------------
1421 checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
1422 -> IfG RecompileRequired -> IfG RecompileRequired
1423 checkMaybeHash reason maybe_old_hash new_hash doc continue
1424 | Just hash <- maybe_old_hash, hash /= new_hash
1425 = out_of_date_hash reason doc hash new_hash
1426 | otherwise
1427 = continue
1428
1429 ------------------------
1430 checkEntityUsage :: String
1431 -> (OccName -> Maybe (OccName, Fingerprint))
1432 -> (OccName, Fingerprint)
1433 -> IfG RecompileRequired
1434 checkEntityUsage reason new_hash (name,old_hash)
1435 = case new_hash name of
1436
1437 Nothing -> -- We used it before, but it ain't there now
1438 out_of_date reason (sep [text "No longer exported:", ppr name])
1439
1440 Just (_, new_hash) -- It's there, but is it up to date?
1441 | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
1442 return UpToDate
1443 | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name)
1444 old_hash new_hash
1445
1446 up_to_date :: SDoc -> IfG RecompileRequired
1447 up_to_date msg = traceHiDiffs msg >> return UpToDate
1448
1449 out_of_date :: String -> SDoc -> IfG RecompileRequired
1450 out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
1451
1452 out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
1453 out_of_date_hash reason msg old_hash new_hash
1454 = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
1455
1456 ----------------------
1457 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1458 -- This helper is used in two places
1459 checkList [] = return UpToDate
1460 checkList (check:checks) = do recompile <- check
1461 if recompileRequired recompile
1462 then return recompile
1463 else checkList checks
1464
1465 {-
1466 ************************************************************************
1467 * *
1468 Converting things to their Iface equivalents
1469 * *
1470 ************************************************************************
1471 -}
1472
1473 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1474 tyThingToIfaceDecl (AnId id) = idToIfaceDecl id
1475 tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
1476 tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax
1477 tyThingToIfaceDecl (AConLike cl) = case cl of
1478 RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
1479 PatSynCon ps -> patSynToIfaceDecl ps
1480
1481 --------------------------
1482 idToIfaceDecl :: Id -> IfaceDecl
1483 -- The Id is already tidied, so that locally-bound names
1484 -- (lambdas, for-alls) already have non-clashing OccNames
1485 -- We can't tidy it here, locally, because it may have
1486 -- free variables in its type or IdInfo
1487 idToIfaceDecl id
1488 = IfaceId { ifName = getName id,
1489 ifType = toIfaceType (idType id),
1490 ifIdDetails = toIfaceIdDetails (idDetails id),
1491 ifIdInfo = toIfaceIdInfo (idInfo id) }
1492
1493 --------------------------
1494 dataConToIfaceDecl :: DataCon -> IfaceDecl
1495 dataConToIfaceDecl dataCon
1496 = IfaceId { ifName = getName dataCon,
1497 ifType = toIfaceType (dataConUserType dataCon),
1498 ifIdDetails = IfVanillaId,
1499 ifIdInfo = NoInfo }
1500
1501 --------------------------
1502 coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
1503 -- We *do* tidy Axioms, because they are not (and cannot
1504 -- conveniently be) built in tidy form
1505 coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
1506 , co_ax_role = role })
1507 = IfaceAxiom { ifName = getName ax
1508 , ifTyCon = toIfaceTyCon tycon
1509 , ifRole = role
1510 , ifAxBranches = map (coAxBranchToIfaceBranch tycon
1511 (map coAxBranchLHS branch_list))
1512 branch_list }
1513 where
1514 branch_list = fromBranches branches
1515
1516 -- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
1517 -- to incompatible indices
1518 -- See Note [Storing compatibility] in CoAxiom
1519 coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
1520 coAxBranchToIfaceBranch tc lhs_s
1521 branch@(CoAxBranch { cab_incomps = incomps })
1522 = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
1523 where
1524 iface_incomps = map (expectJust "iface_incomps"
1525 . (flip findIndex lhs_s
1526 . eqTypes)
1527 . coAxBranchLHS) incomps
1528
1529 -- use this one for standalone branches without incompatibles
1530 coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
1531 coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
1532 , cab_lhs = lhs
1533 , cab_roles = roles, cab_rhs = rhs })
1534 = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tidy_tvs
1535 , ifaxbCoVars = map toIfaceIdBndr cvs
1536 , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
1537 , ifaxbRoles = roles
1538 , ifaxbRHS = tidyToIfaceType env1 rhs
1539 , ifaxbIncomps = [] }
1540 where
1541 (env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs
1542 -- Don't re-bind in-scope tyvars
1543 -- See Note [CoAxBranch type variables] in CoAxiom
1544
1545 -----------------
1546 tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
1547 -- We *do* tidy TyCons, because they are not (and cannot
1548 -- conveniently be) built in tidy form
1549 -- The returned TidyEnv is the one after tidying the tyConTyVars
1550 tyConToIfaceDecl env tycon
1551 | Just clas <- tyConClass_maybe tycon
1552 = classToIfaceDecl env clas
1553
1554 | Just syn_rhs <- synTyConRhs_maybe tycon
1555 = ( tc_env1
1556 , IfaceSynonym { ifName = getName tycon,
1557 ifRoles = tyConRoles tycon,
1558 ifSynRhs = if_syn_type syn_rhs,
1559 ifBinders = if_binders,
1560 ifResKind = if_res_kind
1561 })
1562
1563 | Just fam_flav <- famTyConFlav_maybe tycon
1564 = ( tc_env1
1565 , IfaceFamily { ifName = getName tycon,
1566 ifResVar = if_res_var,
1567 ifFamFlav = to_if_fam_flav fam_flav,
1568 ifBinders = if_binders,
1569 ifResKind = if_res_kind,
1570 ifFamInj = familyTyConInjectivityInfo tycon
1571 })
1572
1573 | isAlgTyCon tycon
1574 = ( tc_env1
1575 , IfaceData { ifName = getName tycon,
1576 ifBinders = if_binders,
1577 ifResKind = if_res_kind,
1578 ifCType = tyConCType tycon,
1579 ifRoles = tyConRoles tycon,
1580 ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
1581 ifCons = ifaceConDecls (algTyConRhs tycon),
1582 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1583 ifParent = parent })
1584
1585 | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
1586 -- We only convert these TyCons to IfaceTyCons when we are
1587 -- just about to pretty-print them, not because we are going
1588 -- to put them into interface files
1589 = ( env
1590 , IfaceData { ifName = getName tycon,
1591 ifBinders = if_binders,
1592 ifResKind = if_res_kind,
1593 ifCType = Nothing,
1594 ifRoles = tyConRoles tycon,
1595 ifCtxt = [],
1596 ifCons = IfDataTyCon [],
1597 ifGadtSyntax = False,
1598 ifParent = IfNoParent })
1599 where
1600 -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`
1601 -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
1602 -- an error.
1603 (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
1604 tc_tyvars = binderVars tc_binders
1605 if_binders = toIfaceTyVarBinders tc_binders
1606 if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
1607 if_syn_type ty = tidyToIfaceType tc_env1 ty
1608 if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon
1609
1610 parent = case tyConFamInstSig_maybe tycon of
1611 Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
1612 (toIfaceTyCon tc)
1613 (tidyToIfaceTcArgs tc_env1 tc ty)
1614 Nothing -> IfNoParent
1615
1616 to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
1617 to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
1618 = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
1619 where defs = fromBranches $ coAxiomBranches ax
1620 ibr = map (coAxBranchToIfaceBranch' tycon) defs
1621 axn = coAxiomName ax
1622 to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
1623 = IfaceClosedSynFamilyTyCon Nothing
1624 to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
1625 to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
1626 to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
1627
1628
1629
1630 ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
1631 ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
1632 ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con]
1633 ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
1634 ifaceConDecls AbstractTyCon = IfAbstractTyCon
1635 -- The AbstractTyCon case happens when a TyCon has been trimmed
1636 -- during tidying.
1637 -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
1638 -- for GHCi, when browsing a module, in which case the
1639 -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
1640 -- (Tuple declarations are not serialised into interface files.)
1641
1642 ifaceConDecl data_con
1643 = IfCon { ifConName = dataConName data_con,
1644 ifConInfix = dataConIsInfix data_con,
1645 ifConWrapper = isJust (dataConWrapId_maybe data_con),
1646 ifConExTvs = map toIfaceForAllBndr ex_bndrs',
1647 ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
1648 ifConCtxt = tidyToIfaceContext con_env2 theta,
1649 ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
1650 ifConFields = dataConFieldLabels data_con,
1651 ifConStricts = map (toIfaceBang con_env2)
1652 (dataConImplBangs data_con),
1653 ifConSrcStricts = map toIfaceSrcBang
1654 (dataConSrcBangs data_con)}
1655 where
1656 (univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _)
1657 = dataConFullSig data_con
1658 ex_bndrs = dataConExTyVarBinders data_con
1659
1660 -- Tidy the univ_tvs of the data constructor to be identical
1661 -- to the tyConTyVars of the type constructor. This means
1662 -- (a) we don't need to redundantly put them into the interface file
1663 -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
1664 -- we know that the type variables will line up
1665 -- The latter (b) is important because we pretty-print type constructors
1666 -- by converting to IfaceSyn and pretty-printing that
1667 con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
1668 -- A bit grimy, perhaps, but it's simple!
1669
1670 (con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs
1671 to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
1672
1673 classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
1674 classToIfaceDecl env clas
1675 = ( env1
1676 , IfaceClass { ifName = getName tycon,
1677 ifRoles = tyConRoles (classTyCon clas),
1678 ifBinders = toIfaceTyVarBinders tc_binders,
1679 ifBody = body,
1680 ifFDs = map toIfaceFD clas_fds })
1681 where
1682 (_, clas_fds, sc_theta, _, clas_ats, op_stuff)
1683 = classExtraBigSig clas
1684 tycon = classTyCon clas
1685
1686 body | isAbstractTyCon tycon = IfAbstractClass
1687 | otherwise
1688 = IfConcreteClass {
1689 ifClassCtxt = tidyToIfaceContext env1 sc_theta,
1690 ifATs = map toIfaceAT clas_ats,
1691 ifSigs = map toIfaceClassOp op_stuff,
1692 ifMinDef = fmap getOccFS (classMinimalDef clas)
1693 }
1694
1695 (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
1696
1697 toIfaceAT :: ClassATItem -> IfaceAT
1698 toIfaceAT (ATI tc def)
1699 = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
1700 where
1701 (env2, if_decl) = tyConToIfaceDecl env1 tc
1702
1703 toIfaceClassOp (sel_id, def_meth)
1704 = ASSERT( sel_tyvars == binderVars tc_binders )
1705 IfaceClassOp (getName sel_id)
1706 (tidyToIfaceType env1 op_ty)
1707 (fmap toDmSpec def_meth)
1708 where
1709 -- Be careful when splitting the type, because of things
1710 -- like class Foo a where
1711 -- op :: (?x :: String) => a -> a
1712 -- and class Baz a where
1713 -- op :: (Ord a) => a -> a
1714 (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1715 op_ty = funResultTy rho_ty
1716
1717 toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
1718 toDmSpec (_, VanillaDM) = VanillaDM
1719 toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
1720
1721 toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1
1722 ,map (tidyTyVar env1) tvs2)
1723
1724 --------------------------
1725
1726 tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
1727 -- If the type variable "binder" is in scope, don't re-bind it
1728 -- In a class decl, for example, the ATD binders mention
1729 -- (amd must mention) the class tyvars
1730 tidyTyConBinder env@(_, subst) tvb@(TvBndr tv vis)
1731 = case lookupVarEnv subst tv of
1732 Just tv' -> (env, TvBndr tv' vis)
1733 Nothing -> tidyTyVarBinder env tvb
1734
1735 tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
1736 tidyTyConBinders = mapAccumL tidyTyConBinder
1737
1738 tidyTyVar :: TidyEnv -> TyVar -> FastString
1739 tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
1740
1741 --------------------------
1742 instanceToIfaceInst :: ClsInst -> IfaceClsInst
1743 instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
1744 , is_cls_nm = cls_name, is_cls = cls
1745 , is_tcs = mb_tcs
1746 , is_orphan = orph })
1747 = ASSERT( cls_name == className cls )
1748 IfaceClsInst { ifDFun = dfun_name,
1749 ifOFlag = oflag,
1750 ifInstCls = cls_name,
1751 ifInstTys = map do_rough mb_tcs,
1752 ifInstOrph = orph }
1753 where
1754 do_rough Nothing = Nothing
1755 do_rough (Just n) = Just (toIfaceTyCon_name n)
1756
1757 dfun_name = idName dfun_id
1758
1759
1760 --------------------------
1761 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1762 famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
1763 fi_fam = fam,
1764 fi_tcs = roughs })
1765 = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
1766 , ifFamInstFam = fam
1767 , ifFamInstTys = map do_rough roughs
1768 , ifFamInstOrph = orph }
1769 where
1770 do_rough Nothing = Nothing
1771 do_rough (Just n) = Just (toIfaceTyCon_name n)
1772
1773 fam_decl = tyConName $ coAxiomTyCon axiom
1774 mod = ASSERT( isExternalName (coAxiomName axiom) )
1775 nameModule (coAxiomName axiom)
1776 is_local name = nameIsLocalOrFrom mod name
1777
1778 lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
1779
1780 orph | is_local fam_decl
1781 = NotOrphan (nameOccName fam_decl)
1782 | otherwise
1783 = chooseOrphanAnchor lhs_names
1784
1785 --------------------------
1786 coreRuleToIfaceRule :: CoreRule -> IfaceRule
1787 coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
1788 = pprTrace "toHsRule: builtin" (ppr fn) $
1789 bogusIfaceRule fn
1790
1791 coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
1792 ru_act = act, ru_bndrs = bndrs,
1793 ru_args = args, ru_rhs = rhs,
1794 ru_orphan = orph, ru_auto = auto })
1795 = IfaceRule { ifRuleName = name, ifActivation = act,
1796 ifRuleBndrs = map toIfaceBndr bndrs,
1797 ifRuleHead = fn,
1798 ifRuleArgs = map do_arg args,
1799 ifRuleRhs = toIfaceExpr rhs,
1800 ifRuleAuto = auto,
1801 ifRuleOrph = orph }
1802 where
1803 -- For type args we must remove synonyms from the outermost
1804 -- level. Reason: so that when we read it back in we'll
1805 -- construct the same ru_rough field as we have right now;
1806 -- see tcIfaceRule
1807 do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1808 do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
1809 do_arg arg = toIfaceExpr arg
1810
1811 bogusIfaceRule :: Name -> IfaceRule
1812 bogusIfaceRule id_name
1813 = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
1814 ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
1815 ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
1816 ifRuleAuto = True }