Filter orphan rules based on imports, fixes #10294 and #10420.
[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_boot = is_boot,
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 is_boot 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 == HsBootFile) 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 -> IsBootInterface
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 is_boot 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_boot = is_boot,
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 snd pkg)
1335 let reason = moduleNameString mod ++ " changed"
1336 case find_res of
1337 Found _ mod
1338 | pkg == this_pkg
1339 -> if moduleName mod `notElem` map fst prev_dep_mods
1340 then do traceHiDiffs $
1341 text "imported module " <> quotes (ppr mod) <>
1342 text " not among previous dependencies"
1343 return (RecompBecause reason)
1344 else
1345 return UpToDate
1346 | otherwise
1347 -> if pkg `notElem` (map fst prev_dep_pkgs)
1348 then do traceHiDiffs $
1349 text "imported module " <> quotes (ppr mod) <>
1350 text " is from package " <> quotes (ppr pkg) <>
1351 text ", which is not among previous dependencies"
1352 return (RecompBecause reason)
1353 else
1354 return UpToDate
1355 where pkg = modulePackageKey mod
1356 _otherwise -> return (RecompBecause reason)
1357
1358 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1359 -> IfG RecompileRequired
1360 needInterface mod continue
1361 = do -- Load the imported interface if possible
1362 let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1363 traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1364
1365 mb_iface <- loadInterface doc_str mod ImportBySystem
1366 -- Load the interface, but don't complain on failure;
1367 -- Instead, get an Either back which we can test
1368
1369 case mb_iface of
1370 Failed _ -> do
1371 traceHiDiffs (sep [ptext (sLit "Couldn't load interface for module"),
1372 ppr mod])
1373 return MustCompile
1374 -- Couldn't find or parse a module mentioned in the
1375 -- old interface file. Don't complain: it might
1376 -- just be that the current module doesn't need that
1377 -- import and it's been deleted
1378 Succeeded iface -> continue iface
1379
1380
1381 -- | Given the usage information extracted from the old
1382 -- M.hi file for the module being compiled, figure out
1383 -- whether M needs to be recompiled.
1384 checkModUsage :: PackageKey -> Usage -> IfG RecompileRequired
1385 checkModUsage _this_pkg UsagePackageModule{
1386 usg_mod = mod,
1387 usg_mod_hash = old_mod_hash }
1388 = needInterface mod $ \iface -> do
1389 let reason = moduleNameString (moduleName mod) ++ " changed"
1390 checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
1391 -- We only track the ABI hash of package modules, rather than
1392 -- individual entity usages, so if the ABI hash changes we must
1393 -- recompile. This is safe but may entail more recompilation when
1394 -- a dependent package has changed.
1395
1396 checkModUsage this_pkg UsageHomeModule{
1397 usg_mod_name = mod_name,
1398 usg_mod_hash = old_mod_hash,
1399 usg_exports = maybe_old_export_hash,
1400 usg_entities = old_decl_hash }
1401 = do
1402 let mod = mkModule this_pkg mod_name
1403 needInterface mod $ \iface -> do
1404
1405 let
1406 new_mod_hash = mi_mod_hash iface
1407 new_decl_hash = mi_hash_fn iface
1408 new_export_hash = mi_exp_hash iface
1409
1410 reason = moduleNameString mod_name ++ " changed"
1411
1412 -- CHECK MODULE
1413 recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
1414 if not (recompileRequired recompile)
1415 then return UpToDate
1416 else do
1417
1418 -- CHECK EXPORT LIST
1419 checkMaybeHash reason maybe_old_export_hash new_export_hash
1420 (ptext (sLit " Export list changed")) $ do
1421
1422 -- CHECK ITEMS ONE BY ONE
1423 recompile <- checkList [ checkEntityUsage reason new_decl_hash u
1424 | u <- old_decl_hash]
1425 if recompileRequired recompile
1426 then return recompile -- This one failed, so just bail out now
1427 else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
1428
1429
1430 checkModUsage _this_pkg UsageFile{ usg_file_path = file,
1431 usg_file_hash = old_hash } =
1432 liftIO $
1433 handleIO handle $ do
1434 new_hash <- getFileHash file
1435 if (old_hash /= new_hash)
1436 then return recomp
1437 else return UpToDate
1438 where
1439 recomp = RecompBecause (file ++ " changed")
1440 handle =
1441 #ifdef DEBUG
1442 \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
1443 #else
1444 \_ -> return recomp -- if we can't find the file, just recompile, don't fail
1445 #endif
1446
1447 ------------------------
1448 checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
1449 -> IfG RecompileRequired
1450 checkModuleFingerprint reason old_mod_hash new_mod_hash
1451 | new_mod_hash == old_mod_hash
1452 = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1453
1454 | otherwise
1455 = out_of_date_hash reason (ptext (sLit " Module fingerprint has changed"))
1456 old_mod_hash new_mod_hash
1457
1458 ------------------------
1459 checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
1460 -> IfG RecompileRequired -> IfG RecompileRequired
1461 checkMaybeHash reason maybe_old_hash new_hash doc continue
1462 | Just hash <- maybe_old_hash, hash /= new_hash
1463 = out_of_date_hash reason doc hash new_hash
1464 | otherwise
1465 = continue
1466
1467 ------------------------
1468 checkEntityUsage :: String
1469 -> (OccName -> Maybe (OccName, Fingerprint))
1470 -> (OccName, Fingerprint)
1471 -> IfG RecompileRequired
1472 checkEntityUsage reason new_hash (name,old_hash)
1473 = case new_hash name of
1474
1475 Nothing -> -- We used it before, but it ain't there now
1476 out_of_date reason (sep [ptext (sLit "No longer exported:"), ppr name])
1477
1478 Just (_, new_hash) -- It's there, but is it up to date?
1479 | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
1480 return UpToDate
1481 | otherwise -> out_of_date_hash reason (ptext (sLit " Out of date:") <+> ppr name)
1482 old_hash new_hash
1483
1484 up_to_date :: SDoc -> IfG RecompileRequired
1485 up_to_date msg = traceHiDiffs msg >> return UpToDate
1486
1487 out_of_date :: String -> SDoc -> IfG RecompileRequired
1488 out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
1489
1490 out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
1491 out_of_date_hash reason msg old_hash new_hash
1492 = out_of_date reason (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1493
1494 ----------------------
1495 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1496 -- This helper is used in two places
1497 checkList [] = return UpToDate
1498 checkList (check:checks) = do recompile <- check
1499 if recompileRequired recompile
1500 then return recompile
1501 else checkList checks
1502
1503 {-
1504 ************************************************************************
1505 * *
1506 Converting things to their Iface equivalents
1507 * *
1508 ************************************************************************
1509 -}
1510
1511 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1512 tyThingToIfaceDecl (AnId id) = idToIfaceDecl id
1513 tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
1514 tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax
1515 tyThingToIfaceDecl (AConLike cl) = case cl of
1516 RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
1517 PatSynCon ps -> patSynToIfaceDecl ps
1518
1519 --------------------------
1520 idToIfaceDecl :: Id -> IfaceDecl
1521 -- The Id is already tidied, so that locally-bound names
1522 -- (lambdas, for-alls) already have non-clashing OccNames
1523 -- We can't tidy it here, locally, because it may have
1524 -- free variables in its type or IdInfo
1525 idToIfaceDecl id
1526 = IfaceId { ifName = getOccName id,
1527 ifType = toIfaceType (idType id),
1528 ifIdDetails = toIfaceIdDetails (idDetails id),
1529 ifIdInfo = toIfaceIdInfo (idInfo id) }
1530
1531 --------------------------
1532 dataConToIfaceDecl :: DataCon -> IfaceDecl
1533 dataConToIfaceDecl dataCon
1534 = IfaceId { ifName = getOccName dataCon,
1535 ifType = toIfaceType (dataConUserType dataCon),
1536 ifIdDetails = IfVanillaId,
1537 ifIdInfo = NoInfo }
1538
1539 --------------------------
1540 patSynToIfaceDecl :: PatSyn -> IfaceDecl
1541 patSynToIfaceDecl ps
1542 = IfacePatSyn { ifName = getOccName . getName $ ps
1543 , ifPatMatcher = to_if_pr (patSynMatcher ps)
1544 , ifPatBuilder = fmap to_if_pr (patSynBuilder ps)
1545 , ifPatIsInfix = patSynIsInfix ps
1546 , ifPatUnivTvs = toIfaceTvBndrs univ_tvs'
1547 , ifPatExTvs = toIfaceTvBndrs ex_tvs'
1548 , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta
1549 , ifPatReqCtxt = tidyToIfaceContext env2 req_theta
1550 , ifPatArgs = map (tidyToIfaceType env2) args
1551 , ifPatTy = tidyToIfaceType env2 rhs_ty
1552 }
1553 where
1554 (univ_tvs, ex_tvs, prov_theta, req_theta, args, rhs_ty) = patSynSig ps
1555 (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
1556 (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
1557 to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
1558
1559 --------------------------
1560 coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
1561 -- We *do* tidy Axioms, because they are not (and cannot
1562 -- conveniently be) built in tidy form
1563 coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
1564 , co_ax_role = role })
1565 = IfaceAxiom { ifName = name
1566 , ifTyCon = toIfaceTyCon tycon
1567 , ifRole = role
1568 , ifAxBranches = brListMap (coAxBranchToIfaceBranch tycon
1569 (brListMap coAxBranchLHS branches))
1570 branches }
1571 where
1572 name = getOccName ax
1573
1574 -- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
1575 -- to incompatible indices
1576 -- See Note [Storing compatibility] in CoAxiom
1577 coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
1578 coAxBranchToIfaceBranch tc lhs_s
1579 branch@(CoAxBranch { cab_incomps = incomps })
1580 = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
1581 where
1582 iface_incomps = map (expectJust "iface_incomps"
1583 . (flip findIndex lhs_s
1584 . eqTypes)
1585 . coAxBranchLHS) incomps
1586
1587 -- use this one for standalone branches without incompatibles
1588 coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
1589 coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
1590 , cab_roles = roles, cab_rhs = rhs })
1591 = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
1592 , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
1593 , ifaxbRoles = roles
1594 , ifaxbRHS = tidyToIfaceType env1 rhs
1595 , ifaxbIncomps = [] }
1596 where
1597 (env1, tv_bndrs) = tidyTyClTyVarBndrs emptyTidyEnv tvs
1598 -- Don't re-bind in-scope tyvars
1599 -- See Note [CoAxBranch type variables] in CoAxiom
1600
1601 -----------------
1602 tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
1603 -- We *do* tidy TyCons, because they are not (and cannot
1604 -- conveniently be) built in tidy form
1605 -- The returned TidyEnv is the one after tidying the tyConTyVars
1606 tyConToIfaceDecl env tycon
1607 | Just clas <- tyConClass_maybe tycon
1608 = classToIfaceDecl env clas
1609
1610 | Just syn_rhs <- synTyConRhs_maybe tycon
1611 = ( tc_env1
1612 , IfaceSynonym { ifName = getOccName tycon,
1613 ifTyVars = if_tc_tyvars,
1614 ifRoles = tyConRoles tycon,
1615 ifSynRhs = if_syn_type syn_rhs,
1616 ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon)
1617 })
1618
1619 | Just fam_flav <- famTyConFlav_maybe tycon
1620 = ( tc_env1
1621 , IfaceFamily { ifName = getOccName tycon,
1622 ifTyVars = if_tc_tyvars,
1623 ifFamFlav = to_if_fam_flav fam_flav,
1624 ifFamKind = tidyToIfaceType tc_env1 (synTyConResKind tycon)
1625 })
1626
1627 | isAlgTyCon tycon
1628 = ( tc_env1
1629 , IfaceData { ifName = getOccName tycon,
1630 ifCType = tyConCType tycon,
1631 ifTyVars = if_tc_tyvars,
1632 ifRoles = tyConRoles tycon,
1633 ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
1634 ifCons = ifaceConDecls (algTyConRhs tycon),
1635 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
1636 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1637 ifPromotable = isJust (promotableTyCon_maybe tycon),
1638 ifParent = parent })
1639
1640 | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
1641 -- For pretty printing purposes only.
1642 = ( env
1643 , IfaceData { ifName = getOccName tycon,
1644 ifCType = Nothing,
1645 ifTyVars = funAndPrimTyVars,
1646 ifRoles = tyConRoles tycon,
1647 ifCtxt = [],
1648 ifCons = IfDataTyCon [],
1649 ifRec = boolToRecFlag False,
1650 ifGadtSyntax = False,
1651 ifPromotable = False,
1652 ifParent = IfNoParent })
1653 where
1654 (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
1655 if_tc_tyvars = toIfaceTvBndrs tc_tyvars
1656 if_syn_type ty = tidyToIfaceType tc_env1 ty
1657
1658 funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars
1659
1660 parent = case tyConFamInstSig_maybe tycon of
1661 Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
1662 (toIfaceTyCon tc)
1663 (tidyToIfaceTcArgs tc_env1 tc ty)
1664 Nothing -> IfNoParent
1665
1666 to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
1667 to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
1668 = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
1669 where defs = fromBranchList $ coAxiomBranches ax
1670 ibr = map (coAxBranchToIfaceBranch' tycon) defs
1671 axn = coAxiomName ax
1672 to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
1673 = IfaceClosedSynFamilyTyCon Nothing
1674 to_if_fam_flav AbstractClosedSynFamilyTyCon
1675 = IfaceAbstractClosedSynFamilyTyCon
1676
1677 to_if_fam_flav (BuiltInSynFamTyCon {})
1678 = IfaceBuiltInSynFamTyCon
1679
1680
1681 ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
1682 ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
1683 ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon
1684 ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con]
1685 ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct
1686 -- The AbstractTyCon case happens when a TyCon has been trimmed
1687 -- during tidying.
1688 -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
1689 -- for GHCi, when browsing a module, in which case the
1690 -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
1691 -- (Tuple declarations are not serialised into interface files.)
1692
1693 ifaceConDecl data_con
1694 = IfCon { ifConOcc = getOccName (dataConName data_con),
1695 ifConInfix = dataConIsInfix data_con,
1696 ifConWrapper = isJust (dataConWrapId_maybe data_con),
1697 ifConExTvs = toIfaceTvBndrs ex_tvs',
1698 ifConEqSpec = map to_eq_spec eq_spec,
1699 ifConCtxt = tidyToIfaceContext con_env2 theta,
1700 ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
1701 ifConFields = map getOccName
1702 (dataConFieldLabels data_con),
1703 ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con) }
1704 where
1705 (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
1706
1707 -- Tidy the univ_tvs of the data constructor to be identical
1708 -- to the tyConTyVars of the type constructor. This means
1709 -- (a) we don't need to redundantly put them into the interface file
1710 -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
1711 -- we know that the type variables will line up
1712 -- The latter (b) is important because we pretty-print type constructors
1713 -- by converting to IfaceSyn and pretty-printing that
1714 con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
1715 -- A bit grimy, perhaps, but it's simple!
1716
1717 (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
1718 to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
1719
1720 toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
1721 toIfaceBang _ HsNoBang = IfNoBang
1722 toIfaceBang _ (HsUnpack Nothing) = IfUnpack
1723 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
1724 toIfaceBang _ HsStrict = IfStrict
1725 toIfaceBang _ (HsSrcBang {}) = panic "toIfaceBang"
1726
1727 classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
1728 classToIfaceDecl env clas
1729 = ( env1
1730 , IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
1731 ifName = getOccName (classTyCon clas),
1732 ifTyVars = toIfaceTvBndrs clas_tyvars',
1733 ifRoles = tyConRoles (classTyCon clas),
1734 ifFDs = map toIfaceFD clas_fds,
1735 ifATs = map toIfaceAT clas_ats,
1736 ifSigs = map toIfaceClassOp op_stuff,
1737 ifMinDef = fmap getFS (classMinimalDef clas),
1738 ifRec = boolToRecFlag (isRecursiveTyCon tycon) })
1739 where
1740 (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
1741 = classExtraBigSig clas
1742 tycon = classTyCon clas
1743
1744 (env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars
1745
1746 toIfaceAT :: ClassATItem -> IfaceAT
1747 toIfaceAT (ATI tc def)
1748 = IfaceAT if_decl (fmap (tidyToIfaceType env2) def)
1749 where
1750 (env2, if_decl) = tyConToIfaceDecl env1 tc
1751
1752 toIfaceClassOp (sel_id, def_meth)
1753 = ASSERT(sel_tyvars == clas_tyvars)
1754 IfaceClassOp (getOccName sel_id) (toDmSpec def_meth)
1755 (tidyToIfaceType env1 op_ty)
1756 where
1757 -- Be careful when splitting the type, because of things
1758 -- like class Foo a where
1759 -- op :: (?x :: String) => a -> a
1760 -- and class Baz a where
1761 -- op :: (Ord a) => a -> a
1762 (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1763 op_ty = funResultTy rho_ty
1764
1765 toDmSpec NoDefMeth = NoDM
1766 toDmSpec (GenDefMeth _) = GenericDM
1767 toDmSpec (DefMeth _) = VanillaDM
1768
1769 toIfaceFD (tvs1, tvs2) = (map (getFS . tidyTyVar env1) tvs1,
1770 map (getFS . tidyTyVar env1) tvs2)
1771
1772 --------------------------
1773 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
1774 tidyToIfaceType env ty = toIfaceType (tidyType env ty)
1775
1776 tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs
1777 tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
1778
1779 tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
1780 tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
1781
1782 tidyTyClTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
1783 tidyTyClTyVarBndrs env tvs = mapAccumL tidyTyClTyVarBndr env tvs
1784
1785 tidyTyClTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
1786 -- If the type variable "binder" is in scope, don't re-bind it
1787 -- In a class decl, for example, the ATD binders mention
1788 -- (amd must mention) the class tyvars
1789 tidyTyClTyVarBndr env@(_, subst) tv
1790 | Just tv' <- lookupVarEnv subst tv = (env, tv')
1791 | otherwise = tidyTyVarBndr env tv
1792
1793 tidyTyVar :: TidyEnv -> TyVar -> TyVar
1794 tidyTyVar (_, subst) tv = lookupVarEnv subst tv `orElse` tv
1795 -- TcType.tidyTyVarOcc messes around with FlatSkols
1796
1797 getFS :: NamedThing a => a -> FastString
1798 getFS x = occNameFS (getOccName x)
1799
1800 --------------------------
1801 instanceToIfaceInst :: ClsInst -> IfaceClsInst
1802 instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
1803 , is_cls_nm = cls_name, is_cls = cls
1804 , is_tcs = mb_tcs
1805 , is_orphan = orph })
1806 = ASSERT( cls_name == className cls )
1807 IfaceClsInst { ifDFun = dfun_name,
1808 ifOFlag = oflag,
1809 ifInstCls = cls_name,
1810 ifInstTys = map do_rough mb_tcs,
1811 ifInstOrph = orph }
1812 where
1813 do_rough Nothing = Nothing
1814 do_rough (Just n) = Just (toIfaceTyCon_name n)
1815
1816 dfun_name = idName dfun_id
1817
1818
1819 --------------------------
1820 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1821 famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
1822 fi_fam = fam,
1823 fi_tcs = roughs })
1824 = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
1825 , ifFamInstFam = fam
1826 , ifFamInstTys = map do_rough roughs
1827 , ifFamInstOrph = orph }
1828 where
1829 do_rough Nothing = Nothing
1830 do_rough (Just n) = Just (toIfaceTyCon_name n)
1831
1832 fam_decl = tyConName $ coAxiomTyCon axiom
1833 mod = ASSERT( isExternalName (coAxiomName axiom) )
1834 nameModule (coAxiomName axiom)
1835 is_local name = nameIsLocalOrFrom mod name
1836
1837 lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
1838
1839 orph | is_local fam_decl
1840 = NotOrphan (nameOccName fam_decl)
1841
1842 | not (isEmptyNameSet lhs_names)
1843 = NotOrphan (nameOccName (head (nameSetElems lhs_names)))
1844
1845
1846 | otherwise
1847 = IsOrphan
1848
1849 --------------------------
1850 toIfaceLetBndr :: Id -> IfaceLetBndr
1851 toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
1852 (toIfaceType (idType id))
1853 (toIfaceIdInfo (idInfo id))
1854 -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr
1855 -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn
1856
1857 --------------------------
1858 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
1859 toIfaceIdDetails VanillaId = IfVanillaId
1860 toIfaceIdDetails (DFunId {}) = IfDFunId
1861 toIfaceIdDetails (RecSelId { sel_naughty = n
1862 , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
1863 toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
1864 IfVanillaId -- Unexpected
1865
1866 toIfaceIdInfo :: IdInfo -> IfaceIdInfo
1867 toIfaceIdInfo id_info
1868 = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
1869 inline_hsinfo, unfold_hsinfo] of
1870 [] -> NoInfo
1871 infos -> HasInfo infos
1872 -- NB: strictness and arity must appear in the list before unfolding
1873 -- See TcIface.tcUnfolding
1874 where
1875 ------------ Arity --------------
1876 arity_info = arityInfo id_info
1877 arity_hsinfo | arity_info == 0 = Nothing
1878 | otherwise = Just (HsArity arity_info)
1879
1880 ------------ Caf Info --------------
1881 caf_info = cafInfo id_info
1882 caf_hsinfo = case caf_info of
1883 NoCafRefs -> Just HsNoCafRefs
1884 _other -> Nothing
1885
1886 ------------ Strictness --------------
1887 -- No point in explicitly exporting TopSig
1888 sig_info = strictnessInfo id_info
1889 strict_hsinfo | not (isNopSig sig_info) = Just (HsStrictness sig_info)
1890 | otherwise = Nothing
1891
1892 ------------ Unfolding --------------
1893 unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
1894 loop_breaker = isStrongLoopBreaker (occInfo id_info)
1895
1896 ------------ Inline prag --------------
1897 inline_prag = inlinePragInfo id_info
1898 inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
1899 | otherwise = Just (HsInline inline_prag)
1900
1901 --------------------------
1902 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
1903 toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
1904 , uf_src = src
1905 , uf_guidance = guidance })
1906 = Just $ HsUnfold lb $
1907 case src of
1908 InlineStable
1909 -> case guidance of
1910 UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
1911 -> IfInlineRule arity unsat_ok boring_ok if_rhs
1912 _other -> IfCoreUnfold True if_rhs
1913 InlineCompulsory -> IfCompulsory if_rhs
1914 InlineRhs -> IfCoreUnfold False if_rhs
1915 -- Yes, even if guidance is UnfNever, expose the unfolding
1916 -- If we didn't want to expose the unfolding, TidyPgm would
1917 -- have stuck in NoUnfolding. For supercompilation we want
1918 -- to see that unfolding!
1919 where
1920 if_rhs = toIfaceExpr rhs
1921
1922 toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
1923 = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
1924 -- No need to serialise the data constructor;
1925 -- we can recover it from the type of the dfun
1926
1927 toIfUnfolding _ _
1928 = Nothing
1929
1930 --------------------------
1931 coreRuleToIfaceRule :: CoreRule -> IfaceRule
1932 coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
1933 = pprTrace "toHsRule: builtin" (ppr fn) $
1934 bogusIfaceRule fn
1935
1936 coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
1937 ru_act = act, ru_bndrs = bndrs,
1938 ru_args = args, ru_rhs = rhs,
1939 ru_orphan = orph, ru_auto = auto })
1940 = IfaceRule { ifRuleName = name, ifActivation = act,
1941 ifRuleBndrs = map toIfaceBndr bndrs,
1942 ifRuleHead = fn,
1943 ifRuleArgs = map do_arg args,
1944 ifRuleRhs = toIfaceExpr rhs,
1945 ifRuleAuto = auto,
1946 ifRuleOrph = orph }
1947 where
1948 -- For type args we must remove synonyms from the outermost
1949 -- level. Reason: so that when we read it back in we'll
1950 -- construct the same ru_rough field as we have right now;
1951 -- see tcIfaceRule
1952 do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1953 do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
1954 do_arg arg = toIfaceExpr arg
1955
1956 bogusIfaceRule :: Name -> IfaceRule
1957 bogusIfaceRule id_name
1958 = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
1959 ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
1960 ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
1961 ifRuleAuto = True }
1962
1963 ---------------------
1964 toIfaceExpr :: CoreExpr -> IfaceExpr
1965 toIfaceExpr (Var v) = toIfaceVar v
1966 toIfaceExpr (Lit l) = IfaceLit l
1967 toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
1968 toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co)
1969 toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
1970 toIfaceExpr (App f a) = toIfaceApp f [a]
1971 toIfaceExpr (Case s x ty as)
1972 | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
1973 | otherwise = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
1974 toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1975 toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
1976 toIfaceExpr (Tick t e)
1977 | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)
1978 | otherwise = toIfaceExpr e
1979
1980 toIfaceOneShot :: Id -> IfaceOneShot
1981 toIfaceOneShot id | isId id
1982 , OneShotLam <- oneShotInfo (idInfo id)
1983 = IfaceOneShot
1984 | otherwise
1985 = IfaceNoOneShot
1986
1987 ---------------------
1988 toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
1989 toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
1990 toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix)
1991 toIfaceTickish (SourceNote src names) = Just (IfaceSource src names)
1992 toIfaceTickish (Breakpoint {}) = Nothing
1993 -- Ignore breakpoints, since they are relevant only to GHCi, and
1994 -- should not be serialised (Trac #8333)
1995
1996 ---------------------
1997 toIfaceBind :: Bind Id -> IfaceBinding
1998 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
1999 toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
2000
2001 ---------------------
2002 toIfaceAlt :: (AltCon, [Var], CoreExpr)
2003 -> (IfaceConAlt, [FastString], IfaceExpr)
2004 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
2005
2006 ---------------------
2007 toIfaceCon :: AltCon -> IfaceConAlt
2008 toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
2009 toIfaceCon (LitAlt l) = IfaceLitAlt l
2010 toIfaceCon DEFAULT = IfaceDefault
2011
2012 ---------------------
2013 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
2014 toIfaceApp (App f a) as = toIfaceApp f (a:as)
2015 toIfaceApp (Var v) as
2016 = case isDataConWorkId_maybe v of
2017 -- We convert the *worker* for tuples into IfaceTuples
2018 Just dc | saturated
2019 , Just tup_sort <- tyConTuple_maybe tc
2020 -> IfaceTuple tup_sort tup_args
2021 where
2022 val_args = dropWhile isTypeArg as
2023 saturated = val_args `lengthIs` idArity v
2024 tup_args = map toIfaceExpr val_args
2025 tc = dataConTyCon dc
2026
2027 _ -> mkIfaceApps (toIfaceVar v) as
2028
2029 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
2030
2031 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
2032 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
2033
2034 ---------------------
2035 toIfaceVar :: Id -> IfaceExpr
2036 toIfaceVar v
2037 | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
2038 -- Foreign calls have special syntax
2039 | isExternalName name = IfaceExt name
2040 | otherwise = IfaceLcl (getFS name)
2041 where name = idName v