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"
85 import BasicTypes hiding ( SuccessFlag(..) )
88 import Util hiding ( eqListBy )
100 import System.FilePath
105 %************************************************************************
107 \subsection{Completing an interface}
109 %************************************************************************
113 -> Maybe Fingerprint -- The old fingerprint, if we have it
114 -> ModDetails -- The trimmed, tidied interface
115 -> ModGuts -- Usages, deprecations, etc
117 Maybe (ModIface, -- The new one
118 Bool)) -- True <=> there was an old Iface, and the
119 -- new one is identical, so no need
122 mkIface hsc_env maybe_old_fingerprint mod_details
123 ModGuts{ mg_module = this_mod,
125 mg_used_names = used_names,
127 mg_dir_imps = dir_imp_mods,
128 mg_rdr_env = rdr_env,
129 mg_fix_env = fix_env,
131 mg_hpc_info = hpc_info }
132 = mkIface_ hsc_env maybe_old_fingerprint
133 this_mod is_boot used_names deps rdr_env
134 fix_env warns hpc_info dir_imp_mods mod_details
136 -- | make an interface from the results of typechecking only. Useful
137 -- for non-optimising compilation, or where we aren't generating any
138 -- object code at all ('HscNothing').
140 -> Maybe Fingerprint -- The old fingerprint, if we have it
141 -> ModDetails -- gotten from mkBootModDetails, probably
142 -> TcGblEnv -- Usages, deprecations, etc
143 -> IO (Messages, Maybe (ModIface, Bool))
144 mkIfaceTc hsc_env maybe_old_fingerprint mod_details
145 tc_result@TcGblEnv{ tcg_mod = this_mod,
147 tcg_imports = imports,
148 tcg_rdr_env = rdr_env,
149 tcg_fix_env = fix_env,
151 tcg_hpc = other_hpc_info
154 used_names <- mkUsedNames tc_result
155 deps <- mkDependencies tc_result
156 let hpc_info = emptyHpcInfo other_hpc_info
157 mkIface_ hsc_env maybe_old_fingerprint
158 this_mod (isHsBoot hsc_src) used_names deps rdr_env
159 fix_env warns hpc_info (imp_mods imports) mod_details
162 mkUsedNames :: TcGblEnv -> IO NameSet
164 TcGblEnv{ tcg_inst_uses = dfun_uses_var,
168 dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
169 return (allUses dus `unionNameSets` dfun_uses)
171 mkDependencies :: TcGblEnv -> IO Dependencies
173 TcGblEnv{ tcg_mod = mod,
174 tcg_imports = imports,
178 th_used <- readIORef th_var -- Whether TH is used
180 dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
181 -- M.hi-boot can be in the imp_dep_mods, but we must remove
182 -- it before recording the modules on which this one depends!
183 -- (We want to retain M.hi-boot in imp_dep_mods so that
184 -- loadHiBootInterface can see if M's direct imports depend
185 -- on M.hi-boot, and hence that we should do the hi-boot consistency
188 pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
189 | otherwise = imp_dep_pkgs imports
191 return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
192 dep_pkgs = sortBy stablePackageIdCmp pkgs,
193 dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
194 dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
195 -- sort to get into canonical order
196 -- NB. remember to use lexicographic ordering
198 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
199 -> NameSet -> Dependencies -> GlobalRdrEnv
200 -> NameEnv FixItem -> Warnings -> HpcInfo
203 -> IO (Messages, Maybe (ModIface, Bool))
204 mkIface_ hsc_env maybe_old_fingerprint
205 this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
207 ModDetails{ md_insts = insts,
208 md_fam_insts = fam_insts,
211 md_vect_info = vect_info,
213 md_exports = exports }
214 -- NB: notice that mkIface does not look at the bindings
215 -- only at the TypeEnv. The previous Tidy phase has
216 -- put exactly the info into the TypeEnv that we want
217 -- to expose in the interface
219 = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
221 ; let { entities = typeEnvElts type_env ;
222 decls = [ tyThingToIfaceDecl entity
223 | entity <- entities,
224 let name = getName entity,
225 not (isImplicitTyThing entity),
226 -- No implicit Ids and class tycons in the interface file
227 not (isWiredInName name),
228 -- Nor wired-in things; the compiler knows about them anyhow
229 nameIsLocalOrFrom this_mod name ]
230 -- Sigh: see Note [Root-main Id] in TcRnDriver
232 ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
234 ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
235 ; iface_insts = map instanceToIfaceInst insts
236 ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
237 ; iface_vect_info = flattenVectInfo vect_info
239 ; intermediate_iface = ModIface {
240 mi_module = this_mod,
244 mi_exports = mkIfaceExports exports,
246 -- Sort these lexicographically, so that
247 -- the result is stable across compilations
248 mi_insts = sortLe le_inst iface_insts,
249 mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
250 mi_rules = sortLe le_rule iface_rules,
252 mi_vect_info = iface_vect_info,
254 mi_fixities = fixities,
256 mi_anns = mkIfaceAnnotations anns,
257 mi_globals = Just rdr_env,
259 -- Left out deliberately: filled in by addVersionInfo
260 mi_iface_hash = fingerprint0,
261 mi_mod_hash = fingerprint0,
262 mi_exp_hash = fingerprint0,
263 mi_orphan_hash = fingerprint0,
264 mi_orphan = False, -- Always set by addVersionInfo, but
265 -- it's a strict field, so we can't omit it.
266 mi_finsts = False, -- Ditto
267 mi_decls = deliberatelyOmitted "decls",
268 mi_hash_fn = deliberatelyOmitted "hash_fn",
269 mi_hpc = isHpcUsed hpc_info,
271 -- And build the cached values
272 mi_warn_fn = mkIfaceWarnCache warns,
273 mi_fix_fn = mkIfaceFixCache fixities }
276 ; (new_iface, no_change_at_all)
277 <- {-# SCC "versioninfo" #-}
278 addFingerprints hsc_env maybe_old_fingerprint
279 intermediate_iface decls
281 -- Warn about orphans
282 ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans
283 | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
284 | otherwise = emptyBag
285 errs_and_warns = (orph_warnings, emptyBag)
286 unqual = mkPrintUnqualified dflags rdr_env
287 inst_warns = listToBag [ instOrphWarn unqual d
288 | (d,i) <- insts `zip` iface_insts
289 , isNothing (ifInstOrph i) ]
290 rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
292 , isNothing (ifRuleOrph r) ]
294 ; if errorsFound dflags errs_and_warns
295 then return ( errs_and_warns, Nothing )
298 -- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
301 ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
302 (pprModIface new_iface)
304 -- bug #1617: on reload we weren't updating the PrintUnqualified
305 -- correctly. This stems from the fact that the interface had
306 -- not changed, so addVersionInfo returns the old ModIface
307 -- with the old GlobalRdrEnv (mi_globals).
308 ; let final_iface = new_iface{ mi_globals = Just rdr_env }
310 ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
312 r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
313 i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2
314 i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
316 le_occ :: Name -> Name -> Bool
317 -- Compare lexicographically by OccName, *not* by unique, because
318 -- the latter is not stable across compilations
319 le_occ n1 n2 = nameOccName n1 <= nameOccName n2
321 dflags = hsc_dflags hsc_env
322 deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
323 ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
325 flattenVectInfo (VectInfo { vectInfoVar = vVar
326 , vectInfoTyCon = vTyCon
329 ifaceVectInfoVar = [ Var.varName v
330 | (v, _) <- varEnvElts vVar],
331 ifaceVectInfoTyCon = [ tyConName t
332 | (t, t_v) <- nameEnvElts vTyCon
334 ifaceVectInfoTyConReuse = [ tyConName t
335 | (t, t_v) <- nameEnvElts vTyCon
339 -----------------------------
340 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
341 writeIfaceFile dflags location new_iface
342 = do createDirectoryHierarchy (takeDirectory hi_file_path)
343 writeBinIface dflags hi_file_path new_iface
344 where hi_file_path = ml_hi_file location
347 -- -----------------------------------------------------------------------------
348 -- Look up parents and versions of Names
350 -- This is like a global version of the mi_hash_fn field in each ModIface.
351 -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
352 -- the parent and version info.
355 :: HscEnv -- needed to look up versions
356 -> ExternalPackageState -- ditto
357 -> (Name -> Fingerprint)
358 mkHashFun hsc_env eps
361 mod = ASSERT2( isExternalName name, ppr name ) nameModule name
362 occ = nameOccName name
363 iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
364 pprPanic "lookupVers2" (ppr mod <+> ppr occ)
366 snd (mi_hash_fn iface occ `orElse`
367 pprPanic "lookupVers1" (ppr mod <+> ppr occ))
369 hpt = hsc_HPT hsc_env
372 -- ---------------------------------------------------------------------------
373 -- Compute fingerprints for the interface
377 -> Maybe Fingerprint -- the old fingerprint, if any
378 -> ModIface -- The new interface (lacking decls)
379 -> [IfaceDecl] -- The new decls
380 -> IO (ModIface, -- Updated interface
381 Bool) -- True <=> no changes at all;
382 -- no need to write Iface
384 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
386 eps <- hscEPS hsc_env
388 -- the ABI of a declaration represents everything that is made
389 -- visible about the declaration that a client can depend on.
390 -- see IfaceDeclABI below.
391 declABI :: IfaceDecl -> IfaceDeclABI
392 declABI decl = (this_mod, decl, extras)
393 where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
395 edges :: [(IfaceDeclABI, Unique, [Unique])]
396 edges = [ (abi, getUnique (ifName decl), out)
398 , let abi = declABI decl
399 , let out = localOccs $ freeNamesDeclABI abi
402 name_module n = ASSERT( isExternalName n ) nameModule n
403 localOccs = map (getUnique . getParent . getOccName)
404 . filter ((== this_mod) . name_module)
406 where getParent occ = lookupOccEnv parent_map occ `orElse` occ
408 -- maps OccNames to their parents in the current module.
409 -- e.g. a reference to a constructor must be turned into a reference
410 -- to the TyCon for the purposes of calculating dependencies.
411 parent_map :: OccEnv OccName
412 parent_map = foldr extend emptyOccEnv new_decls
414 extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
417 -- strongly-connected groups of declarations, in dependency order
418 groups = stronglyConnCompFromEdgedVertices edges
420 global_hash_fn = mkHashFun hsc_env eps
422 -- how to output Names when generating the data to fingerprint.
423 -- Here we want to output the fingerprint for each top-level
424 -- Name, whether it comes from the current module or another
425 -- module. In this way, the fingerprint for a declaration will
426 -- change if the fingerprint for anything it refers to (transitively)
428 mk_put_name :: (OccEnv (OccName,Fingerprint))
429 -> BinHandle -> Name -> IO ()
430 mk_put_name local_env bh name
431 | isWiredInName name = putNameLiterally bh name
432 -- wired-in names don't have fingerprints
434 = ASSERT( isExternalName name )
435 let hash | nameModule name /= this_mod = global_hash_fn name
437 snd (lookupOccEnv local_env (getOccName name)
438 `orElse` pprPanic "urk! lookup local fingerprint"
439 (ppr name)) -- (undefined,fingerprint0))
440 -- This panic indicates that we got the dependency
441 -- analysis wrong, because we needed a fingerprint for
442 -- an entity that wasn't in the environment. To debug
443 -- it, turn the panic into a trace, uncomment the
444 -- pprTraces below, run the compile again, and inspect
445 -- the output and the generated .hi file with
450 -- take a strongly-connected group of declarations and compute
453 fingerprint_group :: (OccEnv (OccName,Fingerprint),
454 [(Fingerprint,IfaceDecl)])
456 -> IO (OccEnv (OccName,Fingerprint),
457 [(Fingerprint,IfaceDecl)])
459 fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
460 = do let hash_fn = mk_put_name local_env
462 -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
463 hash <- computeFingerprint dflags hash_fn abi
464 return (extend_hash_env (hash,decl) local_env,
465 (hash,decl) : decls_w_hashes)
467 fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
468 = do let decls = map abiDecl abis
469 local_env' = foldr extend_hash_env local_env
470 (zip (repeat fingerprint0) decls)
471 hash_fn = mk_put_name local_env'
472 -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
473 let stable_abis = sortBy cmp_abiNames abis
474 -- put the cycle in a canonical order
475 hash <- computeFingerprint dflags hash_fn stable_abis
476 let pairs = zip (repeat hash) decls
477 return (foldr extend_hash_env local_env pairs,
478 pairs ++ decls_w_hashes)
480 extend_hash_env :: (Fingerprint,IfaceDecl)
481 -> OccEnv (OccName,Fingerprint)
482 -> OccEnv (OccName,Fingerprint)
483 extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
486 item = (decl_name, hash)
487 env1 = extendOccEnv env0 decl_name item
488 add_imp bndr env = extendOccEnv env bndr item
491 (local_env, decls_w_hashes) <-
492 foldM fingerprint_group (emptyOccEnv, []) groups
494 -- when calculating fingerprints, we always need to use canonical
495 -- ordering for lists of things. In particular, the mi_deps has various
496 -- lists of modules and suchlike, so put these all in canonical order:
497 let sorted_deps = sortDependencies (mi_deps iface0)
499 -- the export hash of a module depends on the orphan hashes of the
500 -- orphan modules below us in the dependeny tree. This is the way
501 -- that changes in orphans get propagated all the way up the
502 -- dependency tree. We only care about orphan modules in the current
503 -- package, because changes to orphans outside this package will be
504 -- tracked by the usage on the ABI hash of package modules that we import.
505 let orph_mods = filter ((== this_pkg) . modulePackageId)
506 $ dep_orphs sorted_deps
507 dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
509 orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
510 (map IfaceInstABI orph_insts, orph_rules, fam_insts)
512 -- the export list hash doesn't depend on the fingerprints of
513 -- the Names it mentions, only the Names themselves, hence putNameLiterally.
514 export_hash <- computeFingerprint dflags putNameLiterally
515 (mi_exports iface0, orphan_hash, dep_orphan_hashes)
517 -- put the declarations in a canonical order, sorted by OccName
518 let sorted_decls = eltsFM $ listToFM $
519 [(ifName d, e) | e@(_, d) <- decls_w_hashes]
521 -- the ABI hash depends on:
527 mod_hash <- computeFingerprint dflags putNameLiterally
528 (map fst sorted_decls,
533 -- The interface hash depends on:
534 -- - the ABI hash, plus
538 iface_hash <- computeFingerprint dflags putNameLiterally
545 no_change_at_all = Just iface_hash == mb_old_fingerprint
547 final_iface = iface0 {
548 mi_mod_hash = mod_hash,
549 mi_iface_hash = iface_hash,
550 mi_exp_hash = export_hash,
551 mi_orphan_hash = orphan_hash,
552 mi_orphan = not (null orph_rules && null orph_insts),
553 mi_finsts = not . null $ mi_fam_insts iface0,
554 mi_decls = sorted_decls,
555 mi_hash_fn = lookupOccEnv local_env }
557 return (final_iface, no_change_at_all)
560 this_mod = mi_module iface0
561 dflags = hsc_dflags hsc_env
562 this_pkg = thisPackage dflags
563 (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
564 (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
565 -- ToDo: shouldn't we be splitting fam_insts into orphans and
567 fam_insts = mi_fam_insts iface0
568 fix_fn = mi_fix_fn iface0
571 getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
572 getOrphanHashes hsc_env mods = do
573 eps <- hscEPS hsc_env
575 hpt = hsc_HPT hsc_env
577 dflags = hsc_dflags hsc_env
579 case lookupIfaceByModule dflags hpt pit mod of
580 Nothing -> pprPanic "moduleOrphanHash" (ppr mod)
581 Just iface -> mi_orphan_hash iface
583 return (map get_orph_hash mods)
586 sortDependencies :: Dependencies -> Dependencies
588 = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
589 dep_pkgs = sortBy (compare `on` packageIdFS) (dep_pkgs d),
590 dep_orphs = sortBy stableModuleCmp (dep_orphs d),
591 dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
593 -- The ABI of a declaration consists of:
594 -- the full name of the identifier (inc. module and package, because
595 -- these are used to construct the symbol name by which the
596 -- identifier is known externally).
597 -- the fixity of the identifier
598 -- the declaration itself, as exposed to clients. That is, the
599 -- definition of an Id is included in the fingerprint only if
600 -- it is made available as as unfolding in the interface.
602 -- for classes: instances, fixity & rules for methods
603 -- for datatypes: instances, fixity & rules for constrs
604 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
606 abiDecl :: IfaceDeclABI -> IfaceDecl
607 abiDecl (_, decl, _) = decl
609 cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
610 cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
611 ifName (abiDecl abi2)
613 freeNamesDeclABI :: IfaceDeclABI -> NameSet
614 freeNamesDeclABI (_mod, decl, extras) =
615 freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
618 = IfaceIdExtras Fixity [IfaceRule]
619 | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
620 | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
621 | IfaceSynExtras Fixity
622 | IfaceOtherDeclExtras
624 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
625 freeNamesDeclExtras (IfaceIdExtras _ rules)
626 = unionManyNameSets (map freeNamesIfRule rules)
627 freeNamesDeclExtras (IfaceDataExtras _ _insts subs)
628 = unionManyNameSets (map freeNamesSub subs)
629 freeNamesDeclExtras (IfaceClassExtras _ _insts subs)
630 = unionManyNameSets (map freeNamesSub subs)
631 freeNamesDeclExtras (IfaceSynExtras _)
633 freeNamesDeclExtras IfaceOtherDeclExtras
636 freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
637 freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
639 instance Binary IfaceDeclExtras where
640 get _bh = panic "no get for IfaceDeclExtras"
641 put_ bh (IfaceIdExtras fix rules) = do
642 putByte bh 1; put_ bh fix; put_ bh rules
643 put_ bh (IfaceDataExtras fix insts cons) = do
644 putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
645 put_ bh (IfaceClassExtras fix insts methods) = do
646 putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
647 put_ bh (IfaceSynExtras fix) = do
648 putByte bh 4; put_ bh fix
649 put_ bh IfaceOtherDeclExtras = do
652 declExtras :: (OccName -> Fixity)
653 -> OccEnv [IfaceRule]
654 -> OccEnv [IfaceInst]
658 declExtras fix_fn rule_env inst_env decl
660 IfaceId{} -> IfaceIdExtras (fix_fn n)
661 (lookupOccEnvL rule_env n)
662 IfaceData{ifCons=cons} ->
663 IfaceDataExtras (fix_fn n)
664 (map IfaceInstABI $ lookupOccEnvL inst_env n)
665 (map (id_extras . ifConOcc) (visibleIfConDecls cons))
666 IfaceClass{ifSigs=sigs} ->
667 IfaceClassExtras (fix_fn n)
668 (map IfaceInstABI $ lookupOccEnvL inst_env n)
669 [id_extras op | IfaceClassOp op _ _ <- sigs]
670 IfaceSyn{} -> IfaceSynExtras (fix_fn n)
671 _other -> IfaceOtherDeclExtras
674 id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
677 -- When hashing an instance, we hash only its structure, not the
678 -- fingerprints of the things it mentions. See the section on instances
679 -- in the commentary,
680 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
682 newtype IfaceInstABI = IfaceInstABI IfaceInst
684 instance Binary IfaceInstABI where
685 get = panic "no get for IfaceInstABI"
686 put_ bh (IfaceInstABI inst) = do
687 let ud = getUserData bh
688 bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
691 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
692 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
694 -- used when we want to fingerprint a structure without depending on the
695 -- fingerprints of external Names that it refers to.
696 putNameLiterally :: BinHandle -> Name -> IO ()
697 putNameLiterally bh name = ASSERT( isExternalName name )
698 do { put_ bh $! nameModule name
699 ; put_ bh $! nameOccName name }
701 computeFingerprint :: Binary a
703 -> (BinHandle -> Name -> IO ())
707 computeFingerprint _dflags put_name a = do
708 bh <- openBinMem (3*1024) -- just less than a block
709 ud <- newWriteState put_name putFS
710 bh <- return $ setUserData bh ud
715 -- for testing: use the md5sum command to generate fingerprints and
716 -- compare the results against our built-in version.
717 fp' <- oldMD5 dflags bh
718 if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
721 oldMD5 dflags bh = do
722 tmp <- newTempName dflags "bin"
724 tmp2 <- newTempName dflags "md5"
725 let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
728 ExitFailure _ -> ghcError (PhaseFailed cmd r)
730 hash_str <- readFile tmp2
731 return $! readHexFingerprint hash_str
734 instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
735 instOrphWarn unqual inst
736 = mkWarnMsg (getSrcSpan inst) unqual $
737 hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
739 ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
740 ruleOrphWarn unqual mod rule
741 = mkWarnMsg silly_loc unqual $
742 ptext (sLit "Orphan rule:") <+> ppr rule
744 silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0)
745 -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
746 -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
748 ----------------------
749 -- mkOrphMap partitions instance decls or rules into
750 -- (a) an OccEnv for ones that are not orphans,
751 -- mapping the local OccName to a list of its decls
752 -- (b) a list of orphan decls
753 mkOrphMap :: (decl -> Maybe OccName) -- (Just occ) for a non-orphan decl, keyed by occ
754 -- Nothing for an orphan decl
755 -> [decl] -- Sorted into canonical order
756 -> (OccEnv [decl], -- Non-orphan decls associated with their key;
757 -- each sublist in canonical order
758 [decl]) -- Orphan decls; in canonical order
759 mkOrphMap get_key decls
760 = foldl go (emptyOccEnv, []) decls
762 go (non_orphs, orphs) d
763 | Just occ <- get_key d
764 = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
765 | otherwise = (non_orphs, d:orphs)
769 %*********************************************************
771 \subsection{Keeping track of what we've slurped, and fingerprints}
773 %*********************************************************
777 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
778 mkUsageInfo hsc_env this_mod dir_imp_mods used_names
779 = do { eps <- hscEPS hsc_env
780 ; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
781 dir_imp_mods used_names
782 ; usages `seqList` return usages }
783 -- seq the list of Usages returned: occasionally these
784 -- don't get evaluated for a while and we can end up hanging on to
785 -- the entire collection of Ifaces.
787 mk_usage_info :: PackageIfaceTable
793 mk_usage_info pit hsc_env this_mod direct_imports used_names
794 = mapCatMaybes mkUsage usage_mods
796 hpt = hsc_HPT hsc_env
797 dflags = hsc_dflags hsc_env
798 this_pkg = thisPackage dflags
800 used_mods = moduleEnvKeys ent_map
801 dir_imp_mods = (moduleEnvKeys direct_imports)
802 all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
803 usage_mods = sortBy stableModuleCmp all_mods
804 -- canonical order is imported, to avoid interface-file
807 -- ent_map groups together all the things imported and used
808 -- from a particular module
809 ent_map :: ModuleEnv [OccName]
810 ent_map = foldNameSet add_mv emptyModuleEnv used_names
813 | isWiredInName name = mv_map -- ignore wired-in names
815 = case nameModule_maybe name of
816 Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
817 Just mod -> -- We use this fiddly lambda function rather than
818 -- (++) as the argument to extendModuleEnv_C to
819 -- avoid quadratic behaviour (trac #2680)
820 extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
821 where occ = nameOccName name
823 -- We want to create a Usage for a home module if
824 -- a) we used something from it; has something in used_names
825 -- b) we imported it, even if we used nothing from it
826 -- (need to recompile if its export list changes: export_fprint)
827 mkUsage :: Module -> Maybe Usage
829 | isNothing maybe_iface -- We can't depend on it if we didn't
830 -- load its interface.
831 || mod == this_mod -- We don't care about usages of
832 -- things in *this* module
835 | modulePackageId mod /= this_pkg
836 = Just UsagePackageModule{ usg_mod = mod,
837 usg_mod_hash = mod_hash }
838 -- for package modules, we record the module hash only
841 && isNothing export_hash
842 && not is_direct_import
844 = Nothing -- Record no usage info
845 -- for directly-imported modules, we always want to record a usage
846 -- on the orphan hash. This is what triggers a recompilation if
847 -- an orphan is added or removed somewhere below us in the future.
850 = Just UsageHomeModule {
851 usg_mod_name = moduleName mod,
852 usg_mod_hash = mod_hash,
853 usg_exports = export_hash,
854 usg_entities = fmToList ent_hashs }
856 maybe_iface = lookupIfaceByModule dflags hpt pit mod
857 -- In one-shot mode, the interfaces for home-package
858 -- modules accumulate in the PIT not HPT. Sigh.
860 is_direct_import = mod `elemModuleEnv` direct_imports
862 Just iface = maybe_iface
863 finsts_mod = mi_finsts iface
864 hash_env = mi_hash_fn iface
865 mod_hash = mi_mod_hash iface
866 export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
867 | otherwise = Nothing
869 used_occs = lookupModuleEnv ent_map mod `orElse` []
871 -- Making a FiniteMap here ensures that (a) we remove duplicates
872 -- when we have usages on several subordinates of a single parent,
873 -- and (b) that the usages emerge in a canonical order, which
874 -- is why we use FiniteMap rather than OccEnv: FiniteMap works
875 -- using Ord on the OccNames, which is a lexicographic ordering.
876 ent_hashs :: FiniteMap OccName Fingerprint
877 ent_hashs = listToFM (map lookup_occ used_occs)
881 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
884 depend_on_exports mod =
885 case lookupModuleEnv direct_imports mod of
887 -- Even if we used 'import M ()', we have to register a
888 -- usage on the export list because we are sensitive to
889 -- changes in orphan instances/rules.
891 -- In GHC 6.8.x the above line read "True", and in
892 -- fact it recorded a dependency on *all* the
893 -- modules underneath in the dependency tree. This
894 -- happens to make orphans work right, but is too
895 -- expensive: it'll read too many interface files.
896 -- The 'isNothing maybe_iface' check above saved us
897 -- from generating many of these usages (at least in
898 -- one-shot mode), but that's even more bogus!
902 mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
903 mkIfaceAnnotations = map mkIfaceAnnotation
905 mkIfaceAnnotation :: Annotation -> IfaceAnnotation
906 mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation {
907 ifAnnotatedTarget = fmap nameOccName target,
908 ifAnnotatedValue = serialized
913 mkIfaceExports :: [AvailInfo]
914 -> [(Module, [GenAvailInfo OccName])]
915 -- Group by module and sort by occurrence
916 mkIfaceExports exports
917 = [ (mod, eltsFM avails)
918 | (mod, avails) <- sortBy (stableModuleCmp `on` fst)
919 (moduleEnvToList groupFM)
920 -- NB. the fmToList is in a random order,
921 -- because Ord Module is not a predictable
922 -- ordering. Hence we perform a final sort
923 -- using the stable Module ordering.
926 -- Group by the module where the exported entities are defined
927 -- (which may not be the same for all Names in an Avail)
928 -- Deliberately use FiniteMap rather than UniqFM so we
929 -- get a canonical ordering
930 groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
931 groupFM = foldl add emptyModuleEnv exports
933 add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
934 -> Module -> GenAvailInfo OccName
935 -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
936 add_one env mod avail
937 = extendModuleEnv_C plusFM env mod
938 (unitFM (occNameFS (availName avail)) avail)
940 -- NB: we should not get T(X) and T(Y) in the export list
941 -- else the plusFM will simply discard one! They
942 -- should have been combined by now.
944 = ASSERT( isExternalName n )
945 add_one env (nameModule n) (Avail (nameOccName n))
947 add env (AvailTC tc ns)
948 = ASSERT( all isExternalName ns )
949 foldl add_for_mod env mods
951 tc_occ = nameOccName tc
952 mods = nub (map nameModule ns)
953 -- Usually just one, but see Note [Original module]
956 = add_one env mod (AvailTC tc_occ (sort names_from_mod))
957 -- NB. sort the children, we need a canonical order
959 names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
962 Note [Orignal module]
963 ~~~~~~~~~~~~~~~~~~~~~
965 module X where { data family T }
966 module Y( T(..) ) where { import X; data instance T Int = MkT Int }
967 The exported Avail from Y will look like
970 - only MkT is brought into scope by the data instance;
971 - but the parent (used for grouping and naming in T(..) exports) is X.T
972 - and in this case we export X.T too
974 In the result of MkIfaceExports, the names are grouped by defining module,
975 so we may need to split up a single Avail into multiple ones.
978 %************************************************************************
980 Load the old interface file for this module (unless
981 we have it aleady), and check whether it is up to date
984 %************************************************************************
987 checkOldIface :: HscEnv
989 -> Bool -- Source unchanged
990 -> Maybe ModIface -- Old interface from compilation manager, if any
991 -> IO (RecompileRequired, Maybe ModIface)
993 checkOldIface hsc_env mod_summary source_unchanged maybe_iface
994 = do { showPass (hsc_dflags hsc_env)
995 ("Checking old interface for " ++
996 showSDoc (ppr (ms_mod mod_summary))) ;
998 ; initIfaceCheck hsc_env $
999 check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1002 check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
1003 -> IfG (Bool, Maybe ModIface)
1004 check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1005 = do -- CHECK WHETHER THE SOURCE HAS CHANGED
1006 { when (not source_unchanged)
1007 (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
1009 -- If the source has changed and we're in interactive mode, avoid reading
1010 -- an interface; just return the one we might have been supplied with.
1011 ; let dflags = hsc_dflags hsc_env
1012 ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
1013 return (outOfDate, maybe_iface)
1015 case maybe_iface of {
1016 Just old_iface -> do -- Use the one we already have
1017 { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
1018 ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
1019 ; return (recomp, Just old_iface) }
1023 -- Try and read the old interface for the current module
1024 -- from the .hi file left from the last time we compiled it
1025 { let iface_path = msHiFilePath mod_summary
1026 ; read_result <- readIface (ms_mod mod_summary) iface_path False
1027 ; case read_result of {
1028 Failed err -> do -- Old interface file not found, or garbled; give up
1029 { traceIf (text "FYI: cannot read old interface file:"
1031 ; return (outOfDate, Nothing) }
1033 ; Succeeded iface -> do
1035 -- We have got the old iface; check its versions
1036 { traceIf (text "Read the interface file" <+> text iface_path)
1037 ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
1038 ; return (recomp, Just iface)
1043 @recompileRequired@ is called from the HscMain. It checks whether
1044 a recompilation is required. It needs access to the persistent state,
1045 finder, etc, because it may have to load lots of interface files to
1046 check their versions.
1049 type RecompileRequired = Bool
1050 upToDate, outOfDate :: Bool
1051 upToDate = False -- Recompile not required
1052 outOfDate = True -- Recompile required
1054 checkVersions :: HscEnv
1055 -> Bool -- True <=> source unchanged
1057 -> ModIface -- Old interface
1058 -> IfG RecompileRequired
1059 checkVersions hsc_env source_unchanged mod_summary iface
1060 | not source_unchanged
1063 = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
1064 ppr (mi_module iface) <> colon)
1066 ; recomp <- checkDependencies hsc_env mod_summary iface
1067 ; if recomp then return outOfDate else do {
1069 -- Source code unchanged and no errors yet... carry on
1071 -- First put the dependent-module info, read from the old
1072 -- interface, into the envt, so that when we look for
1073 -- interfaces we look for the right one (.hi or .hi-boot)
1075 -- It's just temporary because either the usage check will succeed
1076 -- (in which case we are done with this module) or it'll fail (in which
1077 -- case we'll compile the module from scratch anyhow).
1079 -- We do this regardless of compilation mode, although in --make mode
1080 -- all the dependent modules should be in the HPT already, so it's
1082 updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
1084 ; let this_pkg = thisPackage (hsc_dflags hsc_env)
1085 ; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1088 -- This is a bit of a hack really
1089 mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1090 mod_deps = mkModDeps (dep_mods (mi_deps iface))
1093 -- If the direct imports of this module are resolved to targets that
1094 -- are not among the dependencies of the previous interface file,
1095 -- then we definitely need to recompile. This catches cases like
1096 -- - an exposed package has been upgraded
1097 -- - we are compiling with different package flags
1098 -- - a home module that was shadowing a package module has been removed
1099 -- - a new home module has been added that shadows a package module
1102 -- Returns True if recompilation is required.
1103 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1104 checkDependencies hsc_env summary iface
1105 = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1107 prev_dep_mods = dep_mods (mi_deps iface)
1108 prev_dep_pkgs = dep_pkgs (mi_deps iface)
1110 this_pkg = thisPackage (hsc_dflags hsc_env)
1112 orM = foldr f (return False)
1113 where f m rest = do b <- m; if b then return True else rest
1115 dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
1116 find_res <- liftIO $ findImportedModule hsc_env mod pkg
1120 -> if moduleName mod `notElem` map fst prev_dep_mods
1121 then do traceHiDiffs $
1122 text "imported module " <> quotes (ppr mod) <>
1123 text " not among previous dependencies"
1128 -> if pkg `notElem` prev_dep_pkgs
1129 then do traceHiDiffs $
1130 text "imported module " <> quotes (ppr mod) <>
1131 text " is from package " <> quotes (ppr pkg) <>
1132 text ", which is not among previous dependencies"
1136 where pkg = modulePackageId mod
1137 _otherwise -> return outOfDate
1139 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1140 -> IfG RecompileRequired
1141 needInterface mod continue
1142 = do -- Load the imported interface if possible
1143 let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1144 traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1146 mb_iface <- loadInterface doc_str mod ImportBySystem
1147 -- Load the interface, but don't complain on failure;
1148 -- Instead, get an Either back which we can test
1151 Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
1153 -- Couldn't find or parse a module mentioned in the
1154 -- old interface file. Don't complain: it might
1155 -- just be that the current module doesn't need that
1156 -- import and it's been deleted
1157 Succeeded iface -> continue iface
1160 checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
1161 -- Given the usage information extracted from the old
1162 -- M.hi file for the module being compiled, figure out
1163 -- whether M needs to be recompiled.
1165 checkModUsage _this_pkg UsagePackageModule{
1167 usg_mod_hash = old_mod_hash }
1168 = needInterface mod $ \iface -> do
1169 checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
1170 -- We only track the ABI hash of package modules, rather than
1171 -- individual entity usages, so if the ABI hash changes we must
1172 -- recompile. This is safe but may entail more recompilation when
1173 -- a dependent package has changed.
1175 checkModUsage this_pkg UsageHomeModule{
1176 usg_mod_name = mod_name,
1177 usg_mod_hash = old_mod_hash,
1178 usg_exports = maybe_old_export_hash,
1179 usg_entities = old_decl_hash }
1181 let mod = mkModule this_pkg mod_name
1182 needInterface mod $ \iface -> do
1185 new_mod_hash = mi_mod_hash iface
1186 new_decl_hash = mi_hash_fn iface
1187 new_export_hash = mi_exp_hash iface
1190 recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
1191 if not recompile then return upToDate else do
1193 -- CHECK EXPORT LIST
1194 checkMaybeHash maybe_old_export_hash new_export_hash
1195 (ptext (sLit " Export list changed")) $ do
1197 -- CHECK ITEMS ONE BY ONE
1198 recompile <- checkList [ checkEntityUsage new_decl_hash u
1199 | u <- old_decl_hash]
1201 then return outOfDate -- This one failed, so just bail out now
1202 else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
1204 ------------------------
1205 checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
1206 checkModuleFingerprint old_mod_hash new_mod_hash
1207 | new_mod_hash == old_mod_hash
1208 = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1211 = out_of_date_hash (ptext (sLit " Module fingerprint has changed"))
1212 old_mod_hash new_mod_hash
1214 ------------------------
1215 checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
1216 -> IfG RecompileRequired -> IfG RecompileRequired
1217 checkMaybeHash maybe_old_hash new_hash doc continue
1218 | Just hash <- maybe_old_hash, hash /= new_hash
1219 = out_of_date_hash doc hash new_hash
1223 ------------------------
1224 checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
1225 -> (OccName, Fingerprint)
1227 checkEntityUsage new_hash (name,old_hash)
1228 = case new_hash name of
1230 Nothing -> -- We used it before, but it ain't there now
1231 out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
1233 Just (_, new_hash) -- It's there, but is it up to date?
1234 | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
1236 | otherwise -> out_of_date_hash (ptext (sLit " Out of date:") <+> ppr name)
1239 up_to_date, out_of_date :: SDoc -> IfG Bool
1240 up_to_date msg = traceHiDiffs msg >> return upToDate
1241 out_of_date msg = traceHiDiffs msg >> return outOfDate
1243 out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
1244 out_of_date_hash msg old_hash new_hash
1245 = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1247 ----------------------
1248 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1249 -- This helper is used in two places
1250 checkList [] = return upToDate
1251 checkList (check:checks) = do recompile <- check
1253 then return outOfDate
1254 else checkList checks
1257 %************************************************************************
1259 Converting things to their Iface equivalents
1261 %************************************************************************
1264 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1265 -- Assumption: the thing is already tidied, so that locally-bound names
1266 -- (lambdas, for-alls) already have non-clashing OccNames
1267 -- Reason: Iface stuff uses OccNames, and the conversion here does
1268 -- not do tidying on the way
1269 tyThingToIfaceDecl (AnId id)
1270 = IfaceId { ifName = getOccName id,
1271 ifType = toIfaceType (idType id),
1272 ifIdDetails = toIfaceIdDetails (idDetails id),
1275 info = case toIfaceIdInfo (idInfo id) of
1277 items -> HasInfo items
1279 tyThingToIfaceDecl (AClass clas)
1280 = IfaceClass { ifCtxt = toIfaceContext sc_theta,
1281 ifName = getOccName clas,
1282 ifTyVars = toIfaceTvBndrs clas_tyvars,
1283 ifFDs = map toIfaceFD clas_fds,
1284 ifATs = map (tyThingToIfaceDecl . ATyCon) clas_ats,
1285 ifSigs = map toIfaceClassOp op_stuff,
1286 ifRec = boolToRecFlag (isRecursiveTyCon tycon) }
1288 (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
1289 = classExtraBigSig clas
1290 tycon = classTyCon clas
1292 toIfaceClassOp (sel_id, def_meth)
1293 = ASSERT(sel_tyvars == clas_tyvars)
1294 IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
1296 -- Be careful when splitting the type, because of things
1297 -- like class Foo a where
1298 -- op :: (?x :: String) => a -> a
1299 -- and class Baz a where
1300 -- op :: (Ord a) => a -> a
1301 (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1302 op_ty = funResultTy rho_ty
1304 toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
1306 tyThingToIfaceDecl (ATyCon tycon)
1308 = IfaceSyn { ifName = getOccName tycon,
1309 ifTyVars = toIfaceTvBndrs tyvars,
1312 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
1316 = IfaceData { ifName = getOccName tycon,
1317 ifTyVars = toIfaceTvBndrs tyvars,
1318 ifCtxt = toIfaceContext (tyConStupidTheta tycon),
1319 ifCons = ifaceConDecls (algTyConRhs tycon),
1320 ifRec = boolToRecFlag (isRecursiveTyCon tycon),
1321 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1322 ifGeneric = tyConHasGenerics tycon,
1323 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
1325 | isForeignTyCon tycon
1326 = IfaceForeign { ifName = getOccName tycon,
1327 ifExtName = tyConExtName tycon }
1329 | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
1331 tyvars = tyConTyVars tycon
1333 = case synTyConRhs tycon of
1334 OpenSynTyCon ki _ -> (Nothing, toIfaceType ki)
1335 SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
1337 ifaceConDecls (NewTyCon { data_con = con }) =
1338 IfNewTyCon (ifaceConDecl con)
1339 ifaceConDecls (DataTyCon { data_cons = cons }) =
1340 IfDataTyCon (map ifaceConDecl cons)
1341 ifaceConDecls OpenTyCon {} = IfOpenDataTyCon
1342 ifaceConDecls AbstractTyCon = IfAbstractTyCon
1343 -- The last case happens when a TyCon has been trimmed during tidying
1344 -- Furthermore, tyThingToIfaceDecl is also used
1345 -- in TcRnDriver for GHCi, when browsing a module, in which case the
1346 -- AbstractTyCon case is perfectly sensible.
1348 ifaceConDecl data_con
1349 = IfCon { ifConOcc = getOccName (dataConName data_con),
1350 ifConInfix = dataConIsInfix data_con,
1351 ifConWrapper = isJust (dataConWrapId_maybe data_con),
1352 ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
1353 ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
1354 ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
1355 ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
1356 ifConArgTys = map toIfaceType (dataConOrigArgTys data_con),
1357 ifConFields = map getOccName
1358 (dataConFieldLabels data_con),
1359 ifConStricts = dataConStrictMarks data_con }
1361 to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
1363 famInstToIface Nothing = Nothing
1364 famInstToIface (Just (famTyCon, instTys)) =
1365 Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
1367 tyThingToIfaceDecl (ADataCon dc)
1368 = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
1371 getFS :: NamedThing a => a -> FastString
1372 getFS x = occNameFS (getOccName x)
1374 --------------------------
1375 instanceToIfaceInst :: Instance -> IfaceInst
1376 instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
1377 is_cls = cls_name, is_tcs = mb_tcs })
1378 = ASSERT( cls_name == className cls )
1379 IfaceInst { ifDFun = dfun_name,
1381 ifInstCls = cls_name,
1382 ifInstTys = map do_rough mb_tcs,
1385 do_rough Nothing = Nothing
1386 do_rough (Just n) = Just (toIfaceTyCon_name n)
1388 dfun_name = idName dfun_id
1389 mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
1390 is_local name = nameIsLocalOrFrom mod name
1392 -- Compute orphanhood. See Note [Orphans] in IfaceSyn
1393 (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
1394 -- Slightly awkward: we need the Class to get the fundeps
1395 (tvs, fds) = classTvsFds cls
1396 arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
1397 orph | is_local cls_name = Just (nameOccName cls_name)
1398 | all isJust mb_ns = head mb_ns
1399 | otherwise = Nothing
1401 mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name
1402 -- that is not in the "determined" arguments
1403 mb_ns | null fds = [choose_one arg_names]
1404 | otherwise = map do_one fds
1405 do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
1406 , not (tv `elem` rtvs)]
1408 choose_one :: [NameSet] -> Maybe OccName
1409 choose_one nss = case nameSetToList (unionManyNameSets nss) of
1411 (n : _) -> Just (nameOccName n)
1413 --------------------------
1414 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1415 famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
1418 = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon
1419 , ifFamInstFam = fam
1420 , ifFamInstTys = map do_rough mb_tcs }
1422 do_rough Nothing = Nothing
1423 do_rough (Just n) = Just (toIfaceTyCon_name n)
1425 --------------------------
1426 toIfaceLetBndr :: Id -> IfaceLetBndr
1427 toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
1428 (toIfaceType (idType id))
1431 -- Stripped-down version of tcIfaceIdInfo
1432 -- Change this if you want to export more IdInfo for
1433 -- non-top-level Ids. Don't forget to change
1434 -- CoreTidy.tidyLetBndr too!
1436 -- See Note [IdInfo on nested let-bindings] in IfaceSyn
1438 inline_prag = inlinePragInfo id_info
1439 prag_info | isDefaultInlinePragma inline_prag = NoInfo
1440 | otherwise = HasInfo [HsInline inline_prag]
1442 --------------------------
1443 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
1444 toIfaceIdDetails VanillaId = IfVanillaId
1445 toIfaceIdDetails DFunId = IfVanillaId
1446 toIfaceIdDetails (RecSelId { sel_naughty = n
1447 , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
1448 toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
1449 IfVanillaId -- Unexpected
1451 toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
1452 toIfaceIdInfo id_info
1453 = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
1454 inline_hsinfo, wrkr_hsinfo, unfold_hsinfo]
1456 ------------ Arity --------------
1457 arity_info = arityInfo id_info
1458 arity_hsinfo | arity_info == 0 = Nothing
1459 | otherwise = Just (HsArity arity_info)
1461 ------------ Caf Info --------------
1462 caf_info = cafInfo id_info
1463 caf_hsinfo = case caf_info of
1464 NoCafRefs -> Just HsNoCafRefs
1467 ------------ Strictness --------------
1468 -- No point in explicitly exporting TopSig
1469 strict_hsinfo = case newStrictnessInfo id_info of
1470 Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
1473 ------------ Worker --------------
1474 work_info = workerInfo id_info
1475 has_worker = workerExists work_info
1476 wrkr_hsinfo = case work_info of
1477 HasWorker work_id wrap_arity ->
1478 Just (HsWorker ((idName work_id)) wrap_arity)
1481 ------------ Unfolding --------------
1482 -- The unfolding is redundant if there is a worker
1483 unfold_info = unfoldingInfo id_info
1484 rhs = unfoldingTemplate unfold_info
1485 no_unfolding = neverUnfold unfold_info
1486 -- The CoreTidy phase retains unfolding info iff
1487 -- we want to expose the unfolding, taking into account
1488 -- unconditional NOINLINE, etc. See TidyPgm.addExternal
1489 unfold_hsinfo | no_unfolding = Nothing
1490 | has_worker = Nothing -- Unfolding is implicit
1491 | otherwise = Just (HsUnfold (toIfaceExpr rhs))
1493 ------------ Inline prag --------------
1494 inline_prag = inlinePragInfo id_info
1495 inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
1496 | no_unfolding && not has_worker
1497 && isFunLike (inlinePragmaRuleMatchInfo inline_prag)
1499 -- If the iface file give no unfolding info, we
1500 -- don't need to say when inlining is OK!
1501 | otherwise = Just (HsInline inline_prag)
1503 --------------------------
1504 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
1505 coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
1506 = pprTrace "toHsRule: builtin" (ppr fn) $
1509 coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
1510 ru_act = act, ru_bndrs = bndrs,
1511 ru_args = args, ru_rhs = rhs })
1512 = IfaceRule { ifRuleName = name, ifActivation = act,
1513 ifRuleBndrs = map toIfaceBndr bndrs,
1515 ifRuleArgs = map do_arg args,
1516 ifRuleRhs = toIfaceExpr rhs,
1519 -- For type args we must remove synonyms from the outermost
1520 -- level. Reason: so that when we read it back in we'll
1521 -- construct the same ru_rough field as we have right now;
1523 do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1524 do_arg arg = toIfaceExpr arg
1526 -- Compute orphanhood. See Note [Orphans] in IfaceSyn
1527 -- A rule is an orphan only if none of the variables
1528 -- mentioned on its left-hand side are locally defined
1529 lhs_names = fn : nameSetToList (exprsFreeNames args)
1530 -- No need to delete bndrs, because
1531 -- exprsFreeNames finds only External names
1533 orph = case filter (nameIsLocalOrFrom mod) lhs_names of
1534 (n : _) -> Just (nameOccName n)
1537 bogusIfaceRule :: Name -> IfaceRule
1538 bogusIfaceRule id_name
1539 = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
1540 ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
1541 ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
1543 ---------------------
1544 toIfaceExpr :: CoreExpr -> IfaceExpr
1545 toIfaceExpr (Var v) = toIfaceVar v
1546 toIfaceExpr (Lit l) = IfaceLit l
1547 toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
1548 toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
1549 toIfaceExpr (App f a) = toIfaceApp f [a]
1550 toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
1551 toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1552 toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co)
1553 toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
1555 ---------------------
1556 toIfaceNote :: Note -> IfaceNote
1557 toIfaceNote (SCC cc) = IfaceSCC cc
1558 toIfaceNote InlineMe = IfaceInlineMe
1559 toIfaceNote (CoreNote s) = IfaceCoreNote s
1561 ---------------------
1562 toIfaceBind :: Bind Id -> IfaceBinding
1563 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
1564 toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
1566 ---------------------
1567 toIfaceAlt :: (AltCon, [Var], CoreExpr)
1568 -> (IfaceConAlt, [FastString], IfaceExpr)
1569 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
1571 ---------------------
1572 toIfaceCon :: AltCon -> IfaceConAlt
1573 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
1574 | otherwise = IfaceDataAlt (getName dc)
1576 tc = dataConTyCon dc
1578 toIfaceCon (LitAlt l) = IfaceLitAlt l
1579 toIfaceCon DEFAULT = IfaceDefault
1581 ---------------------
1582 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
1583 toIfaceApp (App f a) as = toIfaceApp f (a:as)
1584 toIfaceApp (Var v) as
1585 = case isDataConWorkId_maybe v of
1586 -- We convert the *worker* for tuples into IfaceTuples
1587 Just dc | isTupleTyCon tc && saturated
1588 -> IfaceTuple (tupleTyConBoxity tc) tup_args
1590 val_args = dropWhile isTypeArg as
1591 saturated = val_args `lengthIs` idArity v
1592 tup_args = map toIfaceExpr val_args
1593 tc = dataConTyCon dc
1595 _ -> mkIfaceApps (toIfaceVar v) as
1597 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
1599 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
1600 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
1602 ---------------------
1603 toIfaceVar :: Id -> IfaceExpr
1605 | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
1606 -- Foreign calls have special syntax
1607 | isExternalName name = IfaceExt name
1608 | Just (TickBox m ix) <- isTickBoxOp_maybe v
1610 | otherwise = IfaceLcl (getFS name)