+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
+
+-- ---------------------------------------------------------------------------
+-- 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)
+ where
+ decl_name = ifName d
+ item = (decl_name, hash)
+ env1 = extendOccEnv env0 decl_name item
+ add_imp bndr env = extendOccEnv env bndr item
+
+ --
+ (local_env, decls_w_hashes) <-
+ foldM fingerprint_group (emptyOccEnv, []) groups
+
+ -- the export hash of a module depends on the orphan hashes of the
+ -- orphan modules below us in the dependeny tree. This is the way
+ -- that changes in orphans get propagated all the way up the
+ -- dependency tree. We only care about orphan modules in the current
+ -- package, because changes to orphans outside this package will be
+ -- tracked by the usage on the ABI hash of package modules that we import.
+ let orph_mods = sortBy (compare `on` (moduleNameFS.moduleName))
+ . filter ((== this_pkg) . modulePackageId)
+ $ dep_orphs (mi_deps iface0)
+ dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
+
+ orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
+ (map IfaceInstABI orph_insts, orph_rules, fam_insts)
+
+ -- the export list hash doesn't depend on the fingerprints of
+ -- the Names it mentions, only the Names themselves, hence putNameLiterally.
+ export_hash <- computeFingerprint dflags putNameLiterally
+ (mi_exports iface0, orphan_hash, dep_orphan_hashes)
+
+ -- put the declarations in a canonical order, sorted by OccName
+ let sorted_decls = eltsFM $ listToFM $
+ [(ifName d, e) | e@(_, d) <- decls_w_hashes]
+
+ -- the ABI hash depends on:
+ -- - decls
+ -- - export list
+ -- - orphans
+ -- - deprecations
+ -- - XXX vect info?
+ mod_hash <- computeFingerprint dflags putNameLiterally
+ (map fst sorted_decls,
+ export_hash,
+ orphan_hash,
+ mi_deprecs iface0)
+
+ -- The interface hash depends on:
+ -- - the ABI hash, plus
+ -- - usages
+ -- - deps
+ -- - hpc
+ iface_hash <- computeFingerprint dflags putNameLiterally
+ (mod_hash,
+ mi_usages iface0,
+ mi_deps iface0,
+ mi_hpc iface0)
+
+ let
+ no_change_at_all = Just iface_hash == mb_old_fingerprint
+
+ final_iface = iface0 {
+ mi_mod_hash = mod_hash,
+ mi_iface_hash = iface_hash,
+ mi_exp_hash = export_hash,
+ mi_orphan_hash = orphan_hash,
+ mi_orphan = not (null orph_rules && null orph_insts),
+ mi_finsts = not . null $ mi_fam_insts iface0,
+ mi_decls = sorted_decls,
+ mi_hash_fn = lookupOccEnv local_env }
+ --
+ return (final_iface, no_change_at_all, pp_orphs)
projects / ghc-hetmet.git / blobdiff