2 % (c) The University of Glasgow 2006-2008
3 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
10 mkIface, -- Build a ModIface from a ModGuts,
11 -- including computing version information
15 writeIfaceFile, -- Write the interface file
17 checkOldIface, -- See if recompilation is required, by
18 -- comparing version information
20 tyThingToIfaceDecl -- Converting things to their Iface equivalents
24 -----------------------------------------------
25 Recompilation checking
26 -----------------------------------------------
28 A complete description of how recompilation checking works can be
29 found in the wiki commentary:
31 http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
33 Please read the above page for a top-down description of how this all
34 works. Notes below cover specific issues related to the implementation.
38 * In the mi_usages information in an interface, we record the
39 fingerprint of each free variable of the module
41 * In mkIface, we compute the fingerprint of each exported thing A.f.
42 For each external thing that A.f refers to, we include the fingerprint
43 of the external reference when computing the fingerprint of A.f. So
44 if anything that A.f depends on changes, then A.f's fingerprint will
47 * In checkOldIface we compare the mi_usages for the module with
48 the actual fingerprint for all each thing recorded in mi_usages
51 #include "HsVersions.h"
86 import BasicTypes hiding ( SuccessFlag(..) )
89 import Util hiding ( eqListBy )
102 import System.FilePath
103 import System.Exit ( exitWith, ExitCode(..) )
108 %************************************************************************
110 \subsection{Completing an interface}
112 %************************************************************************
116 -> Maybe Fingerprint -- The old fingerprint, if we have it
117 -> ModDetails -- The trimmed, tidied interface
118 -> ModGuts -- Usages, deprecations, etc
119 -> IO (ModIface, -- The new one
120 Bool) -- True <=> there was an old Iface, and the
121 -- new one is identical, so no need
124 mkIface hsc_env maybe_old_fingerprint mod_details
125 ModGuts{ mg_module = this_mod,
127 mg_used_names = used_names,
129 mg_dir_imps = dir_imp_mods,
130 mg_rdr_env = rdr_env,
131 mg_fix_env = fix_env,
133 mg_hpc_info = hpc_info }
134 = mkIface_ hsc_env maybe_old_fingerprint
135 this_mod is_boot used_names deps rdr_env
136 fix_env warns hpc_info dir_imp_mods mod_details
138 -- | make an interface from the results of typechecking only. Useful
139 -- for non-optimising compilation, or where we aren't generating any
140 -- object code at all ('HscNothing').
142 -> Maybe Fingerprint -- The old fingerprint, if we have it
143 -> ModDetails -- gotten from mkBootModDetails, probably
144 -> TcGblEnv -- Usages, deprecations, etc
147 mkIfaceTc hsc_env maybe_old_fingerprint mod_details
148 tc_result@TcGblEnv{ tcg_mod = this_mod,
150 tcg_imports = imports,
151 tcg_rdr_env = rdr_env,
152 tcg_fix_env = fix_env,
154 tcg_hpc = other_hpc_info
157 used_names <- mkUsedNames tc_result
158 deps <- mkDependencies tc_result
159 let hpc_info = emptyHpcInfo other_hpc_info
160 mkIface_ hsc_env maybe_old_fingerprint
161 this_mod (isHsBoot hsc_src) used_names deps rdr_env
162 fix_env warns hpc_info (imp_mods imports) mod_details
165 mkUsedNames :: TcGblEnv -> IO NameSet
167 TcGblEnv{ tcg_inst_uses = dfun_uses_var,
171 dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
172 return (allUses dus `unionNameSets` dfun_uses)
174 mkDependencies :: TcGblEnv -> IO Dependencies
176 TcGblEnv{ tcg_mod = mod,
177 tcg_imports = imports,
181 th_used <- readIORef th_var -- Whether TH is used
183 dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
184 -- M.hi-boot can be in the imp_dep_mods, but we must remove
185 -- it before recording the modules on which this one depends!
186 -- (We want to retain M.hi-boot in imp_dep_mods so that
187 -- loadHiBootInterface can see if M's direct imports depend
188 -- on M.hi-boot, and hence that we should do the hi-boot consistency
191 -- Modules don't compare lexicographically usually,
192 -- but we want them to do so here.
193 le_mod :: Module -> Module -> Bool
194 le_mod m1 m2 = moduleNameFS (moduleName m1)
195 <= moduleNameFS (moduleName m2)
197 le_dep_mod :: (ModuleName, IsBootInterface)
198 -> (ModuleName, IsBootInterface) -> Bool
199 le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
202 pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
203 | otherwise = imp_dep_pkgs imports
205 return Deps { dep_mods = sortLe le_dep_mod dep_mods,
206 dep_pkgs = sortLe (<=) pkgs,
207 dep_orphs = sortLe le_mod (imp_orphs imports),
208 dep_finsts = sortLe le_mod (imp_finsts imports) }
209 -- sort to get into canonical order
212 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
213 -> NameSet -> Dependencies -> GlobalRdrEnv
214 -> NameEnv FixItem -> Warnings -> HpcInfo
217 -> IO (ModIface, Bool)
218 mkIface_ hsc_env maybe_old_fingerprint
219 this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
221 ModDetails{ md_insts = insts,
222 md_fam_insts = fam_insts,
225 md_vect_info = vect_info,
227 md_exports = exports }
228 -- NB: notice that mkIface does not look at the bindings
229 -- only at the TypeEnv. The previous Tidy phase has
230 -- put exactly the info into the TypeEnv that we want
231 -- to expose in the interface
233 = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
235 ; let { entities = typeEnvElts type_env ;
236 decls = [ tyThingToIfaceDecl entity
237 | entity <- entities,
238 let name = getName entity,
239 not (isImplicitTyThing entity),
240 -- No implicit Ids and class tycons in the interface file
241 not (isWiredInName name),
242 -- Nor wired-in things; the compiler knows about them anyhow
243 nameIsLocalOrFrom this_mod name ]
244 -- Sigh: see Note [Root-main Id] in TcRnDriver
246 ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
248 ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
249 ; iface_insts = map instanceToIfaceInst insts
250 ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
251 ; iface_vect_info = flattenVectInfo vect_info
253 ; intermediate_iface = ModIface {
254 mi_module = this_mod,
258 mi_exports = mkIfaceExports exports,
260 -- Sort these lexicographically, so that
261 -- the result is stable across compilations
262 mi_insts = sortLe le_inst iface_insts,
263 mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
264 mi_rules = sortLe le_rule iface_rules,
266 mi_vect_info = iface_vect_info,
268 mi_fixities = fixities,
270 mi_anns = mkIfaceAnnotations anns,
271 mi_globals = Just rdr_env,
273 -- Left out deliberately: filled in by addVersionInfo
274 mi_iface_hash = fingerprint0,
275 mi_mod_hash = fingerprint0,
276 mi_exp_hash = fingerprint0,
277 mi_orphan_hash = fingerprint0,
278 mi_orphan = False, -- Always set by addVersionInfo, but
279 -- it's a strict field, so we can't omit it.
280 mi_finsts = False, -- Ditto
281 mi_decls = deliberatelyOmitted "decls",
282 mi_hash_fn = deliberatelyOmitted "hash_fn",
283 mi_hpc = isHpcUsed hpc_info,
285 -- And build the cached values
286 mi_warn_fn = mkIfaceWarnCache warns,
287 mi_fix_fn = mkIfaceFixCache fixities }
290 ; (new_iface, no_change_at_all)
291 <- {-# SCC "versioninfo" #-}
292 addFingerprints hsc_env maybe_old_fingerprint
293 intermediate_iface decls
295 -- Warn about orphans
296 ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans
297 | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
298 | otherwise = emptyBag
299 errs_and_warns = (orph_warnings, emptyBag)
300 unqual = mkPrintUnqualified dflags rdr_env
301 inst_warns = listToBag [ instOrphWarn unqual d
302 | (d,i) <- insts `zip` iface_insts
303 , isNothing (ifInstOrph i) ]
304 rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
306 , isNothing (ifRuleOrph r) ]
308 ; when (not (isEmptyBag orph_warnings))
309 (do { printErrorsAndWarnings dflags errs_and_warns -- XXX
310 ; when (errorsFound dflags errs_and_warns)
311 (exitWith (ExitFailure 1)) })
313 -- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
316 ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
317 (pprModIface new_iface)
319 -- bug #1617: on reload we weren't updating the PrintUnqualified
320 -- correctly. This stems from the fact that the interface had
321 -- not changed, so addVersionInfo returns the old ModIface
322 -- with the old GlobalRdrEnv (mi_globals).
323 ; let final_iface = new_iface{ mi_globals = Just rdr_env }
325 ; return (final_iface, no_change_at_all) }
327 r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
328 i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2
329 i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
331 le_occ :: Name -> Name -> Bool
332 -- Compare lexicographically by OccName, *not* by unique, because
333 -- the latter is not stable across compilations
334 le_occ n1 n2 = nameOccName n1 <= nameOccName n2
336 dflags = hsc_dflags hsc_env
337 deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
338 ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
340 flattenVectInfo (VectInfo { vectInfoVar = vVar
341 , vectInfoTyCon = vTyCon
344 ifaceVectInfoVar = [ Var.varName v
345 | (v, _) <- varEnvElts vVar],
346 ifaceVectInfoTyCon = [ tyConName t
347 | (t, t_v) <- nameEnvElts vTyCon
349 ifaceVectInfoTyConReuse = [ tyConName t
350 | (t, t_v) <- nameEnvElts vTyCon
354 -----------------------------
355 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
356 writeIfaceFile dflags location new_iface
357 = do createDirectoryHierarchy (takeDirectory hi_file_path)
358 writeBinIface dflags hi_file_path new_iface
359 where hi_file_path = ml_hi_file location
362 -- -----------------------------------------------------------------------------
363 -- Look up parents and versions of Names
365 -- This is like a global version of the mi_hash_fn field in each ModIface.
366 -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
367 -- the parent and version info.
370 :: HscEnv -- needed to look up versions
371 -> ExternalPackageState -- ditto
372 -> (Name -> Fingerprint)
373 mkHashFun hsc_env eps
376 mod = ASSERT2( isExternalName name, ppr name ) nameModule name
377 occ = nameOccName name
378 iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
379 pprPanic "lookupVers2" (ppr mod <+> ppr occ)
381 snd (mi_hash_fn iface occ `orElse`
382 pprPanic "lookupVers1" (ppr mod <+> ppr occ))
384 hpt = hsc_HPT hsc_env
387 -- ---------------------------------------------------------------------------
388 -- Compute fingerprints for the interface
392 -> Maybe Fingerprint -- the old fingerprint, if any
393 -> ModIface -- The new interface (lacking decls)
394 -> [IfaceDecl] -- The new decls
395 -> IO (ModIface, -- Updated interface
396 Bool) -- True <=> no changes at all;
397 -- no need to write Iface
399 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
401 eps <- hscEPS hsc_env
403 -- the ABI of a declaration represents everything that is made
404 -- visible about the declaration that a client can depend on.
405 -- see IfaceDeclABI below.
406 declABI :: IfaceDecl -> IfaceDeclABI
407 declABI decl = (this_mod, decl, extras)
408 where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
410 edges :: [(IfaceDeclABI, Unique, [Unique])]
411 edges = [ (abi, getUnique (ifName decl), out)
413 , let abi = declABI decl
414 , let out = localOccs $ freeNamesDeclABI abi
417 name_module n = ASSERT( isExternalName n ) nameModule n
418 localOccs = map (getUnique . getParent . getOccName)
419 . filter ((== this_mod) . name_module)
421 where getParent occ = lookupOccEnv parent_map occ `orElse` occ
423 -- maps OccNames to their parents in the current module.
424 -- e.g. a reference to a constructor must be turned into a reference
425 -- to the TyCon for the purposes of calculating dependencies.
426 parent_map :: OccEnv OccName
427 parent_map = foldr extend emptyOccEnv new_decls
429 extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
432 -- strongly-connected groups of declarations, in dependency order
433 groups = stronglyConnCompFromEdgedVertices edges
435 global_hash_fn = mkHashFun hsc_env eps
437 -- how to output Names when generating the data to fingerprint.
438 -- Here we want to output the fingerprint for each top-level
439 -- Name, whether it comes from the current module or another
440 -- module. In this way, the fingerprint for a declaration will
441 -- change if the fingerprint for anything it refers to (transitively)
443 mk_put_name :: (OccEnv (OccName,Fingerprint))
444 -> BinHandle -> Name -> IO ()
445 mk_put_name local_env bh name
446 | isWiredInName name = putNameLiterally bh name
447 -- wired-in names don't have fingerprints
449 = ASSERT( isExternalName name )
450 let hash | nameModule name /= this_mod = global_hash_fn name
452 snd (lookupOccEnv local_env (getOccName name)
453 `orElse` pprPanic "urk! lookup local fingerprint"
454 (ppr name)) -- (undefined,fingerprint0))
455 -- This panic indicates that we got the dependency
456 -- analysis wrong, because we needed a fingerprint for
457 -- an entity that wasn't in the environment. To debug
458 -- it, turn the panic into a trace, uncomment the
459 -- pprTraces below, run the compile again, and inspect
460 -- the output and the generated .hi file with
465 -- take a strongly-connected group of declarations and compute
468 fingerprint_group :: (OccEnv (OccName,Fingerprint),
469 [(Fingerprint,IfaceDecl)])
471 -> IO (OccEnv (OccName,Fingerprint),
472 [(Fingerprint,IfaceDecl)])
474 fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
475 = do let hash_fn = mk_put_name local_env
477 -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
478 hash <- computeFingerprint dflags hash_fn abi
479 return (extend_hash_env (hash,decl) local_env,
480 (hash,decl) : decls_w_hashes)
482 fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
483 = do let decls = map abiDecl abis
484 local_env' = foldr extend_hash_env local_env
485 (zip (repeat fingerprint0) decls)
486 hash_fn = mk_put_name local_env'
487 -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
488 let stable_abis = sortBy cmp_abiNames abis
489 -- put the cycle in a canonical order
490 hash <- computeFingerprint dflags hash_fn stable_abis
491 let pairs = zip (repeat hash) decls
492 return (foldr extend_hash_env local_env pairs,
493 pairs ++ decls_w_hashes)
495 extend_hash_env :: (Fingerprint,IfaceDecl)
496 -> OccEnv (OccName,Fingerprint)
497 -> OccEnv (OccName,Fingerprint)
498 extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
501 item = (decl_name, hash)
502 env1 = extendOccEnv env0 decl_name item
503 add_imp bndr env = extendOccEnv env bndr item
506 (local_env, decls_w_hashes) <-
507 foldM fingerprint_group (emptyOccEnv, []) groups
509 -- when calculating fingerprints, we always need to use canonical
510 -- ordering for lists of things. In particular, the mi_deps has various
511 -- lists of modules and suchlike, so put these all in canonical order:
512 let sorted_deps = sortDependencies (mi_deps iface0)
514 -- the export hash of a module depends on the orphan hashes of the
515 -- orphan modules below us in the dependeny tree. This is the way
516 -- that changes in orphans get propagated all the way up the
517 -- dependency tree. We only care about orphan modules in the current
518 -- package, because changes to orphans outside this package will be
519 -- tracked by the usage on the ABI hash of package modules that we import.
520 let orph_mods = filter ((== this_pkg) . modulePackageId)
521 $ dep_orphs sorted_deps
522 dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
524 orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
525 (map IfaceInstABI orph_insts, orph_rules, fam_insts)
527 -- the export list hash doesn't depend on the fingerprints of
528 -- the Names it mentions, only the Names themselves, hence putNameLiterally.
529 export_hash <- computeFingerprint dflags putNameLiterally
530 (mi_exports iface0, orphan_hash, dep_orphan_hashes)
532 -- put the declarations in a canonical order, sorted by OccName
533 let sorted_decls = eltsFM $ listToFM $
534 [(ifName d, e) | e@(_, d) <- decls_w_hashes]
536 -- the ABI hash depends on:
542 mod_hash <- computeFingerprint dflags putNameLiterally
543 (map fst sorted_decls,
548 -- The interface hash depends on:
549 -- - the ABI hash, plus
553 iface_hash <- computeFingerprint dflags putNameLiterally
560 no_change_at_all = Just iface_hash == mb_old_fingerprint
562 final_iface = iface0 {
563 mi_mod_hash = mod_hash,
564 mi_iface_hash = iface_hash,
565 mi_exp_hash = export_hash,
566 mi_orphan_hash = orphan_hash,
567 mi_orphan = not (null orph_rules && null orph_insts),
568 mi_finsts = not . null $ mi_fam_insts iface0,
569 mi_decls = sorted_decls,
570 mi_hash_fn = lookupOccEnv local_env }
572 return (final_iface, no_change_at_all)
575 this_mod = mi_module iface0
576 dflags = hsc_dflags hsc_env
577 this_pkg = thisPackage dflags
578 (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
579 (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
580 -- ToDo: shouldn't we be splitting fam_insts into orphans and
582 fam_insts = mi_fam_insts iface0
583 fix_fn = mi_fix_fn iface0
586 getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
587 getOrphanHashes hsc_env mods = do
588 eps <- hscEPS hsc_env
590 hpt = hsc_HPT hsc_env
592 dflags = hsc_dflags hsc_env
594 case lookupIfaceByModule dflags hpt pit mod of
595 Nothing -> pprPanic "moduleOrphanHash" (ppr mod)
596 Just iface -> mi_orphan_hash iface
598 return (map get_orph_hash mods)
601 sortDependencies :: Dependencies -> Dependencies
603 = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
604 dep_pkgs = sortBy (compare `on` packageIdFS) (dep_pkgs d),
605 dep_orphs = sortBy stableModuleCmp (dep_orphs d),
606 dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
608 -- The ABI of a declaration consists of:
609 -- the full name of the identifier (inc. module and package, because
610 -- these are used to construct the symbol name by which the
611 -- identifier is known externally).
612 -- the fixity of the identifier
613 -- the declaration itself, as exposed to clients. That is, the
614 -- definition of an Id is included in the fingerprint only if
615 -- it is made available as as unfolding in the interface.
617 -- for classes: instances, fixity & rules for methods
618 -- for datatypes: instances, fixity & rules for constrs
619 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
621 abiDecl :: IfaceDeclABI -> IfaceDecl
622 abiDecl (_, decl, _) = decl
624 cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
625 cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
626 ifName (abiDecl abi2)
628 freeNamesDeclABI :: IfaceDeclABI -> NameSet
629 freeNamesDeclABI (_mod, decl, extras) =
630 freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
633 = IfaceIdExtras Fixity [IfaceRule]
634 | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
635 | IfaceClassExtras [IfaceInstABI] [(Fixity,[IfaceRule])]
636 | IfaceOtherDeclExtras
638 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
639 freeNamesDeclExtras (IfaceIdExtras _ rules)
640 = unionManyNameSets (map freeNamesIfRule rules)
641 freeNamesDeclExtras (IfaceDataExtras _ _insts subs)
642 = unionManyNameSets (map freeNamesSub subs)
643 freeNamesDeclExtras (IfaceClassExtras _insts subs)
644 = unionManyNameSets (map freeNamesSub subs)
645 freeNamesDeclExtras IfaceOtherDeclExtras
648 freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
649 freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
651 instance Binary IfaceDeclExtras where
652 get _bh = panic "no get for IfaceDeclExtras"
653 put_ bh (IfaceIdExtras fix rules) = do
654 putByte bh 1; put_ bh fix; put_ bh rules
655 put_ bh (IfaceDataExtras fix insts cons) = do
656 putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
657 put_ bh (IfaceClassExtras insts methods) = do
658 putByte bh 3; put_ bh insts; put_ bh methods
659 put_ bh IfaceOtherDeclExtras = do
662 declExtras :: (OccName -> Fixity)
663 -> OccEnv [IfaceRule]
664 -> OccEnv [IfaceInst]
668 declExtras fix_fn rule_env inst_env decl
670 IfaceId{} -> IfaceIdExtras (fix_fn n)
671 (lookupOccEnvL rule_env n)
672 IfaceData{ifCons=cons} ->
673 IfaceDataExtras (fix_fn n)
674 (map IfaceInstABI $ lookupOccEnvL inst_env n)
675 (map (id_extras . ifConOcc) (visibleIfConDecls cons))
676 IfaceClass{ifSigs=sigs} ->
678 (map IfaceInstABI $ lookupOccEnvL inst_env n)
679 [id_extras op | IfaceClassOp op _ _ <- sigs]
680 _other -> IfaceOtherDeclExtras
683 id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
686 -- When hashing an instance, we hash only its structure, not the
687 -- fingerprints of the things it mentions. See the section on instances
688 -- in the commentary,
689 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
691 newtype IfaceInstABI = IfaceInstABI IfaceInst
693 instance Binary IfaceInstABI where
694 get = panic "no get for IfaceInstABI"
695 put_ bh (IfaceInstABI inst) = do
696 let ud = getUserData bh
697 bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
700 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
701 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
703 -- used when we want to fingerprint a structure without depending on the
704 -- fingerprints of external Names that it refers to.
705 putNameLiterally :: BinHandle -> Name -> IO ()
706 putNameLiterally bh name = ASSERT( isExternalName name )
707 do { put_ bh $! nameModule name
708 ; put_ bh $! nameOccName name }
710 computeFingerprint :: Binary a
712 -> (BinHandle -> Name -> IO ())
716 computeFingerprint _dflags put_name a = do
717 bh <- openBinMem (3*1024) -- just less than a block
718 ud <- newWriteState put_name putFS
719 bh <- return $ setUserData bh ud
724 -- for testing: use the md5sum command to generate fingerprints and
725 -- compare the results against our built-in version.
726 fp' <- oldMD5 dflags bh
727 if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
730 oldMD5 dflags bh = do
731 tmp <- newTempName dflags "bin"
733 tmp2 <- newTempName dflags "md5"
734 let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
737 ExitFailure _ -> ghcError (PhaseFailed cmd r)
739 hash_str <- readFile tmp2
740 return $! readHexFingerprint hash_str
743 instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
744 instOrphWarn unqual inst
745 = mkWarnMsg (getSrcSpan inst) unqual $
746 hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
748 ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
749 ruleOrphWarn unqual mod rule
750 = mkWarnMsg silly_loc unqual $
751 ptext (sLit "Orphan rule:") <+> ppr rule
753 silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0)
754 -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
755 -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
757 ----------------------
758 -- mkOrphMap partitions instance decls or rules into
759 -- (a) an OccEnv for ones that are not orphans,
760 -- mapping the local OccName to a list of its decls
761 -- (b) a list of orphan decls
762 mkOrphMap :: (decl -> Maybe OccName) -- (Just occ) for a non-orphan decl, keyed by occ
763 -- Nothing for an orphan decl
764 -> [decl] -- Sorted into canonical order
765 -> (OccEnv [decl], -- Non-orphan decls associated with their key;
766 -- each sublist in canonical order
767 [decl]) -- Orphan decls; in canonical order
768 mkOrphMap get_key decls
769 = foldl go (emptyOccEnv, []) decls
771 go (non_orphs, orphs) d
772 | Just occ <- get_key d
773 = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
774 | otherwise = (non_orphs, d:orphs)
778 %*********************************************************
780 \subsection{Keeping track of what we've slurped, and fingerprints}
782 %*********************************************************
786 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
787 mkUsageInfo hsc_env this_mod dir_imp_mods used_names
788 = do { eps <- hscEPS hsc_env
789 ; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
790 dir_imp_mods used_names
791 ; usages `seqList` return usages }
792 -- seq the list of Usages returned: occasionally these
793 -- don't get evaluated for a while and we can end up hanging on to
794 -- the entire collection of Ifaces.
796 mk_usage_info :: PackageIfaceTable
802 mk_usage_info pit hsc_env this_mod direct_imports used_names
803 = mapCatMaybes mkUsage usage_mods
805 hpt = hsc_HPT hsc_env
806 dflags = hsc_dflags hsc_env
807 this_pkg = thisPackage dflags
809 used_mods = moduleEnvKeys ent_map
810 dir_imp_mods = (moduleEnvKeys direct_imports)
811 all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
812 usage_mods = sortBy stableModuleCmp all_mods
813 -- canonical order is imported, to avoid interface-file
816 -- ent_map groups together all the things imported and used
817 -- from a particular module
818 ent_map :: ModuleEnv [OccName]
819 ent_map = foldNameSet add_mv emptyModuleEnv used_names
822 | isWiredInName name = mv_map -- ignore wired-in names
824 = case nameModule_maybe name of
825 Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
826 Just mod -> -- We use this fiddly lambda function rather than
827 -- (++) as the argument to extendModuleEnv_C to
828 -- avoid quadratic behaviour (trac #2680)
829 extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
830 where occ = nameOccName name
832 -- We want to create a Usage for a home module if
833 -- a) we used something from it; has something in used_names
834 -- b) we imported it, even if we used nothing from it
835 -- (need to recompile if its export list changes: export_fprint)
836 mkUsage :: Module -> Maybe Usage
838 | isNothing maybe_iface -- We can't depend on it if we didn't
839 -- load its interface.
840 || mod == this_mod -- We don't care about usages of
841 -- things in *this* module
844 | modulePackageId mod /= this_pkg
845 = Just UsagePackageModule{ usg_mod = mod,
846 usg_mod_hash = mod_hash }
847 -- for package modules, we record the module hash only
850 && isNothing export_hash
851 && not is_direct_import
853 = Nothing -- Record no usage info
854 -- for directly-imported modules, we always want to record a usage
855 -- on the orphan hash. This is what triggers a recompilation if
856 -- an orphan is added or removed somewhere below us in the future.
859 = Just UsageHomeModule {
860 usg_mod_name = moduleName mod,
861 usg_mod_hash = mod_hash,
862 usg_exports = export_hash,
863 usg_entities = fmToList ent_hashs }
865 maybe_iface = lookupIfaceByModule dflags hpt pit mod
866 -- In one-shot mode, the interfaces for home-package
867 -- modules accumulate in the PIT not HPT. Sigh.
869 is_direct_import = mod `elemModuleEnv` direct_imports
871 Just iface = maybe_iface
872 finsts_mod = mi_finsts iface
873 hash_env = mi_hash_fn iface
874 mod_hash = mi_mod_hash iface
875 export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
876 | otherwise = Nothing
878 used_occs = lookupModuleEnv ent_map mod `orElse` []
880 -- Making a FiniteMap here ensures that (a) we remove duplicates
881 -- when we have usages on several subordinates of a single parent,
882 -- and (b) that the usages emerge in a canonical order, which
883 -- is why we use FiniteMap rather than OccEnv: FiniteMap works
884 -- using Ord on the OccNames, which is a lexicographic ordering.
885 ent_hashs :: FiniteMap OccName Fingerprint
886 ent_hashs = listToFM (map lookup_occ used_occs)
890 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
893 depend_on_exports mod =
894 case lookupModuleEnv direct_imports mod of
896 -- Even if we used 'import M ()', we have to register a
897 -- usage on the export list because we are sensitive to
898 -- changes in orphan instances/rules.
900 -- In GHC 6.8.x the above line read "True", and in
901 -- fact it recorded a dependency on *all* the
902 -- modules underneath in the dependency tree. This
903 -- happens to make orphans work right, but is too
904 -- expensive: it'll read too many interface files.
905 -- The 'isNothing maybe_iface' check above saved us
906 -- from generating many of these usages (at least in
907 -- one-shot mode), but that's even more bogus!
911 mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
912 mkIfaceAnnotations = map mkIfaceAnnotation
914 mkIfaceAnnotation :: Annotation -> IfaceAnnotation
915 mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation {
916 ifAnnotatedTarget = fmap nameOccName target,
917 ifAnnotatedValue = serialized
922 mkIfaceExports :: [AvailInfo]
923 -> [(Module, [GenAvailInfo OccName])]
924 -- Group by module and sort by occurrence
925 -- This keeps the list in canonical order
926 mkIfaceExports exports
927 = [ (mod, eltsFM avails)
928 | (mod, avails) <- fmToList groupFM
931 -- Group by the module where the exported entities are defined
932 -- (which may not be the same for all Names in an Avail)
933 -- Deliberately use FiniteMap rather than UniqFM so we
934 -- get a canonical ordering
935 groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
936 groupFM = foldl add emptyModuleEnv exports
938 add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
939 -> Module -> GenAvailInfo OccName
940 -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
941 add_one env mod avail
942 = extendModuleEnv_C plusFM env mod
943 (unitFM (occNameFS (availName avail)) avail)
945 -- NB: we should not get T(X) and T(Y) in the export list
946 -- else the plusFM will simply discard one! They
947 -- should have been combined by now.
949 = ASSERT( isExternalName n )
950 add_one env (nameModule n) (Avail (nameOccName n))
952 add env (AvailTC tc ns)
953 = ASSERT( all isExternalName ns )
954 foldl add_for_mod env mods
956 tc_occ = nameOccName tc
957 mods = nub (map nameModule ns)
958 -- Usually just one, but see Note [Original module]
961 = add_one env mod (AvailTC tc_occ (sort names_from_mod))
962 -- NB. sort the children, we need a canonical order
964 names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
967 Note [Orignal module]
968 ~~~~~~~~~~~~~~~~~~~~~
970 module X where { data family T }
971 module Y( T(..) ) where { import X; data instance T Int = MkT Int }
972 The exported Avail from Y will look like
975 - only MkT is brought into scope by the data instance;
976 - but the parent (used for grouping and naming in T(..) exports) is X.T
977 - and in this case we export X.T too
979 In the result of MkIfaceExports, the names are grouped by defining module,
980 so we may need to split up a single Avail into multiple ones.
983 %************************************************************************
985 Load the old interface file for this module (unless
986 we have it aleady), and check whether it is up to date
989 %************************************************************************
992 checkOldIface :: HscEnv
994 -> Bool -- Source unchanged
995 -> Maybe ModIface -- Old interface from compilation manager, if any
996 -> IO (RecompileRequired, Maybe ModIface)
998 checkOldIface hsc_env mod_summary source_unchanged maybe_iface
999 = do { showPass (hsc_dflags hsc_env)
1000 ("Checking old interface for " ++
1001 showSDoc (ppr (ms_mod mod_summary))) ;
1003 ; initIfaceCheck hsc_env $
1004 check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1007 check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
1008 -> IfG (Bool, Maybe ModIface)
1009 check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1010 = do -- CHECK WHETHER THE SOURCE HAS CHANGED
1011 { when (not source_unchanged)
1012 (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
1014 -- If the source has changed and we're in interactive mode, avoid reading
1015 -- an interface; just return the one we might have been supplied with.
1016 ; let dflags = hsc_dflags hsc_env
1017 ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
1018 return (outOfDate, maybe_iface)
1020 case maybe_iface of {
1021 Just old_iface -> do -- Use the one we already have
1022 { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
1023 ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
1024 ; return (recomp, Just old_iface) }
1028 -- Try and read the old interface for the current module
1029 -- from the .hi file left from the last time we compiled it
1030 { let iface_path = msHiFilePath mod_summary
1031 ; read_result <- readIface (ms_mod mod_summary) iface_path False
1032 ; case read_result of {
1033 Failed err -> do -- Old interface file not found, or garbled; give up
1034 { traceIf (text "FYI: cannot read old interface file:"
1036 ; return (outOfDate, Nothing) }
1038 ; Succeeded iface -> do
1040 -- We have got the old iface; check its versions
1041 { traceIf (text "Read the interface file" <+> text iface_path)
1042 ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
1043 ; return (recomp, Just iface)
1048 @recompileRequired@ is called from the HscMain. It checks whether
1049 a recompilation is required. It needs access to the persistent state,
1050 finder, etc, because it may have to load lots of interface files to
1051 check their versions.
1054 type RecompileRequired = Bool
1055 upToDate, outOfDate :: Bool
1056 upToDate = False -- Recompile not required
1057 outOfDate = True -- Recompile required
1059 checkVersions :: HscEnv
1060 -> Bool -- True <=> source unchanged
1062 -> ModIface -- Old interface
1063 -> IfG RecompileRequired
1064 checkVersions hsc_env source_unchanged mod_summary iface
1065 | not source_unchanged
1068 = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
1069 ppr (mi_module iface) <> colon)
1071 ; recomp <- checkDependencies hsc_env mod_summary iface
1072 ; if recomp then return outOfDate else do {
1074 -- Source code unchanged and no errors yet... carry on
1076 -- First put the dependent-module info, read from the old
1077 -- interface, into the envt, so that when we look for
1078 -- interfaces we look for the right one (.hi or .hi-boot)
1080 -- It's just temporary because either the usage check will succeed
1081 -- (in which case we are done with this module) or it'll fail (in which
1082 -- case we'll compile the module from scratch anyhow).
1084 -- We do this regardless of compilation mode, although in --make mode
1085 -- all the dependent modules should be in the HPT already, so it's
1087 updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
1089 ; let this_pkg = thisPackage (hsc_dflags hsc_env)
1090 ; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1093 -- This is a bit of a hack really
1094 mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1095 mod_deps = mkModDeps (dep_mods (mi_deps iface))
1098 -- If the direct imports of this module are resolved to targets that
1099 -- are not among the dependencies of the previous interface file,
1100 -- then we definitely need to recompile. This catches cases like
1101 -- - an exposed package has been upgraded
1102 -- - we are compiling with different package flags
1103 -- - a home module that was shadowing a package module has been removed
1104 -- - a new home module has been added that shadows a package module
1107 -- Returns True if recompilation is required.
1108 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1109 checkDependencies hsc_env summary iface
1110 = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1112 prev_dep_mods = dep_mods (mi_deps iface)
1113 prev_dep_pkgs = dep_pkgs (mi_deps iface)
1115 this_pkg = thisPackage (hsc_dflags hsc_env)
1117 orM = foldr f (return False)
1118 where f m rest = do b <- m; if b then return True else rest
1120 dep_missing (L _ mod) = do
1121 find_res <- liftIO $ findImportedModule hsc_env mod Nothing
1125 -> if moduleName mod `notElem` map fst prev_dep_mods
1126 then do traceHiDiffs $
1127 text "imported module " <> quotes (ppr mod) <>
1128 text " not among previous dependencies"
1133 -> if pkg `notElem` prev_dep_pkgs
1134 then do traceHiDiffs $
1135 text "imported module " <> quotes (ppr mod) <>
1136 text " is from package " <> quotes (ppr pkg) <>
1137 text ", which is not among previous dependencies"
1141 where pkg = modulePackageId mod
1142 _otherwise -> return outOfDate
1144 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1145 -> IfG RecompileRequired
1146 needInterface mod continue
1147 = do -- Load the imported interface if possible
1148 let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1149 traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1151 mb_iface <- loadInterface doc_str mod ImportBySystem
1152 -- Load the interface, but don't complain on failure;
1153 -- Instead, get an Either back which we can test
1156 Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
1158 -- Couldn't find or parse a module mentioned in the
1159 -- old interface file. Don't complain: it might
1160 -- just be that the current module doesn't need that
1161 -- import and it's been deleted
1162 Succeeded iface -> continue iface
1165 checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
1166 -- Given the usage information extracted from the old
1167 -- M.hi file for the module being compiled, figure out
1168 -- whether M needs to be recompiled.
1170 checkModUsage _this_pkg UsagePackageModule{
1172 usg_mod_hash = old_mod_hash }
1173 = needInterface mod $ \iface -> do
1174 checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
1175 -- We only track the ABI hash of package modules, rather than
1176 -- individual entity usages, so if the ABI hash changes we must
1177 -- recompile. This is safe but may entail more recompilation when
1178 -- a dependent package has changed.
1180 checkModUsage this_pkg UsageHomeModule{
1181 usg_mod_name = mod_name,
1182 usg_mod_hash = old_mod_hash,
1183 usg_exports = maybe_old_export_hash,
1184 usg_entities = old_decl_hash }
1186 let mod = mkModule this_pkg mod_name
1187 needInterface mod $ \iface -> do
1190 new_mod_hash = mi_mod_hash iface
1191 new_decl_hash = mi_hash_fn iface
1192 new_export_hash = mi_exp_hash iface
1195 recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
1196 if not recompile then return upToDate else do
1198 -- CHECK EXPORT LIST
1199 checkMaybeHash maybe_old_export_hash new_export_hash
1200 (ptext (sLit " Export list changed")) $ do
1202 -- CHECK ITEMS ONE BY ONE
1203 recompile <- checkList [ checkEntityUsage new_decl_hash u
1204 | u <- old_decl_hash]
1206 then return outOfDate -- This one failed, so just bail out now
1207 else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
1209 ------------------------
1210 checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
1211 checkModuleFingerprint old_mod_hash new_mod_hash
1212 | new_mod_hash == old_mod_hash
1213 = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1216 = out_of_date_hash (ptext (sLit " Module fingerprint has changed"))
1217 old_mod_hash new_mod_hash
1219 ------------------------
1220 checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
1221 -> IfG RecompileRequired -> IfG RecompileRequired
1222 checkMaybeHash maybe_old_hash new_hash doc continue
1223 | Just hash <- maybe_old_hash, hash /= new_hash
1224 = out_of_date_hash doc hash new_hash
1228 ------------------------
1229 checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
1230 -> (OccName, Fingerprint)
1232 checkEntityUsage new_hash (name,old_hash)
1233 = case new_hash name of
1235 Nothing -> -- We used it before, but it ain't there now
1236 out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
1238 Just (_, new_hash) -- It's there, but is it up to date?
1239 | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
1241 | otherwise -> out_of_date_hash (ptext (sLit " Out of date:") <+> ppr name)
1244 up_to_date, out_of_date :: SDoc -> IfG Bool
1245 up_to_date msg = traceHiDiffs msg >> return upToDate
1246 out_of_date msg = traceHiDiffs msg >> return outOfDate
1248 out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
1249 out_of_date_hash msg old_hash new_hash
1250 = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1252 ----------------------
1253 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1254 -- This helper is used in two places
1255 checkList [] = return upToDate
1256 checkList (check:checks) = do recompile <- check
1258 then return outOfDate
1259 else checkList checks
1262 %************************************************************************
1264 Converting things to their Iface equivalents
1266 %************************************************************************
1269 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1270 -- Assumption: the thing is already tidied, so that locally-bound names
1271 -- (lambdas, for-alls) already have non-clashing OccNames
1272 -- Reason: Iface stuff uses OccNames, and the conversion here does
1273 -- not do tidying on the way
1274 tyThingToIfaceDecl (AnId id)
1275 = IfaceId { ifName = getOccName id,
1276 ifType = toIfaceType (idType id),
1279 info = case toIfaceIdInfo (idInfo id) of
1281 items -> HasInfo items
1283 tyThingToIfaceDecl (AClass clas)
1284 = IfaceClass { ifCtxt = toIfaceContext sc_theta,
1285 ifName = getOccName clas,
1286 ifTyVars = toIfaceTvBndrs clas_tyvars,
1287 ifFDs = map toIfaceFD clas_fds,
1288 ifATs = map (tyThingToIfaceDecl . ATyCon) clas_ats,
1289 ifSigs = map toIfaceClassOp op_stuff,
1290 ifRec = boolToRecFlag (isRecursiveTyCon tycon) }
1292 (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
1293 = classExtraBigSig clas
1294 tycon = classTyCon clas
1296 toIfaceClassOp (sel_id, def_meth)
1297 = ASSERT(sel_tyvars == clas_tyvars)
1298 IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
1300 -- Be careful when splitting the type, because of things
1301 -- like class Foo a where
1302 -- op :: (?x :: String) => a -> a
1303 -- and class Baz a where
1304 -- op :: (Ord a) => a -> a
1305 (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1306 op_ty = funResultTy rho_ty
1308 toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
1310 tyThingToIfaceDecl (ATyCon tycon)
1312 = IfaceSyn { ifName = getOccName tycon,
1313 ifTyVars = toIfaceTvBndrs tyvars,
1316 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
1320 = IfaceData { ifName = getOccName tycon,
1321 ifTyVars = toIfaceTvBndrs tyvars,
1322 ifCtxt = toIfaceContext (tyConStupidTheta tycon),
1323 ifCons = ifaceConDecls (algTyConRhs tycon),
1324 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
1325 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1326 ifGeneric = tyConHasGenerics tycon,
1327 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
1329 | isForeignTyCon tycon
1330 = IfaceForeign { ifName = getOccName tycon,
1331 ifExtName = tyConExtName tycon }
1333 | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
1335 tyvars = tyConTyVars tycon
1337 = case synTyConRhs tycon of
1338 OpenSynTyCon ki _ -> (Nothing, toIfaceType ki)
1339 SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
1341 ifaceConDecls (NewTyCon { data_con = con }) =
1342 IfNewTyCon (ifaceConDecl con)
1343 ifaceConDecls (DataTyCon { data_cons = cons }) =
1344 IfDataTyCon (map ifaceConDecl cons)
1345 ifaceConDecls OpenTyCon {} = IfOpenDataTyCon
1346 ifaceConDecls AbstractTyCon = IfAbstractTyCon
1347 -- The last case happens when a TyCon has been trimmed during tidying
1348 -- Furthermore, tyThingToIfaceDecl is also used
1349 -- in TcRnDriver for GHCi, when browsing a module, in which case the
1350 -- AbstractTyCon case is perfectly sensible.
1352 ifaceConDecl data_con
1353 = IfCon { ifConOcc = getOccName (dataConName data_con),
1354 ifConInfix = dataConIsInfix data_con,
1355 ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
1356 ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
1357 ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
1358 ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
1359 ifConArgTys = map toIfaceType (dataConOrigArgTys data_con),
1360 ifConFields = map getOccName
1361 (dataConFieldLabels data_con),
1362 ifConStricts = dataConStrictMarks data_con }
1364 to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
1366 famInstToIface Nothing = Nothing
1367 famInstToIface (Just (famTyCon, instTys)) =
1368 Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
1370 tyThingToIfaceDecl (ADataCon dc)
1371 = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
1374 getFS :: NamedThing a => a -> FastString
1375 getFS x = occNameFS (getOccName x)
1377 --------------------------
1378 instanceToIfaceInst :: Instance -> IfaceInst
1379 instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
1380 is_cls = cls_name, is_tcs = mb_tcs })
1381 = ASSERT( cls_name == className cls )
1382 IfaceInst { ifDFun = dfun_name,
1384 ifInstCls = cls_name,
1385 ifInstTys = map do_rough mb_tcs,
1388 do_rough Nothing = Nothing
1389 do_rough (Just n) = Just (toIfaceTyCon_name n)
1391 dfun_name = idName dfun_id
1392 mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
1393 is_local name = nameIsLocalOrFrom mod name
1395 -- Compute orphanhood. See Note [Orphans] in IfaceSyn
1396 (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
1397 -- Slightly awkward: we need the Class to get the fundeps
1398 (tvs, fds) = classTvsFds cls
1399 arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
1400 orph | is_local cls_name = Just (nameOccName cls_name)
1401 | all isJust mb_ns = head mb_ns
1402 | otherwise = Nothing
1404 mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name
1405 -- that is not in the "determined" arguments
1406 mb_ns | null fds = [choose_one arg_names]
1407 | otherwise = map do_one fds
1408 do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
1409 , not (tv `elem` rtvs)]
1411 choose_one :: [NameSet] -> Maybe OccName
1412 choose_one nss = case nameSetToList (unionManyNameSets nss) of
1414 (n : _) -> Just (nameOccName n)
1416 --------------------------
1417 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1418 famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
1421 = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon
1422 , ifFamInstFam = fam
1423 , ifFamInstTys = map do_rough mb_tcs }
1425 do_rough Nothing = Nothing
1426 do_rough (Just n) = Just (toIfaceTyCon_name n)
1428 --------------------------
1429 toIfaceLetBndr :: Id -> IfaceLetBndr
1430 toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
1431 (toIfaceType (idType id))
1434 -- Stripped-down version of tcIfaceIdInfo
1435 -- Change this if you want to export more IdInfo for
1436 -- non-top-level Ids. Don't forget to change
1437 -- CoreTidy.tidyLetBndr too!
1439 -- See Note [IdInfo on nested let-bindings] in IfaceSyn
1441 inline_prag = inlinePragInfo id_info
1442 prag_info | isAlwaysActive inline_prag = NoInfo
1443 | otherwise = HasInfo [HsInline inline_prag]
1445 --------------------------
1446 toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
1447 toIfaceIdInfo id_info
1448 = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
1449 inline_hsinfo, wrkr_hsinfo, unfold_hsinfo]
1451 ------------ Arity --------------
1452 arity_info = arityInfo id_info
1453 arity_hsinfo | arity_info == 0 = Nothing
1454 | otherwise = Just (HsArity arity_info)
1456 ------------ Caf Info --------------
1457 caf_info = cafInfo id_info
1458 caf_hsinfo = case caf_info of
1459 NoCafRefs -> Just HsNoCafRefs
1462 ------------ Strictness --------------
1463 -- No point in explicitly exporting TopSig
1464 strict_hsinfo = case newStrictnessInfo id_info of
1465 Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
1468 ------------ Worker --------------
1469 work_info = workerInfo id_info
1470 has_worker = workerExists work_info
1471 wrkr_hsinfo = case work_info of
1472 HasWorker work_id wrap_arity ->
1473 Just (HsWorker ((idName work_id)) wrap_arity)
1476 ------------ Unfolding --------------
1477 -- The unfolding is redundant if there is a worker
1478 unfold_info = unfoldingInfo id_info
1479 rhs = unfoldingTemplate unfold_info
1480 no_unfolding = neverUnfold unfold_info
1481 -- The CoreTidy phase retains unfolding info iff
1482 -- we want to expose the unfolding, taking into account
1483 -- unconditional NOINLINE, etc. See TidyPgm.addExternal
1484 unfold_hsinfo | no_unfolding = Nothing
1485 | has_worker = Nothing -- Unfolding is implicit
1486 | otherwise = Just (HsUnfold (toIfaceExpr rhs))
1488 ------------ Inline prag --------------
1489 inline_prag = inlinePragInfo id_info
1490 inline_hsinfo | isAlwaysActive inline_prag = Nothing
1491 | no_unfolding && not has_worker = Nothing
1492 -- If the iface file give no unfolding info, we
1493 -- don't need to say when inlining is OK!
1494 | otherwise = Just (HsInline inline_prag)
1496 --------------------------
1497 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
1498 coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
1499 = pprTrace "toHsRule: builtin" (ppr fn) $
1502 coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
1503 ru_act = act, ru_bndrs = bndrs,
1504 ru_args = args, ru_rhs = rhs })
1505 = IfaceRule { ifRuleName = name, ifActivation = act,
1506 ifRuleBndrs = map toIfaceBndr bndrs,
1508 ifRuleArgs = map do_arg args,
1509 ifRuleRhs = toIfaceExpr rhs,
1512 -- For type args we must remove synonyms from the outermost
1513 -- level. Reason: so that when we read it back in we'll
1514 -- construct the same ru_rough field as we have right now;
1516 do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1517 do_arg arg = toIfaceExpr arg
1519 -- Compute orphanhood. See Note [Orphans] in IfaceSyn
1520 -- A rule is an orphan only if none of the variables
1521 -- mentioned on its left-hand side are locally defined
1522 lhs_names = fn : nameSetToList (exprsFreeNames args)
1523 -- No need to delete bndrs, because
1524 -- exprsFreeNames finds only External names
1526 orph = case filter (nameIsLocalOrFrom mod) lhs_names of
1527 (n : _) -> Just (nameOccName n)
1530 bogusIfaceRule :: Name -> IfaceRule
1531 bogusIfaceRule id_name
1532 = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
1533 ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
1534 ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
1536 ---------------------
1537 toIfaceExpr :: CoreExpr -> IfaceExpr
1538 toIfaceExpr (Var v) = toIfaceVar v
1539 toIfaceExpr (Lit l) = IfaceLit l
1540 toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
1541 toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
1542 toIfaceExpr (App f a) = toIfaceApp f [a]
1543 toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
1544 toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1545 toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co)
1546 toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
1548 ---------------------
1549 toIfaceNote :: Note -> IfaceNote
1550 toIfaceNote (SCC cc) = IfaceSCC cc
1551 toIfaceNote InlineMe = IfaceInlineMe
1552 toIfaceNote (CoreNote s) = IfaceCoreNote s
1554 ---------------------
1555 toIfaceBind :: Bind Id -> IfaceBinding
1556 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
1557 toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
1559 ---------------------
1560 toIfaceAlt :: (AltCon, [Var], CoreExpr)
1561 -> (IfaceConAlt, [FastString], IfaceExpr)
1562 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
1564 ---------------------
1565 toIfaceCon :: AltCon -> IfaceConAlt
1566 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
1567 | otherwise = IfaceDataAlt (getName dc)
1569 tc = dataConTyCon dc
1571 toIfaceCon (LitAlt l) = IfaceLitAlt l
1572 toIfaceCon DEFAULT = IfaceDefault
1574 ---------------------
1575 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
1576 toIfaceApp (App f a) as = toIfaceApp f (a:as)
1577 toIfaceApp (Var v) as
1578 = case isDataConWorkId_maybe v of
1579 -- We convert the *worker* for tuples into IfaceTuples
1580 Just dc | isTupleTyCon tc && saturated
1581 -> IfaceTuple (tupleTyConBoxity tc) tup_args
1583 val_args = dropWhile isTypeArg as
1584 saturated = val_args `lengthIs` idArity v
1585 tup_args = map toIfaceExpr val_args
1586 tc = dataConTyCon dc
1588 _ -> mkIfaceApps (toIfaceVar v) as
1590 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
1592 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
1593 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
1595 ---------------------
1596 toIfaceVar :: Id -> IfaceExpr
1598 | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
1599 -- Foreign calls have special syntax
1600 | isExternalName name = IfaceExt name
1601 | Just (TickBox m ix) <- isTickBoxOp_maybe v
1603 | otherwise = IfaceLcl (getFS name)