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