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