df96f6a4af47ee1eb9cd7c2ae09c50101db95467
[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 mkUsedNames,
13 mkDependencies,
14 mkIface, -- Build a ModIface from a ModGuts,
15 -- including computing version information
16
17 mkIfaceTc,
18 mkIfaceDirect,
19
20 writeIfaceFile, -- Write the interface file
21
22 checkOldIface, -- See if recompilation is required, by
23 -- comparing version information
24 RecompileRequired(..), recompileRequired,
25
26 tyThingToIfaceDecl -- Converting things to their Iface equivalents
27 ) where
28
29 {-
30 -----------------------------------------------
31 Recompilation checking
32 -----------------------------------------------
33
34 A complete description of how recompilation checking works can be
35 found in the wiki commentary:
36
37 http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
38
39 Please read the above page for a top-down description of how this all
40 works. Notes below cover specific issues related to the implementation.
41
42 Basic idea:
43
44 * In the mi_usages information in an interface, we record the
45 fingerprint of each free variable of the module
46
47 * In mkIface, we compute the fingerprint of each exported thing A.f.
48 For each external thing that A.f refers to, we include the fingerprint
49 of the external reference when computing the fingerprint of A.f. So
50 if anything that A.f depends on changes, then A.f's fingerprint will
51 change.
52 Also record any dependent files added with
53 * addDependentFile
54 * #include
55 * -optP-include
56
57 * In checkOldIface we compare the mi_usages for the module with
58 the actual fingerprint for all each thing recorded in mi_usages
59 -}
60
61 #include "HsVersions.h"
62
63 import IfaceSyn
64 import LoadIface
65 import FlagChecker
66
67 import Id
68 import IdInfo
69 import Demand
70 import Coercion( tidyCo )
71 import Annotations
72 import CoreSyn
73 import Class
74 import Kind
75 import TyCon
76 import CoAxiom
77 import ConLike
78 import DataCon
79 import PatSyn
80 import Type
81 import TcType
82 import TysPrim ( alphaTyVars )
83 import InstEnv
84 import FamInstEnv
85 import TcRnMonad
86 import HsSyn
87 import HscTypes
88 import Finder
89 import DynFlags
90 import VarEnv
91 import VarSet
92 import Var
93 import Name
94 import Avail
95 import RdrName
96 import NameEnv
97 import NameSet
98 import Module
99 import BinIface
100 import ErrUtils
101 import Digraph
102 import SrcLoc
103 import Outputable
104 import BasicTypes hiding ( SuccessFlag(..) )
105 import UniqFM
106 import Unique
107 import Util hiding ( eqListBy )
108 import FastString
109 import FastStringEnv
110 import Maybes
111 import ListSetOps
112 import Binary
113 import Fingerprint
114 import Exception
115
116 import Control.Monad
117 import Data.Function
118 import Data.List
119 import Data.Map (Map)
120 import qualified Data.Map as Map
121 import Data.Ord
122 import Data.IORef
123 import System.Directory
124 import System.FilePath
125
126 {-
127 ************************************************************************
128 * *
129 \subsection{Completing an interface}
130 * *
131 ************************************************************************
132 -}
133
134 mkIface :: HscEnv
135 -> Maybe Fingerprint -- The old fingerprint, if we have it
136 -> ModDetails -- The trimmed, tidied interface
137 -> ModGuts -- Usages, deprecations, etc
138 -> IO (ModIface, -- The new one
139 Bool) -- True <=> there was an old Iface, and the
140 -- new one is identical, so no need
141 -- to write it
142
143 mkIface hsc_env maybe_old_fingerprint mod_details
144 ModGuts{ mg_module = this_mod,
145 mg_hsc_src = hsc_src,
146 mg_used_names = used_names,
147 mg_used_th = used_th,
148 mg_deps = deps,
149 mg_dir_imps = dir_imp_mods,
150 mg_rdr_env = rdr_env,
151 mg_fix_env = fix_env,
152 mg_warns = warns,
153 mg_hpc_info = hpc_info,
154 mg_safe_haskell = safe_mode,
155 mg_trust_pkg = self_trust,
156 mg_dependent_files = dependent_files
157 }
158 = mkIface_ hsc_env maybe_old_fingerprint
159 this_mod hsc_src used_names used_th deps rdr_env fix_env
160 warns hpc_info dir_imp_mods self_trust dependent_files
161 safe_mode mod_details
162
163 -- | Make an interface from a manually constructed 'ModIface'. We use
164 -- this when we are merging 'ModIface's. We assume that the 'ModIface'
165 -- has accurate entries but not accurate fingerprint information (so,
166 -- like @intermediate_iface@ in 'mkIface_'.)
167 mkIfaceDirect :: HscEnv
168 -> Maybe Fingerprint
169 -> ModIface
170 -> IO (ModIface, Bool)
171 mkIfaceDirect hsc_env maybe_old_fingerprint iface0 = do
172 -- Sort some things to make sure we're deterministic
173 let intermediate_iface = iface0 {
174 mi_exports = mkIfaceExports (mi_exports iface0),
175 mi_insts = sortBy cmp_inst (mi_insts iface0),
176 mi_fam_insts = sortBy cmp_fam_inst (mi_fam_insts iface0),
177 mi_rules = sortBy cmp_rule (mi_rules iface0)
178 }
179 dflags = hsc_dflags hsc_env
180 (final_iface, no_change_at_all)
181 <- {-# SCC "versioninfo" #-}
182 addFingerprints hsc_env maybe_old_fingerprint
183 intermediate_iface
184 (map snd (mi_decls iface0))
185
186 -- Debug printing
187 dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
188 (pprModIface final_iface)
189
190 return (final_iface, no_change_at_all)
191
192 -- | make an interface from the results of typechecking only. Useful
193 -- for non-optimising compilation, or where we aren't generating any
194 -- object code at all ('HscNothing').
195 mkIfaceTc :: HscEnv
196 -> Maybe Fingerprint -- The old fingerprint, if we have it
197 -> SafeHaskellMode -- The safe haskell mode
198 -> ModDetails -- gotten from mkBootModDetails, probably
199 -> TcGblEnv -- Usages, deprecations, etc
200 -> IO (ModIface, Bool)
201 mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
202 tc_result@TcGblEnv{ tcg_mod = this_mod,
203 tcg_src = hsc_src,
204 tcg_imports = imports,
205 tcg_rdr_env = rdr_env,
206 tcg_fix_env = fix_env,
207 tcg_warns = warns,
208 tcg_hpc = other_hpc_info,
209 tcg_th_splice_used = tc_splice_used,
210 tcg_dependent_files = dependent_files
211 }
212 = do
213 let used_names = mkUsedNames tc_result
214 deps <- mkDependencies tc_result
215 let hpc_info = emptyHpcInfo other_hpc_info
216 used_th <- readIORef tc_splice_used
217 dep_files <- (readIORef dependent_files)
218 mkIface_ hsc_env maybe_old_fingerprint
219 this_mod hsc_src used_names
220 used_th deps rdr_env
221 fix_env warns hpc_info (imp_mods imports)
222 (imp_trust_own_pkg imports) dep_files safe_mode mod_details
223
224
225 mkUsedNames :: TcGblEnv -> NameSet
226 mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
227
228 -- | Extract information from the rename and typecheck phases to produce
229 -- a dependencies information for the module being compiled.
230 mkDependencies :: TcGblEnv -> IO Dependencies
231 mkDependencies
232 TcGblEnv{ tcg_mod = mod,
233 tcg_imports = imports,
234 tcg_th_used = th_var
235 }
236 = do
237 -- Template Haskell used?
238 th_used <- readIORef th_var
239 let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
240 -- M.hi-boot can be in the imp_dep_mods, but we must remove
241 -- it before recording the modules on which this one depends!
242 -- (We want to retain M.hi-boot in imp_dep_mods so that
243 -- loadHiBootInterface can see if M's direct imports depend
244 -- on M.hi-boot, and hence that we should do the hi-boot consistency
245 -- check.)
246
247 pkgs | th_used = insertList thUnitId (imp_dep_pkgs imports)
248 | otherwise = imp_dep_pkgs imports
249
250 -- Set the packages required to be Safe according to Safe Haskell.
251 -- See Note [RnNames . Tracking Trust Transitively]
252 sorted_pkgs = sortBy stableUnitIdCmp pkgs
253 trust_pkgs = imp_trust_pkgs imports
254 dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
255
256 return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
257 dep_pkgs = dep_pkgs',
258 dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
259 dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
260 -- sort to get into canonical order
261 -- NB. remember to use lexicographic ordering
262
263 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
264 -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
265 -> NameEnv FixItem -> Warnings -> HpcInfo
266 -> ImportedMods -> Bool
267 -> [FilePath]
268 -> SafeHaskellMode
269 -> ModDetails
270 -> IO (ModIface, Bool)
271 mkIface_ hsc_env maybe_old_fingerprint
272 this_mod hsc_src used_names used_th deps rdr_env fix_env src_warns
273 hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
274 ModDetails{ md_insts = insts,
275 md_fam_insts = fam_insts,
276 md_rules = rules,
277 md_anns = anns,
278 md_vect_info = vect_info,
279 md_types = type_env,
280 md_exports = exports }
281 -- NB: notice that mkIface does not look at the bindings
282 -- only at the TypeEnv. The previous Tidy phase has
283 -- put exactly the info into the TypeEnv that we want
284 -- to expose in the interface
285
286 = do
287 usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
288
289 let entities = typeEnvElts type_env
290 decls = [ tyThingToIfaceDecl entity
291 | entity <- entities,
292 let name = getName entity,
293 not (isImplicitTyThing entity),
294 -- No implicit Ids and class tycons in the interface file
295 not (isWiredInName name),
296 -- Nor wired-in things; the compiler knows about them anyhow
297 nameIsLocalOrFrom this_mod name ]
298 -- Sigh: see Note [Root-main Id] in TcRnDriver
299
300 fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
301 warns = src_warns
302 iface_rules = map coreRuleToIfaceRule rules
303 iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
304 iface_fam_insts = map famInstToIfaceFamInst fam_insts
305 iface_vect_info = flattenVectInfo vect_info
306 trust_info = setSafeMode safe_mode
307 annotations = map mkIfaceAnnotation anns
308 sig_of = getSigOf dflags (moduleName this_mod)
309
310 intermediate_iface = ModIface {
311 mi_module = this_mod,
312 mi_sig_of = sig_of,
313 mi_hsc_src = hsc_src,
314 mi_deps = deps,
315 mi_usages = usages,
316 mi_exports = mkIfaceExports exports,
317
318 -- Sort these lexicographically, so that
319 -- the result is stable across compilations
320 mi_insts = sortBy cmp_inst iface_insts,
321 mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts,
322 mi_rules = sortBy cmp_rule iface_rules,
323
324 mi_vect_info = iface_vect_info,
325
326 mi_fixities = fixities,
327 mi_warns = warns,
328 mi_anns = annotations,
329 mi_globals = maybeGlobalRdrEnv rdr_env,
330
331 -- Left out deliberately: filled in by addFingerprints
332 mi_iface_hash = fingerprint0,
333 mi_mod_hash = fingerprint0,
334 mi_flag_hash = fingerprint0,
335 mi_exp_hash = fingerprint0,
336 mi_used_th = used_th,
337 mi_orphan_hash = fingerprint0,
338 mi_orphan = False, -- Always set by addFingerprints, but
339 -- it's a strict field, so we can't omit it.
340 mi_finsts = False, -- Ditto
341 mi_decls = deliberatelyOmitted "decls",
342 mi_hash_fn = deliberatelyOmitted "hash_fn",
343 mi_hpc = isHpcUsed hpc_info,
344 mi_trust = trust_info,
345 mi_trust_pkg = pkg_trust_req,
346
347 -- And build the cached values
348 mi_warn_fn = mkIfaceWarnCache warns,
349 mi_fix_fn = mkIfaceFixCache fixities }
350
351 (new_iface, no_change_at_all)
352 <- {-# SCC "versioninfo" #-}
353 addFingerprints hsc_env maybe_old_fingerprint
354 intermediate_iface decls
355
356 -- Debug printing
357 dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
358 (pprModIface new_iface)
359
360 -- bug #1617: on reload we weren't updating the PrintUnqualified
361 -- correctly. This stems from the fact that the interface had
362 -- not changed, so addFingerprints returns the old ModIface
363 -- with the old GlobalRdrEnv (mi_globals).
364 let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
365
366 return (final_iface, no_change_at_all)
367 where
368
369 dflags = hsc_dflags hsc_env
370
371 -- We only fill in mi_globals if the module was compiled to byte
372 -- code. Otherwise, the compiler may not have retained all the
373 -- top-level bindings and they won't be in the TypeEnv (see
374 -- Desugar.addExportFlagsAndRules). The mi_globals field is used
375 -- by GHCi to decide whether the module has its full top-level
376 -- scope available. (#5534)
377 maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
378 maybeGlobalRdrEnv rdr_env
379 | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
380 | otherwise = Nothing
381
382 deliberatelyOmitted :: String -> a
383 deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
384
385 flattenVectInfo (VectInfo { vectInfoVar = vVar
386 , vectInfoTyCon = vTyCon
387 , vectInfoParallelVars = vParallelVars
388 , vectInfoParallelTyCons = vParallelTyCons
389 }) =
390 IfaceVectInfo
391 { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- varEnvElts vVar]
392 , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
393 , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
394 , ifaceVectInfoParallelVars = [Var.varName v | v <- varSetElems vParallelVars]
395 , ifaceVectInfoParallelTyCons = nameSetElems vParallelTyCons
396 }
397
398 cmp_rule :: IfaceRule -> IfaceRule -> Ordering
399 cmp_rule = comparing ifRuleName
400 -- Compare these lexicographically by OccName, *not* by unique,
401 -- because the latter is not stable across compilations:
402 cmp_inst :: IfaceClsInst -> IfaceClsInst -> Ordering
403 cmp_inst = comparing (nameOccName . ifDFun)
404
405 cmp_fam_inst :: IfaceFamInst -> IfaceFamInst -> Ordering
406 cmp_fam_inst = comparing (nameOccName . ifFamInstFam)
407
408 -----------------------------
409 writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
410 writeIfaceFile dflags hi_file_path new_iface
411 = do createDirectoryIfMissing True (takeDirectory hi_file_path)
412 writeBinIface dflags hi_file_path new_iface
413
414
415 -- -----------------------------------------------------------------------------
416 -- Look up parents and versions of Names
417
418 -- This is like a global version of the mi_hash_fn field in each ModIface.
419 -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
420 -- the parent and version info.
421
422 mkHashFun
423 :: HscEnv -- needed to look up versions
424 -> ExternalPackageState -- ditto
425 -> (Name -> Fingerprint)
426 mkHashFun hsc_env eps
427 = \name ->
428 let
429 mod = ASSERT2( isExternalName name, ppr name ) nameModule name
430 occ = nameOccName name
431 iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
432 pprPanic "lookupVers2" (ppr mod <+> ppr occ)
433 in
434 snd (mi_hash_fn iface occ `orElse`
435 pprPanic "lookupVers1" (ppr mod <+> ppr occ))
436 where
437 hpt = hsc_HPT hsc_env
438 pit = eps_PIT eps
439
440 -- ---------------------------------------------------------------------------
441 -- Compute fingerprints for the interface
442
443 addFingerprints
444 :: HscEnv
445 -> Maybe Fingerprint -- the old fingerprint, if any
446 -> ModIface -- The new interface (lacking decls)
447 -> [IfaceDecl] -- The new decls
448 -> IO (ModIface, -- Updated interface
449 Bool) -- True <=> no changes at all;
450 -- no need to write Iface
451
452 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
453 = do
454 eps <- hscEPS hsc_env
455 let
456 -- The ABI of a declaration represents everything that is made
457 -- visible about the declaration that a client can depend on.
458 -- see IfaceDeclABI below.
459 declABI :: IfaceDecl -> IfaceDeclABI
460 declABI decl = (this_mod, decl, extras)
461 where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
462 non_orph_fis decl
463
464 edges :: [(IfaceDeclABI, Unique, [Unique])]
465 edges = [ (abi, getUnique (ifName decl), out)
466 | decl <- new_decls
467 , let abi = declABI decl
468 , let out = localOccs $ freeNamesDeclABI abi
469 ]
470
471 name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
472 localOccs = map (getUnique . getParent . getOccName)
473 . filter ((== this_mod) . name_module)
474 . nameSetElems
475 where getParent occ = lookupOccEnv parent_map occ `orElse` occ
476
477 -- maps OccNames to their parents in the current module.
478 -- e.g. a reference to a constructor must be turned into a reference
479 -- to the TyCon for the purposes of calculating dependencies.
480 parent_map :: OccEnv OccName
481 parent_map = foldr extend emptyOccEnv new_decls
482 where extend d env =
483 extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
484 where n = ifName d
485
486 -- strongly-connected groups of declarations, in dependency order
487 groups = stronglyConnCompFromEdgedVertices edges
488
489 global_hash_fn = mkHashFun hsc_env eps
490
491 -- how to output Names when generating the data to fingerprint.
492 -- Here we want to output the fingerprint for each top-level
493 -- Name, whether it comes from the current module or another
494 -- module. In this way, the fingerprint for a declaration will
495 -- change if the fingerprint for anything it refers to (transitively)
496 -- changes.
497 mk_put_name :: (OccEnv (OccName,Fingerprint))
498 -> BinHandle -> Name -> IO ()
499 mk_put_name local_env bh name
500 | isWiredInName name = putNameLiterally bh name
501 -- wired-in names don't have fingerprints
502 | otherwise
503 = ASSERT2( isExternalName name, ppr name )
504 let hash | nameModule name /= this_mod = global_hash_fn name
505 | otherwise = snd (lookupOccEnv local_env (getOccName name)
506 `orElse` pprPanic "urk! lookup local fingerprint"
507 (ppr name)) -- (undefined,fingerprint0))
508 -- This panic indicates that we got the dependency
509 -- analysis wrong, because we needed a fingerprint for
510 -- an entity that wasn't in the environment. To debug
511 -- it, turn the panic into a trace, uncomment the
512 -- pprTraces below, run the compile again, and inspect
513 -- the output and the generated .hi file with
514 -- --show-iface.
515 in put_ bh hash
516
517 -- take a strongly-connected group of declarations and compute
518 -- its fingerprint.
519
520 fingerprint_group :: (OccEnv (OccName,Fingerprint),
521 [(Fingerprint,IfaceDecl)])
522 -> SCC IfaceDeclABI
523 -> IO (OccEnv (OccName,Fingerprint),
524 [(Fingerprint,IfaceDecl)])
525
526 fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
527 = do let hash_fn = mk_put_name local_env
528 decl = abiDecl abi
529 --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
530 hash <- computeFingerprint hash_fn abi
531 env' <- extend_hash_env local_env (hash,decl)
532 return (env', (hash,decl) : decls_w_hashes)
533
534 fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
535 = do let decls = map abiDecl abis
536 local_env1 <- foldM extend_hash_env local_env
537 (zip (repeat fingerprint0) decls)
538 let hash_fn = mk_put_name local_env1
539 -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
540 let stable_abis = sortBy cmp_abiNames abis
541 -- put the cycle in a canonical order
542 hash <- computeFingerprint hash_fn stable_abis
543 let pairs = zip (repeat hash) decls
544 local_env2 <- foldM extend_hash_env local_env pairs
545 return (local_env2, pairs ++ decls_w_hashes)
546
547 -- we have fingerprinted the whole declaration, but we now need
548 -- to assign fingerprints to all the OccNames that it binds, to
549 -- use when referencing those OccNames in later declarations.
550 --
551 extend_hash_env :: OccEnv (OccName,Fingerprint)
552 -> (Fingerprint,IfaceDecl)
553 -> IO (OccEnv (OccName,Fingerprint))
554 extend_hash_env env0 (hash,d) = do
555 return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
556 (ifaceDeclFingerprints hash d))
557
558 --
559 (local_env, decls_w_hashes) <-
560 foldM fingerprint_group (emptyOccEnv, []) groups
561
562 -- when calculating fingerprints, we always need to use canonical
563 -- ordering for lists of things. In particular, the mi_deps has various
564 -- lists of modules and suchlike, so put these all in canonical order:
565 let sorted_deps = sortDependencies (mi_deps iface0)
566
567 -- the export hash of a module depends on the orphan hashes of the
568 -- orphan modules below us in the dependency tree. This is the way
569 -- that changes in orphans get propagated all the way up the
570 -- dependency tree. We only care about orphan modules in the current
571 -- package, because changes to orphans outside this package will be
572 -- tracked by the usage on the ABI hash of package modules that we import.
573 let orph_mods
574 = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]
575 . filter ((== this_pkg) . moduleUnitId)
576 $ dep_orphs sorted_deps
577 dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
578
579 -- Note [Do not update EPS with your own hi-boot]
580 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
581 -- (See also Trac #10182). When your hs-boot file includes an orphan
582 -- instance declaration, you may find that the dep_orphs of a module you
583 -- import contains reference to yourself. DO NOT actually load this module
584 -- or add it to the orphan hashes: you're going to provide the orphan
585 -- instances yourself, no need to consult hs-boot; if you do load the
586 -- interface into EPS, you will see a duplicate orphan instance.
587
588 orphan_hash <- computeFingerprint (mk_put_name local_env)
589 (map ifDFun orph_insts, orph_rules, orph_fis)
590
591 -- the export list hash doesn't depend on the fingerprints of
592 -- the Names it mentions, only the Names themselves, hence putNameLiterally.
593 export_hash <- computeFingerprint putNameLiterally
594 (mi_exports iface0,
595 orphan_hash,
596 dep_orphan_hashes,
597 dep_pkgs (mi_deps iface0),
598 -- dep_pkgs: see "Package Version Changes" on
599 -- wiki/Commentary/Compiler/RecompilationAvoidance
600 mi_trust iface0)
601 -- Make sure change of Safe Haskell mode causes recomp.
602
603 -- put the declarations in a canonical order, sorted by OccName
604 let sorted_decls = Map.elems $ Map.fromList $
605 [(ifName d, e) | e@(_, d) <- decls_w_hashes]
606
607 -- the flag hash depends on:
608 -- - (some of) dflags
609 -- it returns two hashes, one that shouldn't change
610 -- the abi hash and one that should
611 flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
612
613 -- the ABI hash depends on:
614 -- - decls
615 -- - export list
616 -- - orphans
617 -- - deprecations
618 -- - vect info
619 -- - flag abi hash
620 mod_hash <- computeFingerprint putNameLiterally
621 (map fst sorted_decls,
622 export_hash, -- includes orphan_hash
623 mi_warns iface0,
624 mi_vect_info iface0)
625
626 -- The interface hash depends on:
627 -- - the ABI hash, plus
628 -- - the module level annotations,
629 -- - usages
630 -- - deps (home and external packages, dependent files)
631 -- - hpc
632 iface_hash <- computeFingerprint putNameLiterally
633 (mod_hash,
634 ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache
635 mi_usages iface0,
636 sorted_deps,
637 mi_hpc iface0)
638
639 let
640 no_change_at_all = Just iface_hash == mb_old_fingerprint
641
642 final_iface = iface0 {
643 mi_mod_hash = mod_hash,
644 mi_iface_hash = iface_hash,
645 mi_exp_hash = export_hash,
646 mi_orphan_hash = orphan_hash,
647 mi_flag_hash = flag_hash,
648 mi_orphan = not ( all ifRuleAuto orph_rules
649 -- See Note [Orphans and auto-generated rules]
650 && null orph_insts
651 && null orph_fis
652 && isNoIfaceVectInfo (mi_vect_info iface0)),
653 mi_finsts = not . null $ mi_fam_insts iface0,
654 mi_decls = sorted_decls,
655 mi_hash_fn = lookupOccEnv local_env }
656 --
657 return (final_iface, no_change_at_all)
658
659 where
660 this_mod = mi_module iface0
661 dflags = hsc_dflags hsc_env
662 this_pkg = thisPackage dflags
663 (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
664 (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
665 (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
666 fix_fn = mi_fix_fn iface0
667 ann_fn = mkIfaceAnnCache (mi_anns iface0)
668
669 getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
670 getOrphanHashes hsc_env mods = do
671 eps <- hscEPS hsc_env
672 let
673 hpt = hsc_HPT hsc_env
674 pit = eps_PIT eps
675 dflags = hsc_dflags hsc_env
676 get_orph_hash mod =
677 case lookupIfaceByModule dflags hpt pit mod of
678 Nothing -> pprPanic "moduleOrphanHash" (ppr mod)
679 Just iface -> mi_orphan_hash iface
680 --
681 return (map get_orph_hash mods)
682
683
684 sortDependencies :: Dependencies -> Dependencies
685 sortDependencies d
686 = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
687 dep_pkgs = sortBy (stableUnitIdCmp `on` fst) (dep_pkgs d),
688 dep_orphs = sortBy stableModuleCmp (dep_orphs d),
689 dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
690
691 -- | Creates cached lookup for the 'mi_anns' field of ModIface
692 -- Hackily, we use "module" as the OccName for any module-level annotations
693 mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
694 mkIfaceAnnCache anns
695 = \n -> lookupOccEnv env n `orElse` []
696 where
697 pair (IfaceAnnotation target value) =
698 (case target of
699 NamedTarget occn -> occn
700 ModuleTarget _ -> mkVarOcc "module"
701 , [value])
702 -- flipping (++), so the first argument is always short
703 env = mkOccEnv_C (flip (++)) (map pair anns)
704
705 {-
706 ************************************************************************
707 * *
708 The ABI of an IfaceDecl
709 * *
710 ************************************************************************
711
712 Note [The ABI of an IfaceDecl]
713 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
714 The ABI of a declaration consists of:
715
716 (a) the full name of the identifier (inc. module and package,
717 because these are used to construct the symbol name by which
718 the identifier is known externally).
719
720 (b) the declaration itself, as exposed to clients. That is, the
721 definition of an Id is included in the fingerprint only if
722 it is made available as an unfolding in the interface.
723
724 (c) the fixity of the identifier
725 (d) for Ids: rules
726 (e) for classes: instances, fixity & rules for methods
727 (f) for datatypes: instances, fixity & rules for constrs
728
729 Items (c)-(f) are not stored in the IfaceDecl, but instead appear
730 elsewhere in the interface file. But they are *fingerprinted* with
731 the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
732 and fingerprinting that as part of the declaration.
733 -}
734
735 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
736
737 data IfaceDeclExtras
738 = IfaceIdExtras IfaceIdExtras
739
740 | IfaceDataExtras
741 Fixity -- Fixity of the tycon itself
742 [IfaceInstABI] -- Local class and family instances of this tycon
743 -- See Note [Orphans] in InstEnv
744 [AnnPayload] -- Annotations of the type itself
745 [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations
746
747 | IfaceClassExtras
748 Fixity -- Fixity of the class itself
749 [IfaceInstABI] -- Local instances of this class *or*
750 -- of its associated data types
751 -- See Note [Orphans] in InstEnv
752 [AnnPayload] -- Annotations of the type itself
753 [IfaceIdExtras] -- For each class method: fixity, RULES and annotations
754
755 | IfaceSynonymExtras Fixity [AnnPayload]
756
757 | IfaceFamilyExtras Fixity [IfaceInstABI] [AnnPayload]
758
759 | IfaceOtherDeclExtras
760
761 data IfaceIdExtras
762 = IdExtras
763 Fixity -- Fixity of the Id
764 [IfaceRule] -- Rules for the Id
765 [AnnPayload] -- Annotations for the Id
766
767 -- When hashing a class or family instance, we hash only the
768 -- DFunId or CoAxiom, because that depends on all the
769 -- information about the instance.
770 --
771 type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance
772
773 abiDecl :: IfaceDeclABI -> IfaceDecl
774 abiDecl (_, decl, _) = decl
775
776 cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
777 cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
778 ifName (abiDecl abi2)
779
780 freeNamesDeclABI :: IfaceDeclABI -> NameSet
781 freeNamesDeclABI (_mod, decl, extras) =
782 freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras
783
784 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
785 freeNamesDeclExtras (IfaceIdExtras id_extras)
786 = freeNamesIdExtras id_extras
787 freeNamesDeclExtras (IfaceDataExtras _ insts _ subs)
788 = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
789 freeNamesDeclExtras (IfaceClassExtras _ insts _ subs)
790 = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
791 freeNamesDeclExtras (IfaceSynonymExtras _ _)
792 = emptyNameSet
793 freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
794 = mkNameSet insts
795 freeNamesDeclExtras IfaceOtherDeclExtras
796 = emptyNameSet
797
798 freeNamesIdExtras :: IfaceIdExtras -> NameSet
799 freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)
800
801 instance Outputable IfaceDeclExtras where
802 ppr IfaceOtherDeclExtras = Outputable.empty
803 ppr (IfaceIdExtras extras) = ppr_id_extras extras
804 ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
805 ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
806 ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
807 ppr_id_extras_s stuff]
808 ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
809 ppr_id_extras_s stuff]
810
811 ppr_insts :: [IfaceInstABI] -> SDoc
812 ppr_insts _ = ptext (sLit "<insts>")
813
814 ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
815 ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
816
817 ppr_id_extras :: IfaceIdExtras -> SDoc
818 ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
819
820 -- This instance is used only to compute fingerprints
821 instance Binary IfaceDeclExtras where
822 get _bh = panic "no get for IfaceDeclExtras"
823 put_ bh (IfaceIdExtras extras) = do
824 putByte bh 1; put_ bh extras
825 put_ bh (IfaceDataExtras fix insts anns cons) = do
826 putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
827 put_ bh (IfaceClassExtras fix insts anns methods) = do
828 putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods
829 put_ bh (IfaceSynonymExtras fix anns) = do
830 putByte bh 4; put_ bh fix; put_ bh anns
831 put_ bh (IfaceFamilyExtras fix finsts anns) = do
832 putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
833 put_ bh IfaceOtherDeclExtras = putByte bh 6
834
835 instance Binary IfaceIdExtras where
836 get _bh = panic "no get for IfaceIdExtras"
837 put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
838
839 declExtras :: (OccName -> Fixity)
840 -> (OccName -> [AnnPayload])
841 -> OccEnv [IfaceRule]
842 -> OccEnv [IfaceClsInst]
843 -> OccEnv [IfaceFamInst]
844 -> IfaceDecl
845 -> IfaceDeclExtras
846
847 declExtras fix_fn ann_fn rule_env inst_env fi_env decl
848 = case decl of
849 IfaceId{} -> IfaceIdExtras (id_extras n)
850 IfaceData{ifCons=cons} ->
851 IfaceDataExtras (fix_fn n)
852 (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
853 map ifDFun (lookupOccEnvL inst_env n))
854 (ann_fn n)
855 (map (id_extras . ifConOcc) (visibleIfConDecls cons))
856 IfaceClass{ifSigs=sigs, ifATs=ats} ->
857 IfaceClassExtras (fix_fn n)
858 (map ifDFun $ (concatMap at_extras ats)
859 ++ lookupOccEnvL inst_env n)
860 -- Include instances of the associated types
861 -- as well as instances of the class (Trac #5147)
862 (ann_fn n)
863 [id_extras op | IfaceClassOp op _ _ <- sigs]
864 IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
865 (ann_fn n)
866 IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
867 (map ifFamInstAxiom (lookupOccEnvL fi_env n))
868 (ann_fn n)
869 _other -> IfaceOtherDeclExtras
870 where
871 n = ifName decl
872 id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
873 at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl)
874
875
876 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
877 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
878
879 -- used when we want to fingerprint a structure without depending on the
880 -- fingerprints of external Names that it refers to.
881 putNameLiterally :: BinHandle -> Name -> IO ()
882 putNameLiterally bh name = ASSERT( isExternalName name )
883 do
884 put_ bh $! nameModule name
885 put_ bh $! nameOccName name
886
887 {-
888 -- for testing: use the md5sum command to generate fingerprints and
889 -- compare the results against our built-in version.
890 fp' <- oldMD5 dflags bh
891 if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
892 else return fp
893
894 oldMD5 dflags bh = do
895 tmp <- newTempName dflags "bin"
896 writeBinMem bh tmp
897 tmp2 <- newTempName dflags "md5"
898 let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
899 r <- system cmd
900 case r of
901 ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
902 ExitSuccess -> do
903 hash_str <- readFile tmp2
904 return $! readHexFingerprint hash_str
905 -}
906
907 ----------------------
908 -- mkOrphMap partitions instance decls or rules into
909 -- (a) an OccEnv for ones that are not orphans,
910 -- mapping the local OccName to a list of its decls
911 -- (b) a list of orphan decls
912 mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
913 -> [decl] -- Sorted into canonical order
914 -> (OccEnv [decl], -- Non-orphan decls associated with their key;
915 -- each sublist in canonical order
916 [decl]) -- Orphan decls; in canonical order
917 mkOrphMap get_key decls
918 = foldl go (emptyOccEnv, []) decls
919 where
920 go (non_orphs, orphs) d
921 | NotOrphan occ <- get_key d
922 = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
923 | otherwise = (non_orphs, d:orphs)
924
925 {-
926 ************************************************************************
927 * *
928 Keeping track of what we've slurped, and fingerprints
929 * *
930 ************************************************************************
931 -}
932
933 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
934 mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
935 = do
936 eps <- hscEPS hsc_env
937 hashes <- mapM getFileHash dependent_files
938 let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
939 dir_imp_mods used_names
940 let usages = mod_usages ++ [ UsageFile { usg_file_path = f
941 , usg_file_hash = hash }
942 | (f, hash) <- zip dependent_files hashes ]
943 usages `seqList` return usages
944 -- seq the list of Usages returned: occasionally these
945 -- don't get evaluated for a while and we can end up hanging on to
946 -- the entire collection of Ifaces.
947
948 mk_mod_usage_info :: PackageIfaceTable
949 -> HscEnv
950 -> Module
951 -> ImportedMods
952 -> NameSet
953 -> [Usage]
954 mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
955 = mapMaybe mkUsage usage_mods
956 where
957 hpt = hsc_HPT hsc_env
958 dflags = hsc_dflags hsc_env
959 this_pkg = thisPackage dflags
960
961 used_mods = moduleEnvKeys ent_map
962 dir_imp_mods = moduleEnvKeys direct_imports
963 all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
964 usage_mods = sortBy stableModuleCmp all_mods
965 -- canonical order is imported, to avoid interface-file
966 -- wobblage.
967
968 -- ent_map groups together all the things imported and used
969 -- from a particular module
970 ent_map :: ModuleEnv [OccName]
971 ent_map = foldNameSet add_mv emptyModuleEnv used_names
972 where
973 add_mv name mv_map
974 | isWiredInName name = mv_map -- ignore wired-in names
975 | otherwise
976 = case nameModule_maybe name of
977 Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map
978 -- See Note [Internal used_names]
979
980 Just mod -> -- This lambda function is really just a
981 -- specialised (++); originally came about to
982 -- avoid quadratic behaviour (trac #2680)
983 extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
984 where occ = nameOccName name
985
986 -- We want to create a Usage for a home module if
987 -- a) we used something from it; has something in used_names
988 -- b) we imported it, even if we used nothing from it
989 -- (need to recompile if its export list changes: export_fprint)
990 mkUsage :: Module -> Maybe Usage
991 mkUsage mod
992 | isNothing maybe_iface -- We can't depend on it if we didn't
993 -- load its interface.
994 || mod == this_mod -- We don't care about usages of
995 -- things in *this* module
996 = Nothing
997
998 | moduleUnitId mod /= this_pkg
999 = Just UsagePackageModule{ usg_mod = mod,
1000 usg_mod_hash = mod_hash,
1001 usg_safe = imp_safe }
1002 -- for package modules, we record the module hash only
1003
1004 | (null used_occs
1005 && isNothing export_hash
1006 && not is_direct_import
1007 && not finsts_mod)
1008 = Nothing -- Record no usage info
1009 -- for directly-imported modules, we always want to record a usage
1010 -- on the orphan hash. This is what triggers a recompilation if
1011 -- an orphan is added or removed somewhere below us in the future.
1012
1013 | otherwise
1014 = Just UsageHomeModule {
1015 usg_mod_name = moduleName mod,
1016 usg_mod_hash = mod_hash,
1017 usg_exports = export_hash,
1018 usg_entities = Map.toList ent_hashs,
1019 usg_safe = imp_safe }
1020 where
1021 maybe_iface = lookupIfaceByModule dflags hpt pit mod
1022 -- In one-shot mode, the interfaces for home-package
1023 -- modules accumulate in the PIT not HPT. Sigh.
1024
1025 Just iface = maybe_iface
1026 finsts_mod = mi_finsts iface
1027 hash_env = mi_hash_fn iface
1028 mod_hash = mi_mod_hash iface
1029 export_hash | depend_on_exports = Just (mi_exp_hash iface)
1030 | otherwise = Nothing
1031
1032 (is_direct_import, imp_safe)
1033 = case lookupModuleEnv direct_imports mod of
1034 Just ((_,_,_,safe):_xs) -> (True, safe)
1035 Just _ -> pprPanic "mkUsage: empty direct import" Outputable.empty
1036 Nothing -> (False, safeImplicitImpsReq dflags)
1037 -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn'
1038 -- is used in the source code. We require them to be safe in Safe Haskell
1039
1040 used_occs = lookupModuleEnv ent_map mod `orElse` []
1041
1042 -- Making a Map here ensures that (a) we remove duplicates
1043 -- when we have usages on several subordinates of a single parent,
1044 -- and (b) that the usages emerge in a canonical order, which
1045 -- is why we use Map rather than OccEnv: Map works
1046 -- using Ord on the OccNames, which is a lexicographic ordering.
1047 ent_hashs :: Map OccName Fingerprint
1048 ent_hashs = Map.fromList (map lookup_occ used_occs)
1049
1050 lookup_occ occ =
1051 case hash_env occ of
1052 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
1053 Just r -> r
1054
1055 depend_on_exports = is_direct_import
1056 {- True
1057 Even if we used 'import M ()', we have to register a
1058 usage on the export list because we are sensitive to
1059 changes in orphan instances/rules.
1060 False
1061 In GHC 6.8.x we always returned true, and in
1062 fact it recorded a dependency on *all* the
1063 modules underneath in the dependency tree. This
1064 happens to make orphans work right, but is too
1065 expensive: it'll read too many interface files.
1066 The 'isNothing maybe_iface' check above saved us
1067 from generating many of these usages (at least in
1068 one-shot mode), but that's even more bogus!
1069 -}
1070
1071 mkIfaceAnnotation :: Annotation -> IfaceAnnotation
1072 mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
1073 = IfaceAnnotation {
1074 ifAnnotatedTarget = fmap nameOccName target,
1075 ifAnnotatedValue = payload
1076 }
1077
1078 mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical
1079 mkIfaceExports exports
1080 = sortBy stableAvailCmp (map sort_subs exports)
1081 where
1082 sort_subs :: AvailInfo -> AvailInfo
1083 sort_subs (Avail n) = Avail n
1084 sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
1085 sort_subs (AvailTC n (m:ms) fs)
1086 | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
1087 | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
1088 -- Maintain the AvailTC Invariant
1089
1090 sort_flds = sortBy (stableNameCmp `on` flSelector)
1091
1092 {-
1093 Note [Orignal module]
1094 ~~~~~~~~~~~~~~~~~~~~~
1095 Consider this:
1096 module X where { data family T }
1097 module Y( T(..) ) where { import X; data instance T Int = MkT Int }
1098 The exported Avail from Y will look like
1099 X.T{X.T, Y.MkT}
1100 That is, in Y,
1101 - only MkT is brought into scope by the data instance;
1102 - but the parent (used for grouping and naming in T(..) exports) is X.T
1103 - and in this case we export X.T too
1104
1105 In the result of MkIfaceExports, the names are grouped by defining module,
1106 so we may need to split up a single Avail into multiple ones.
1107
1108 Note [Internal used_names]
1109 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1110 Most of the used_names are External Names, but we can have Internal
1111 Names too: see Note [Binders in Template Haskell] in Convert, and
1112 Trac #5362 for an example. Such Names are always
1113 - Such Names are always for locally-defined things, for which we
1114 don't gather usage info, so we can just ignore them in ent_map
1115 - They are always System Names, hence the assert, just as a double check.
1116
1117
1118 ************************************************************************
1119 * *
1120 Load the old interface file for this module (unless
1121 we have it already), and check whether it is up to date
1122 * *
1123 ************************************************************************
1124 -}
1125
1126 data RecompileRequired
1127 = UpToDate
1128 -- ^ everything is up to date, recompilation is not required
1129 | MustCompile
1130 -- ^ The .hs file has been touched, or the .o/.hi file does not exist
1131 | RecompBecause String
1132 -- ^ The .o/.hi files are up to date, but something else has changed
1133 -- to force recompilation; the String says what (one-line summary)
1134 deriving Eq
1135
1136 recompileRequired :: RecompileRequired -> Bool
1137 recompileRequired UpToDate = False
1138 recompileRequired _ = True
1139
1140
1141
1142 -- | Top level function to check if the version of an old interface file
1143 -- is equivalent to the current source file the user asked us to compile.
1144 -- If the same, we can avoid recompilation. We return a tuple where the
1145 -- first element is a bool saying if we should recompile the object file
1146 -- and the second is maybe the interface file, where Nothng means to
1147 -- rebuild the interface file not use the exisitng one.
1148 checkOldIface
1149 :: HscEnv
1150 -> ModSummary
1151 -> SourceModified
1152 -> Maybe ModIface -- Old interface from compilation manager, if any
1153 -> IO (RecompileRequired, Maybe ModIface)
1154
1155 checkOldIface hsc_env mod_summary source_modified maybe_iface
1156 = do let dflags = hsc_dflags hsc_env
1157 showPass dflags $
1158 "Checking old interface for " ++
1159 (showPpr dflags $ ms_mod mod_summary)
1160 initIfaceCheck hsc_env $
1161 check_old_iface hsc_env mod_summary source_modified maybe_iface
1162
1163 check_old_iface
1164 :: HscEnv
1165 -> ModSummary
1166 -> SourceModified
1167 -> Maybe ModIface
1168 -> IfG (RecompileRequired, Maybe ModIface)
1169
1170 check_old_iface hsc_env mod_summary src_modified maybe_iface
1171 = let dflags = hsc_dflags hsc_env
1172 getIface =
1173 case maybe_iface of
1174 Just _ -> do
1175 traceIf (text "We already have the old interface for" <+>
1176 ppr (ms_mod mod_summary))
1177 return maybe_iface
1178 Nothing -> loadIface
1179
1180 loadIface = do
1181 let iface_path = msHiFilePath mod_summary
1182 read_result <- readIface (ms_mod mod_summary) iface_path
1183 case read_result of
1184 Failed err -> do
1185 traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
1186 return Nothing
1187 Succeeded iface -> do
1188 traceIf (text "Read the interface file" <+> text iface_path)
1189 return $ Just iface
1190
1191 src_changed
1192 | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
1193 | SourceModified <- src_modified = True
1194 | otherwise = False
1195 in do
1196 when src_changed $
1197 traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
1198
1199 case src_changed of
1200 -- If the source has changed and we're in interactive mode,
1201 -- avoid reading an interface; just return the one we might
1202 -- have been supplied with.
1203 True | not (isObjectTarget $ hscTarget dflags) ->
1204 return (MustCompile, maybe_iface)
1205
1206 -- Try and read the old interface for the current module
1207 -- from the .hi file left from the last time we compiled it
1208 True -> do
1209 maybe_iface' <- getIface
1210 return (MustCompile, maybe_iface')
1211
1212 False -> do
1213 maybe_iface' <- getIface
1214 case maybe_iface' of
1215 -- We can't retrieve the iface
1216 Nothing -> return (MustCompile, Nothing)
1217
1218 -- We have got the old iface; check its versions
1219 -- even in the SourceUnmodifiedAndStable case we
1220 -- should check versions because some packages
1221 -- might have changed or gone away.
1222 Just iface -> checkVersions hsc_env mod_summary iface
1223
1224 -- | Check if a module is still the same 'version'.
1225 --
1226 -- This function is called in the recompilation checker after we have
1227 -- determined that the module M being checked hasn't had any changes
1228 -- to its source file since we last compiled M. So at this point in general
1229 -- two things may have changed that mean we should recompile M:
1230 -- * The interface export by a dependency of M has changed.
1231 -- * The compiler flags specified this time for M have changed
1232 -- in a manner that is significant for recompilaiton.
1233 -- We return not just if we should recompile the object file but also
1234 -- if we should rebuild the interface file.
1235 checkVersions :: HscEnv
1236 -> ModSummary
1237 -> ModIface -- Old interface
1238 -> IfG (RecompileRequired, Maybe ModIface)
1239 checkVersions hsc_env mod_summary iface
1240 = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
1241 ppr (mi_module iface) <> colon)
1242
1243 ; recomp <- checkFlagHash hsc_env iface
1244 ; if recompileRequired recomp then return (recomp, Nothing) else do {
1245 ; if getSigOf (hsc_dflags hsc_env) (moduleName (mi_module iface))
1246 /= mi_sig_of iface
1247 then return (RecompBecause "sig-of changed", Nothing) else do {
1248 ; recomp <- checkDependencies hsc_env mod_summary iface
1249 ; if recompileRequired recomp then return (recomp, Just iface) else do {
1250
1251 -- Source code unchanged and no errors yet... carry on
1252 --
1253 -- First put the dependent-module info, read from the old
1254 -- interface, into the envt, so that when we look for
1255 -- interfaces we look for the right one (.hi or .hi-boot)
1256 --
1257 -- It's just temporary because either the usage check will succeed
1258 -- (in which case we are done with this module) or it'll fail (in which
1259 -- case we'll compile the module from scratch anyhow).
1260 --
1261 -- We do this regardless of compilation mode, although in --make mode
1262 -- all the dependent modules should be in the HPT already, so it's
1263 -- quite redundant
1264 ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
1265 ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1266 ; return (recomp, Just iface)
1267 }}}}
1268 where
1269 this_pkg = thisPackage (hsc_dflags hsc_env)
1270 -- This is a bit of a hack really
1271 mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1272 mod_deps = mkModDeps (dep_mods (mi_deps iface))
1273
1274 -- | Check the flags haven't changed
1275 checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
1276 checkFlagHash hsc_env iface = do
1277 let old_hash = mi_flag_hash iface
1278 new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
1279 (mi_module iface)
1280 putNameLiterally
1281 case old_hash == new_hash of
1282 True -> up_to_date (ptext $ sLit "Module flags unchanged")
1283 False -> out_of_date_hash "flags changed"
1284 (ptext $ sLit " Module flags have changed")
1285 old_hash new_hash
1286
1287 -- If the direct imports of this module are resolved to targets that
1288 -- are not among the dependencies of the previous interface file,
1289 -- then we definitely need to recompile. This catches cases like
1290 -- - an exposed package has been upgraded
1291 -- - we are compiling with different package flags
1292 -- - a home module that was shadowing a package module has been removed
1293 -- - a new home module has been added that shadows a package module
1294 -- See bug #1372.
1295 --
1296 -- Returns True if recompilation is required.
1297 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1298 checkDependencies hsc_env summary iface
1299 = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1300 where
1301 prev_dep_mods = dep_mods (mi_deps iface)
1302 prev_dep_pkgs = dep_pkgs (mi_deps iface)
1303
1304 this_pkg = thisPackage (hsc_dflags hsc_env)
1305
1306 dep_missing (mb_pkg, L _ mod) = do
1307 find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
1308 let reason = moduleNameString mod ++ " changed"
1309 case find_res of
1310 Found _ mod
1311 | pkg == this_pkg
1312 -> if moduleName mod `notElem` map fst prev_dep_mods
1313 then do traceHiDiffs $
1314 text "imported module " <> quotes (ppr mod) <>
1315 text " not among previous dependencies"
1316 return (RecompBecause reason)
1317 else
1318 return UpToDate
1319 | otherwise
1320 -> if pkg `notElem` (map fst prev_dep_pkgs)
1321 then do traceHiDiffs $
1322 text "imported module " <> quotes (ppr mod) <>
1323 text " is from package " <> quotes (ppr pkg) <>
1324 text ", which is not among previous dependencies"
1325 return (RecompBecause reason)
1326 else
1327 return UpToDate
1328 where pkg = moduleUnitId mod
1329 _otherwise -> return (RecompBecause reason)
1330
1331 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1332 -> IfG RecompileRequired
1333 needInterface mod continue
1334 = do -- Load the imported interface if possible
1335 let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1336 traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1337
1338 mb_iface <- loadInterface doc_str mod ImportBySystem
1339 -- Load the interface, but don't complain on failure;
1340 -- Instead, get an Either back which we can test
1341
1342 case mb_iface of
1343 Failed _ -> do
1344 traceHiDiffs (sep [ptext (sLit "Couldn't load interface for module"),
1345 ppr mod])
1346 return MustCompile
1347 -- Couldn't find or parse a module mentioned in the
1348 -- old interface file. Don't complain: it might
1349 -- just be that the current module doesn't need that
1350 -- import and it's been deleted
1351 Succeeded iface -> continue iface
1352
1353
1354 -- | Given the usage information extracted from the old
1355 -- M.hi file for the module being compiled, figure out
1356 -- whether M needs to be recompiled.
1357 checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
1358 checkModUsage _this_pkg UsagePackageModule{
1359 usg_mod = mod,
1360 usg_mod_hash = old_mod_hash }
1361 = needInterface mod $ \iface -> do
1362 let reason = moduleNameString (moduleName mod) ++ " changed"
1363 checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
1364 -- We only track the ABI hash of package modules, rather than
1365 -- individual entity usages, so if the ABI hash changes we must
1366 -- recompile. This is safe but may entail more recompilation when
1367 -- a dependent package has changed.
1368
1369 checkModUsage this_pkg UsageHomeModule{
1370 usg_mod_name = mod_name,
1371 usg_mod_hash = old_mod_hash,
1372 usg_exports = maybe_old_export_hash,
1373 usg_entities = old_decl_hash }
1374 = do
1375 let mod = mkModule this_pkg mod_name
1376 needInterface mod $ \iface -> do
1377
1378 let
1379 new_mod_hash = mi_mod_hash iface
1380 new_decl_hash = mi_hash_fn iface
1381 new_export_hash = mi_exp_hash iface
1382
1383 reason = moduleNameString mod_name ++ " changed"
1384
1385 -- CHECK MODULE
1386 recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
1387 if not (recompileRequired recompile)
1388 then return UpToDate
1389 else do
1390
1391 -- CHECK EXPORT LIST
1392 checkMaybeHash reason maybe_old_export_hash new_export_hash
1393 (ptext (sLit " Export list changed")) $ do
1394
1395 -- CHECK ITEMS ONE BY ONE
1396 recompile <- checkList [ checkEntityUsage reason new_decl_hash u
1397 | u <- old_decl_hash]
1398 if recompileRequired recompile
1399 then return recompile -- This one failed, so just bail out now
1400 else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
1401
1402
1403 checkModUsage _this_pkg UsageFile{ usg_file_path = file,
1404 usg_file_hash = old_hash } =
1405 liftIO $
1406 handleIO handle $ do
1407 new_hash <- getFileHash file
1408 if (old_hash /= new_hash)
1409 then return recomp
1410 else return UpToDate
1411 where
1412 recomp = RecompBecause (file ++ " changed")
1413 handle =
1414 #ifdef DEBUG
1415 \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
1416 #else
1417 \_ -> return recomp -- if we can't find the file, just recompile, don't fail
1418 #endif
1419
1420 ------------------------
1421 checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
1422 -> IfG RecompileRequired
1423 checkModuleFingerprint reason old_mod_hash new_mod_hash
1424 | new_mod_hash == old_mod_hash
1425 = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1426
1427 | otherwise
1428 = out_of_date_hash reason (ptext (sLit " Module fingerprint has changed"))
1429 old_mod_hash new_mod_hash
1430
1431 ------------------------
1432 checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
1433 -> IfG RecompileRequired -> IfG RecompileRequired
1434 checkMaybeHash reason maybe_old_hash new_hash doc continue
1435 | Just hash <- maybe_old_hash, hash /= new_hash
1436 = out_of_date_hash reason doc hash new_hash
1437 | otherwise
1438 = continue
1439
1440 ------------------------
1441 checkEntityUsage :: String
1442 -> (OccName -> Maybe (OccName, Fingerprint))
1443 -> (OccName, Fingerprint)
1444 -> IfG RecompileRequired
1445 checkEntityUsage reason new_hash (name,old_hash)
1446 = case new_hash name of
1447
1448 Nothing -> -- We used it before, but it ain't there now
1449 out_of_date reason (sep [ptext (sLit "No longer exported:"), ppr name])
1450
1451 Just (_, new_hash) -- It's there, but is it up to date?
1452 | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
1453 return UpToDate
1454 | otherwise -> out_of_date_hash reason (ptext (sLit " Out of date:") <+> ppr name)
1455 old_hash new_hash
1456
1457 up_to_date :: SDoc -> IfG RecompileRequired
1458 up_to_date msg = traceHiDiffs msg >> return UpToDate
1459
1460 out_of_date :: String -> SDoc -> IfG RecompileRequired
1461 out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
1462
1463 out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
1464 out_of_date_hash reason msg old_hash new_hash
1465 = out_of_date reason (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1466
1467 ----------------------
1468 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1469 -- This helper is used in two places
1470 checkList [] = return UpToDate
1471 checkList (check:checks) = do recompile <- check
1472 if recompileRequired recompile
1473 then return recompile
1474 else checkList checks
1475
1476 {-
1477 ************************************************************************
1478 * *
1479 Converting things to their Iface equivalents
1480 * *
1481 ************************************************************************
1482 -}
1483
1484 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1485 tyThingToIfaceDecl (AnId id) = idToIfaceDecl id
1486 tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
1487 tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax
1488 tyThingToIfaceDecl (AConLike cl) = case cl of
1489 RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
1490 PatSynCon ps -> patSynToIfaceDecl ps
1491
1492 --------------------------
1493 idToIfaceDecl :: Id -> IfaceDecl
1494 -- The Id is already tidied, so that locally-bound names
1495 -- (lambdas, for-alls) already have non-clashing OccNames
1496 -- We can't tidy it here, locally, because it may have
1497 -- free variables in its type or IdInfo
1498 idToIfaceDecl id
1499 = IfaceId { ifName = getOccName id,
1500 ifType = toIfaceType (idType id),
1501 ifIdDetails = toIfaceIdDetails (idDetails id),
1502 ifIdInfo = toIfaceIdInfo (idInfo id) }
1503
1504 --------------------------
1505 dataConToIfaceDecl :: DataCon -> IfaceDecl
1506 dataConToIfaceDecl dataCon
1507 = IfaceId { ifName = getOccName dataCon,
1508 ifType = toIfaceType (dataConUserType dataCon),
1509 ifIdDetails = IfVanillaId,
1510 ifIdInfo = NoInfo }
1511
1512 --------------------------
1513 patSynToIfaceDecl :: PatSyn -> IfaceDecl
1514 patSynToIfaceDecl ps
1515 = IfacePatSyn { ifName = getOccName . getName $ ps
1516 , ifPatMatcher = to_if_pr (patSynMatcher ps)
1517 , ifPatBuilder = fmap to_if_pr (patSynBuilder ps)
1518 , ifPatIsInfix = patSynIsInfix ps
1519 , ifPatUnivTvs = toIfaceTvBndrs univ_tvs'
1520 , ifPatExTvs = toIfaceTvBndrs ex_tvs'
1521 , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta
1522 , ifPatReqCtxt = tidyToIfaceContext env2 req_theta
1523 , ifPatArgs = map (tidyToIfaceType env2) args
1524 , ifPatTy = tidyToIfaceType env2 rhs_ty
1525 , ifFieldLabels = (patSynFieldLabels ps)
1526 }
1527 where
1528 (univ_tvs, req_theta, ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
1529 (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
1530 (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
1531 to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
1532
1533 --------------------------
1534 coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
1535 -- We *do* tidy Axioms, because they are not (and cannot
1536 -- conveniently be) built in tidy form
1537 coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
1538 , co_ax_role = role })
1539 = IfaceAxiom { ifName = name
1540 , ifTyCon = toIfaceTyCon tycon
1541 , ifRole = role
1542 , ifAxBranches = map (coAxBranchToIfaceBranch tycon
1543 (map coAxBranchLHS branch_list))
1544 branch_list }
1545 where
1546 branch_list = fromBranches branches
1547 name = getOccName ax
1548
1549 -- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
1550 -- to incompatible indices
1551 -- See Note [Storing compatibility] in CoAxiom
1552 coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
1553 coAxBranchToIfaceBranch tc lhs_s
1554 branch@(CoAxBranch { cab_incomps = incomps })
1555 = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
1556 where
1557 iface_incomps = map (expectJust "iface_incomps"
1558 . (flip findIndex lhs_s
1559 . eqTypes)
1560 . coAxBranchLHS) incomps
1561
1562 -- use this one for standalone branches without incompatibles
1563 coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
1564 coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
1565 , cab_roles = roles, cab_rhs = rhs })
1566 = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
1567 , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
1568 , ifaxbRoles = roles
1569 , ifaxbRHS = tidyToIfaceType env1 rhs
1570 , ifaxbIncomps = [] }
1571 where
1572 (env1, tv_bndrs) = tidyTyClTyVarBndrs emptyTidyEnv tvs
1573 -- Don't re-bind in-scope tyvars
1574 -- See Note [CoAxBranch type variables] in CoAxiom
1575
1576 -----------------
1577 tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
1578 -- We *do* tidy TyCons, because they are not (and cannot
1579 -- conveniently be) built in tidy form
1580 -- The returned TidyEnv is the one after tidying the tyConTyVars
1581 tyConToIfaceDecl env tycon
1582 | Just clas <- tyConClass_maybe tycon
1583 = classToIfaceDecl env clas
1584
1585 | Just syn_rhs <- synTyConRhs_maybe tycon
1586 = ( tc_env1
1587 , IfaceSynonym { ifName = getOccName tycon,
1588 ifTyVars = if_tc_tyvars,
1589 ifRoles = tyConRoles tycon,
1590 ifSynRhs = if_syn_type syn_rhs,
1591 ifSynKind = tidyToIfaceType tc_env1 (tyConResKind tycon)
1592 })
1593
1594 | Just fam_flav <- famTyConFlav_maybe tycon
1595 = ( tc_env1
1596 , IfaceFamily { ifName = getOccName tycon,
1597 ifTyVars = if_tc_tyvars,
1598 ifResVar = if_res_var,
1599 ifFamFlav = to_if_fam_flav fam_flav,
1600 ifFamKind = tidyToIfaceType tc_env1 (tyConResKind tycon),
1601 ifFamInj = familyTyConInjectivityInfo tycon
1602 })
1603
1604 | isAlgTyCon tycon
1605 = ( tc_env1
1606 , IfaceData { ifName = getOccName tycon,
1607 ifCType = tyConCType tycon,
1608 ifTyVars = if_tc_tyvars,
1609 ifRoles = tyConRoles tycon,
1610 ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
1611 ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
1612 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
1613 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1614 ifPromotable = isJust (promotableTyCon_maybe tycon),
1615 ifParent = parent })
1616
1617 | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
1618 -- For pretty printing purposes only.
1619 = ( env
1620 , IfaceData { ifName = getOccName tycon,
1621 ifCType = Nothing,
1622 ifTyVars = funAndPrimTyVars,
1623 ifRoles = tyConRoles tycon,
1624 ifCtxt = [],
1625 ifCons = IfDataTyCon [] False [],
1626 ifRec = boolToRecFlag False,
1627 ifGadtSyntax = False,
1628 ifPromotable = False,
1629 ifParent = IfNoParent })
1630 where
1631 (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
1632 if_tc_tyvars = toIfaceTvBndrs tc_tyvars
1633 if_syn_type ty = tidyToIfaceType tc_env1 ty
1634 if_res_var = getFS `fmap` tyConFamilyResVar_maybe tycon
1635
1636 funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars
1637
1638 parent = case tyConFamInstSig_maybe tycon of
1639 Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
1640 (toIfaceTyCon tc)
1641 (tidyToIfaceTcArgs tc_env1 tc ty)
1642 Nothing -> IfNoParent
1643
1644 to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
1645 to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
1646 = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
1647 where defs = fromBranches $ coAxiomBranches ax
1648 ibr = map (coAxBranchToIfaceBranch' tycon) defs
1649 axn = coAxiomName ax
1650 to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
1651 = IfaceClosedSynFamilyTyCon Nothing
1652 to_if_fam_flav AbstractClosedSynFamilyTyCon
1653 = IfaceAbstractClosedSynFamilyTyCon
1654
1655 to_if_fam_flav (BuiltInSynFamTyCon {})
1656 = IfaceBuiltInSynFamTyCon
1657
1658
1659 ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
1660 ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
1661 ifaceConDecls (DataFamilyTyCon {}) _ = IfDataFamTyCon
1662 ifaceConDecls (TupleTyCon { data_con = con }) _ = IfDataTyCon [ifaceConDecl con] False []
1663 ifaceConDecls (AbstractTyCon distinct) _ = IfAbstractTyCon distinct
1664 -- The AbstractTyCon case happens when a TyCon has been trimmed
1665 -- during tidying.
1666 -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
1667 -- for GHCi, when browsing a module, in which case the
1668 -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
1669 -- (Tuple declarations are not serialised into interface files.)
1670
1671 ifaceConDecl data_con
1672 = IfCon { ifConOcc = getOccName (dataConName data_con),
1673 ifConInfix = dataConIsInfix data_con,
1674 ifConWrapper = isJust (dataConWrapId_maybe data_con),
1675 ifConExTvs = toIfaceTvBndrs ex_tvs',
1676 ifConEqSpec = map to_eq_spec eq_spec,
1677 ifConCtxt = tidyToIfaceContext con_env2 theta,
1678 ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
1679 ifConFields = map (nameOccName . flSelector)
1680 (dataConFieldLabels data_con),
1681 ifConStricts = map (toIfaceBang con_env2)
1682 (dataConImplBangs data_con),
1683 ifConSrcStricts = map toIfaceSrcBang
1684 (dataConSrcBangs data_con)}
1685 where
1686 (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
1687
1688 -- Tidy the univ_tvs of the data constructor to be identical
1689 -- to the tyConTyVars of the type constructor. This means
1690 -- (a) we don't need to redundantly put them into the interface file
1691 -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
1692 -- we know that the type variables will line up
1693 -- The latter (b) is important because we pretty-print type constructors
1694 -- by converting to IfaceSyn and pretty-printing that
1695 con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
1696 -- A bit grimy, perhaps, but it's simple!
1697
1698 (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
1699 to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
1700
1701 ifaceOverloaded flds = case fsEnvElts flds of
1702 fl:_ -> flIsOverloaded fl
1703 [] -> False
1704 ifaceFields flds = sort $ map flLabel $ fsEnvElts flds
1705 -- We need to sort the labels because they come out
1706 -- of FastStringEnv in arbitrary order, because
1707 -- FastStringEnv is keyed on Uniques.
1708 -- Sorting FastString is ok here, because Uniques
1709 -- are only used for equality checks in the Ord
1710 -- instance for FastString.
1711 -- See Note [Unique Determinism] in Unique.
1712
1713 toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
1714 toIfaceBang _ HsLazy = IfNoBang
1715 toIfaceBang _ (HsUnpack Nothing) = IfUnpack
1716 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
1717 toIfaceBang _ HsStrict = IfStrict
1718
1719 toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
1720 toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
1721
1722 classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
1723 classToIfaceDecl env clas
1724 = ( env1
1725 , IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
1726 ifName = getOccName (classTyCon clas),
1727 ifTyVars = toIfaceTvBndrs clas_tyvars',
1728 ifRoles = tyConRoles (classTyCon clas),
1729 ifFDs = map toIfaceFD clas_fds,
1730 ifATs = map toIfaceAT clas_ats,
1731 ifSigs = map toIfaceClassOp op_stuff,
1732 ifMinDef = fmap getFS (classMinimalDef clas),
1733 ifRec = boolToRecFlag (isRecursiveTyCon tycon) })
1734 where
1735 (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
1736 = classExtraBigSig clas
1737 tycon = classTyCon clas
1738
1739 (env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars
1740
1741 toIfaceAT :: ClassATItem -> IfaceAT
1742 toIfaceAT (ATI tc def)
1743 = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
1744 where
1745 (env2, if_decl) = tyConToIfaceDecl env1 tc
1746
1747 toIfaceClassOp (sel_id, def_meth)
1748 = ASSERT(sel_tyvars == clas_tyvars)
1749 IfaceClassOp (getOccName sel_id) (toDmSpec def_meth)
1750 (tidyToIfaceType env1 op_ty)
1751 where
1752 -- Be careful when splitting the type, because of things
1753 -- like class Foo a where
1754 -- op :: (?x :: String) => a -> a
1755 -- and class Baz a where
1756 -- op :: (Ord a) => a -> a
1757 (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1758 op_ty = funResultTy rho_ty
1759
1760 toDmSpec NoDefMeth = NoDM
1761 toDmSpec (GenDefMeth _) = GenericDM
1762 toDmSpec (DefMeth _) = VanillaDM
1763
1764 toIfaceFD (tvs1, tvs2) = (map (getFS . tidyTyVar env1) tvs1,
1765 map (getFS . tidyTyVar env1) tvs2)
1766
1767 --------------------------
1768 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
1769 tidyToIfaceType env ty = toIfaceType (tidyType env ty)
1770
1771 tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs
1772 tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
1773
1774 tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
1775 tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
1776
1777 tidyTyClTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
1778 tidyTyClTyVarBndrs env tvs = mapAccumL tidyTyClTyVarBndr env tvs
1779
1780 tidyTyClTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
1781 -- If the type variable "binder" is in scope, don't re-bind it
1782 -- In a class decl, for example, the ATD binders mention
1783 -- (amd must mention) the class tyvars
1784 tidyTyClTyVarBndr env@(_, subst) tv
1785 | Just tv' <- lookupVarEnv subst tv = (env, tv')
1786 | otherwise = tidyTyVarBndr env tv
1787
1788 tidyTyVar :: TidyEnv -> TyVar -> TyVar
1789 tidyTyVar (_, subst) tv = lookupVarEnv subst tv `orElse` tv
1790 -- TcType.tidyTyVarOcc messes around with FlatSkols
1791
1792 getFS :: NamedThing a => a -> FastString
1793 getFS x = occNameFS (getOccName x)
1794
1795 --------------------------
1796 instanceToIfaceInst :: ClsInst -> IfaceClsInst
1797 instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
1798 , is_cls_nm = cls_name, is_cls = cls
1799 , is_tcs = mb_tcs
1800 , is_orphan = orph })
1801 = ASSERT( cls_name == className cls )
1802 IfaceClsInst { ifDFun = dfun_name,
1803 ifOFlag = oflag,
1804 ifInstCls = cls_name,
1805 ifInstTys = map do_rough mb_tcs,
1806 ifInstOrph = orph }
1807 where
1808 do_rough Nothing = Nothing
1809 do_rough (Just n) = Just (toIfaceTyCon_name n)
1810
1811 dfun_name = idName dfun_id
1812
1813
1814 --------------------------
1815 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1816 famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
1817 fi_fam = fam,
1818 fi_tcs = roughs })
1819 = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
1820 , ifFamInstFam = fam
1821 , ifFamInstTys = map do_rough roughs
1822 , ifFamInstOrph = orph }
1823 where
1824 do_rough Nothing = Nothing
1825 do_rough (Just n) = Just (toIfaceTyCon_name n)
1826
1827 fam_decl = tyConName $ coAxiomTyCon axiom
1828 mod = ASSERT( isExternalName (coAxiomName axiom) )
1829 nameModule (coAxiomName axiom)
1830 is_local name = nameIsLocalOrFrom mod name
1831
1832 lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
1833
1834 orph | is_local fam_decl
1835 = NotOrphan (nameOccName fam_decl)
1836 | otherwise
1837 = chooseOrphanAnchor $ nameSetElems lhs_names
1838
1839 --------------------------
1840 toIfaceLetBndr :: Id -> IfaceLetBndr
1841 toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
1842 (toIfaceType (idType id))
1843 (toIfaceIdInfo (idInfo id))
1844 -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr
1845 -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn
1846
1847 --------------------------t
1848 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
1849 toIfaceIdDetails VanillaId = IfVanillaId
1850 toIfaceIdDetails (DFunId {}) = IfDFunId
1851 toIfaceIdDetails (RecSelId { sel_naughty = n
1852 , sel_tycon = tc }) =
1853 let iface = case tc of
1854 RecSelData ty_con -> Left (toIfaceTyCon ty_con)
1855 RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn)
1856 in IfRecSelId iface n
1857
1858 -- Currently we don't persist these three "advisory" IdInfos
1859 -- through interface files. We easily could if it mattered
1860 toIfaceIdDetails PatSynId = IfVanillaId
1861 toIfaceIdDetails ReflectionId = IfVanillaId
1862 toIfaceIdDetails DefMethId = IfVanillaId
1863
1864 -- The remaining cases are all "implicit Ids" which don't
1865 -- appear in interface files at all
1866 toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
1867 IfVanillaId -- Unexpected; the other
1868
1869 toIfaceIdInfo :: IdInfo -> IfaceIdInfo
1870 toIfaceIdInfo id_info
1871 = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
1872 inline_hsinfo, unfold_hsinfo] of
1873 [] -> NoInfo
1874 infos -> HasInfo infos
1875 -- NB: strictness and arity must appear in the list before unfolding
1876 -- See TcIface.tcUnfolding
1877 where
1878 ------------ Arity --------------
1879 arity_info = arityInfo id_info
1880 arity_hsinfo | arity_info == 0 = Nothing
1881 | otherwise = Just (HsArity arity_info)
1882
1883 ------------ Caf Info --------------
1884 caf_info = cafInfo id_info
1885 caf_hsinfo = case caf_info of
1886 NoCafRefs -> Just HsNoCafRefs
1887 _other -> Nothing
1888
1889 ------------ Strictness --------------
1890 -- No point in explicitly exporting TopSig
1891 sig_info = strictnessInfo id_info
1892 strict_hsinfo | not (isNopSig sig_info) = Just (HsStrictness sig_info)
1893 | otherwise = Nothing
1894
1895 ------------ Unfolding --------------
1896 unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
1897 loop_breaker = isStrongLoopBreaker (occInfo id_info)
1898
1899 ------------ Inline prag --------------
1900 inline_prag = inlinePragInfo id_info
1901 inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
1902 | otherwise = Just (HsInline inline_prag)
1903
1904 --------------------------
1905 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
1906 toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
1907 , uf_src = src
1908 , uf_guidance = guidance })
1909 = Just $ HsUnfold lb $
1910 case src of
1911 InlineStable
1912 -> case guidance of
1913 UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
1914 -> IfInlineRule arity unsat_ok boring_ok if_rhs
1915 _other -> IfCoreUnfold True if_rhs
1916 InlineCompulsory -> IfCompulsory if_rhs
1917 InlineRhs -> IfCoreUnfold False if_rhs
1918 -- Yes, even if guidance is UnfNever, expose the unfolding
1919 -- If we didn't want to expose the unfolding, TidyPgm would
1920 -- have stuck in NoUnfolding. For supercompilation we want
1921 -- to see that unfolding!
1922 where
1923 if_rhs = toIfaceExpr rhs
1924
1925 toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
1926 = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
1927 -- No need to serialise the data constructor;
1928 -- we can recover it from the type of the dfun
1929
1930 toIfUnfolding _ _
1931 = Nothing
1932
1933 --------------------------
1934 coreRuleToIfaceRule :: CoreRule -> IfaceRule
1935 coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
1936 = pprTrace "toHsRule: builtin" (ppr fn) $
1937 bogusIfaceRule fn
1938
1939 coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
1940 ru_act = act, ru_bndrs = bndrs,
1941 ru_args = args, ru_rhs = rhs,
1942 ru_orphan = orph, ru_auto = auto })
1943 = IfaceRule { ifRuleName = name, ifActivation = act,
1944 ifRuleBndrs = map toIfaceBndr bndrs,
1945 ifRuleHead = fn,
1946 ifRuleArgs = map do_arg args,
1947 ifRuleRhs = toIfaceExpr rhs,
1948 ifRuleAuto = auto,
1949 ifRuleOrph = orph }
1950 where
1951 -- For type args we must remove synonyms from the outermost
1952 -- level. Reason: so that when we read it back in we'll
1953 -- construct the same ru_rough field as we have right now;
1954 -- see tcIfaceRule
1955 do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1956 do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
1957 do_arg arg = toIfaceExpr arg
1958
1959 bogusIfaceRule :: Name -> IfaceRule
1960 bogusIfaceRule id_name
1961 = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
1962 ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
1963 ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
1964 ifRuleAuto = True }
1965
1966 ---------------------
1967 toIfaceExpr :: CoreExpr -> IfaceExpr
1968 toIfaceExpr (Var v) = toIfaceVar v
1969 toIfaceExpr (Lit l) = IfaceLit l
1970 toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
1971 toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co)
1972 toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
1973 toIfaceExpr (App f a) = toIfaceApp f [a]
1974 toIfaceExpr (Case s x ty as)
1975 | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
1976 | otherwise = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
1977 toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1978 toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
1979 toIfaceExpr (Tick t e)
1980 | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)
1981 | otherwise = toIfaceExpr e
1982
1983 toIfaceOneShot :: Id -> IfaceOneShot
1984 toIfaceOneShot id | isId id
1985 , OneShotLam <- oneShotInfo (idInfo id)
1986 = IfaceOneShot
1987 | otherwise
1988 = IfaceNoOneShot
1989
1990 ---------------------
1991 toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
1992 toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
1993 toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix)
1994 toIfaceTickish (SourceNote src names) = Just (IfaceSource src names)
1995 toIfaceTickish (Breakpoint {}) = Nothing
1996 -- Ignore breakpoints, since they are relevant only to GHCi, and
1997 -- should not be serialised (Trac #8333)
1998
1999 ---------------------
2000 toIfaceBind :: Bind Id -> IfaceBinding
2001 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
2002 toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
2003
2004 ---------------------
2005 toIfaceAlt :: (AltCon, [Var], CoreExpr)
2006 -> (IfaceConAlt, [FastString], IfaceExpr)
2007 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
2008
2009 ---------------------
2010 toIfaceCon :: AltCon -> IfaceConAlt
2011 toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
2012 toIfaceCon (LitAlt l) = IfaceLitAlt l
2013 toIfaceCon DEFAULT = IfaceDefault
2014
2015 ---------------------
2016 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
2017 toIfaceApp (App f a) as = toIfaceApp f (a:as)
2018 toIfaceApp (Var v) as
2019 = case isDataConWorkId_maybe v of
2020 -- We convert the *worker* for tuples into IfaceTuples
2021 Just dc | saturated
2022 , Just tup_sort <- tyConTuple_maybe tc
2023 -> IfaceTuple tup_sort tup_args
2024 where
2025 val_args = dropWhile isTypeArg as
2026 saturated = val_args `lengthIs` idArity v
2027 tup_args = map toIfaceExpr val_args
2028 tc = dataConTyCon dc
2029
2030 _ -> mkIfaceApps (toIfaceVar v) as
2031
2032 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
2033
2034 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
2035 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
2036
2037 ---------------------
2038 toIfaceVar :: Id -> IfaceExpr
2039 toIfaceVar v
2040 | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
2041 -- Foreign calls have special syntax
2042 | isExternalName name = IfaceExt name
2043 | otherwise = IfaceLcl (getFS name)
2044 where name = idName v