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