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