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