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