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