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