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