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