------------------------------------------------------------------------------
--- Compute version numbers for local decls
-
-addVersionInfo
- :: (Name -> (OccName,Version)) -- lookup parents and versions of names
- -> Maybe ModIface -- The old interface, read from M.hi
- -> ModIface -- The new interface (lacking decls)
- -> [IfaceDecl] -- The new decls
- -> (ModIface, -- Updated interface
- Bool, -- True <=> no changes at all; no need to write Iface
- SDoc, -- Differences
- Maybe SDoc) -- Warnings about orphans
-
-addVersionInfo _ Nothing new_iface new_decls
--- No old interface, so definitely write a new one!
- = (new_iface { mi_orphan = not (null orph_insts && null orph_rules)
- , mi_finsts = not . null $ mi_fam_insts new_iface
- , mi_decls = [(initialVersion, decl) | decl <- new_decls]
- , mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion)
- new_decls)
- },
- False,
- ptext (sLit "No old interface file"),
- pprOrphans orph_insts orph_rules)
- where
- orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface)
- orph_rules = filter (isNothing . ifRuleOrph) (mi_rules new_iface)
-
-addVersionInfo ver_fn (Just old_iface@(ModIface {
- mi_mod_vers = old_mod_vers,
- mi_exp_vers = old_exp_vers,
- mi_rule_vers = old_rule_vers,
- mi_decls = old_decls,
- mi_ver_fn = old_decl_vers,
- mi_fix_fn = old_fixities }))
- new_iface@(ModIface { mi_fix_fn = new_fixities })
- new_decls
- | no_change_at_all
- = (old_iface, True, ptext (sLit "Interface file unchanged"), pp_orphs)
- | otherwise
- = (final_iface, False, vcat [ptext (sLit "Interface file has changed"),
- nest 2 pp_diffs], pp_orphs)
- where
- final_iface = new_iface {
- mi_mod_vers = bump_unless no_output_change old_mod_vers,
- mi_exp_vers = bump_unless no_export_change old_exp_vers,
- mi_rule_vers = bump_unless no_rule_change old_rule_vers,
- mi_orphan = not (null new_orph_rules && null new_orph_insts),
- mi_finsts = not . null $ mi_fam_insts new_iface,
- mi_decls = decls_w_vers,
- mi_ver_fn = mkIfaceVerCache decls_w_vers }
-
- decls_w_vers = [(add_vers decl, decl) | decl <- new_decls]
-
- -------------------
- (old_non_orph_insts, old_orph_insts) =
- mkOrphMap ifInstOrph (mi_insts old_iface)
- (new_non_orph_insts, new_orph_insts) =
- mkOrphMap ifInstOrph (mi_insts new_iface)
- old_fam_insts = mi_fam_insts old_iface
- new_fam_insts = mi_fam_insts new_iface
- same_insts occ = eqMaybeBy (eqListBy eqIfInst)
- (lookupOccEnv old_non_orph_insts occ)
- (lookupOccEnv new_non_orph_insts occ)
-
- (old_non_orph_rules, old_orph_rules) =
- mkOrphMap ifRuleOrph (mi_rules old_iface)
- (new_non_orph_rules, new_orph_rules) =
- mkOrphMap ifRuleOrph (mi_rules new_iface)
- same_rules occ = eqMaybeBy (eqListBy eqIfRule)
- (lookupOccEnv old_non_orph_rules occ)
- (lookupOccEnv new_non_orph_rules occ)
- -------------------
- -- Computing what changed
- no_output_change = no_decl_change && no_rule_change &&
- no_export_change && no_deprec_change
- no_export_change = mi_exports new_iface == mi_exports old_iface
- -- Kept sorted
- no_decl_change = isEmptyOccSet changed_occs
- no_rule_change = not (changedWrtNames changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules)
- || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)
- || changedWrtNames changed_occs (eqListBy eqIfFamInst old_fam_insts new_fam_insts))
- no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface
-
- -- If the usages havn't changed either, we don't need to write the interface file
- no_other_changes = mi_usages new_iface == mi_usages old_iface &&
- mi_deps new_iface == mi_deps old_iface &&
- mi_hpc new_iface == mi_hpc old_iface
- no_change_at_all = no_output_change && no_other_changes
-
- pp_diffs = vcat [pp_change no_export_change "Export list"
- (ppr old_exp_vers <+> arrow <+> ppr (mi_exp_vers final_iface)),
- pp_change no_rule_change "Rules"
- (ppr old_rule_vers <+> arrow <+> ppr (mi_rule_vers final_iface)),
- pp_change no_deprec_change "Deprecations" empty,
- pp_change no_other_changes "Usages" empty,
- pp_decl_diffs]
- pp_change True _ _ = empty
- pp_change False what info = text what <+> ptext (sLit "changed") <+> info
-
- -------------------
- old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls]
- same_fixity n = bool (old_fixities n == new_fixities n)
-
- -------------------
- -- Adding version info
- new_version = bumpVersion old_mod_vers
- -- Start from the old module version, not from
- -- zero so that if you remove f, and then add
- -- it again, you don't thereby reduce f's
- -- version number
-
- add_vers decl | occ `elemOccSet` changed_occs = new_version
- | otherwise = snd (expectJust "add_vers" (old_decl_vers occ))
- -- If it's unchanged, there jolly well
- where -- should be an old version number
- occ = ifName decl
-
- -------------------
- -- Deciding which declarations have changed
-
- -- For each local decl, the IfaceEq gives the list of things that
- -- must be unchanged for the declaration as a whole to be unchanged.
- eq_info :: [(OccName, IfaceEq)]
- eq_info = map check_eq new_decls
- check_eq new_decl
- | Just old_decl <- lookupOccEnv old_decl_env occ
- = (occ, new_decl `eqIfDecl` old_decl &&& eq_indirects new_decl)
- | otherwise {- No corresponding old decl -}
- = (occ, NotEqual)
+-- ---------------------------------------------------------------------------
+-- Compute fingerprints for the interface
+
+addFingerprints
+ :: HscEnv
+ -> Maybe Fingerprint -- the old fingerprint, if any
+ -> ModIface -- The new interface (lacking decls)
+ -> [IfaceDecl] -- The new decls
+ -> IO (ModIface, -- Updated interface
+ Bool, -- True <=> no changes at all;
+ -- no need to write Iface
+ Maybe SDoc) -- Warnings about orphans
+
+addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
+ = do
+ eps <- hscEPS hsc_env
+ let
+ -- the ABI of a declaration represents everything that is made
+ -- visible about the declaration that a client can depend on.
+ -- see IfaceDeclABI below.
+ declABI :: IfaceDecl -> IfaceDeclABI
+ declABI decl = (this_mod, decl, extras)
+ where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
+
+ edges :: [(IfaceDeclABI, Unique, [Unique])]
+ edges = [ (abi, getUnique (ifName decl), out)
+ | decl <- new_decls
+ , let abi = declABI decl
+ , let out = localOccs $ freeNamesDeclABI abi
+ ]
+
+ localOccs = map (getUnique . getParent . getOccName)
+ . filter ((== this_mod) . nameModule)
+ . nameSetToList
+ where getParent occ = lookupOccEnv parent_map occ `orElse` occ
+
+ -- maps OccNames to their parents in the current module.
+ -- e.g. a reference to a constructor must be turned into a reference
+ -- to the TyCon for the purposes of calculating dependencies.
+ parent_map :: OccEnv OccName
+ parent_map = foldr extend emptyOccEnv new_decls
+ where extend d env =
+ extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
+ where n = ifName d
+
+ -- strongly-connected groups of declarations, in dependency order
+ groups = stronglyConnComp edges
+
+ global_hash_fn = mkHashFun hsc_env eps
+
+ -- how to output Names when generating the data to fingerprint.
+ -- Here we want to output the fingerprint for each top-level
+ -- Name, whether it comes from the current module or another
+ -- module. In this way, the fingerprint for a declaration will
+ -- change if the fingerprint for anything it refers to (transitively)
+ -- changes.
+ mk_put_name :: (OccEnv (OccName,Fingerprint))
+ -> BinHandle -> Name -> IO ()
+ mk_put_name local_env bh name
+ | isWiredInName name = putNameLiterally bh name
+ -- wired-in names don't have fingerprints
+ | otherwise
+ = let hash | nameModule name /= this_mod = global_hash_fn name
+ | otherwise =
+ snd (lookupOccEnv local_env (getOccName name)
+ `orElse` pprPanic "urk! lookup local fingerprint"
+ (ppr name)) -- (undefined,fingerprint0))
+ in
+ put_ bh hash
+
+ -- take a strongly-connected group of declarations and compute
+ -- its fingerprint.
+
+ fingerprint_group :: (OccEnv (OccName,Fingerprint),
+ [(Fingerprint,IfaceDecl)])
+ -> SCC IfaceDeclABI
+ -> IO (OccEnv (OccName,Fingerprint),
+ [(Fingerprint,IfaceDecl)])
+
+ fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
+ = do let hash_fn = mk_put_name local_env
+ decl = abiDecl abi
+ -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
+ hash <- computeFingerprint dflags hash_fn abi
+ return (extend_hash_env (hash,decl) local_env,
+ (hash,decl) : decls_w_hashes)
+
+ fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
+ = do let decls = map abiDecl abis
+ local_env' = foldr extend_hash_env local_env
+ (zip (repeat fingerprint0) decls)
+ hash_fn = mk_put_name local_env'
+ -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
+ let stable_abis = sortBy cmp_abiNames abis
+ -- put the cycle in a canonical order
+ hash <- computeFingerprint dflags hash_fn stable_abis
+ let pairs = zip (repeat hash) decls
+ return (foldr extend_hash_env local_env pairs,
+ pairs ++ decls_w_hashes)
+
+ extend_hash_env :: (Fingerprint,IfaceDecl)
+ -> OccEnv (OccName,Fingerprint)
+ -> OccEnv (OccName,Fingerprint)
+ extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
projects / ghc-hetmet.git / blobdiff