Commit 583c87d0 authored by Simon Marlow's avatar Simon Marlow
Browse files

Fix #7215: we weren't calculating the hashes correctly for sub-binders

parent c6559131
......@@ -24,6 +24,7 @@ module IfaceSyn (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
......@@ -51,6 +52,10 @@ import Outputable
import FastString
import Module
import TysWiredIn ( eqTyConName )
import Fingerprint
import Binary
import System.IO.Unsafe
infixl 3 &&&
\end{code}
......@@ -448,6 +453,23 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
ifaceDeclImplicitBndrs _ = []
-- -----------------------------------------------------------------------------
-- The fingerprints of an IfaceDecl
-- We better give each name bound by the declaration a
-- different fingerprint! So we calculate the fingerprint of
-- each binder by combining the fingerprint of the whole
-- declaration with the name of the binder. (#5614, #7215)
ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)]
ifaceDeclFingerprints hash decl
= (ifName decl, hash) :
[ (occ, computeFingerprint' (hash,occ))
| occ <- ifaceDeclImplicitBndrs decl ]
where
computeFingerprint' =
unsafeDupablePerformIO
. computeFingerprint (panic "ifaceDeclFingerprints")
----------------------------- Printing IfaceDecl ------------------------------
instance Outputable IfaceDecl where
......
......@@ -530,25 +530,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
-- to assign fingerprints to all the OccNames that it binds, to
-- use when referencing those OccNames in later declarations.
--
-- We better give each name bound by the declaration a
-- different fingerprint! So we calculate the fingerprint of
-- each binder by combining the fingerprint of the whole
-- declaration with the name of the binder. (#5614)
extend_hash_env :: OccEnv (OccName,Fingerprint)
-> (Fingerprint,IfaceDecl)
-> IO (OccEnv (OccName,Fingerprint))
extend_hash_env env0 (hash,d) = do
let
sub_bndrs = ifaceDeclImplicitBndrs d
fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ)
--
sub_fps <- mapM fp_sub_bndr sub_bndrs
return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env1
(zip sub_bndrs sub_fps))
where
decl_name = ifName d
item = (decl_name, hash)
env1 = extendOccEnv env0 decl_name item
return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
(ifaceDeclFingerprints hash d))
--
(local_env, decls_w_hashes) <-
......
......@@ -744,6 +744,22 @@ emptyModIface mod
mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False }
-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
-> (OccName -> Maybe (OccName, Fingerprint))
mkIfaceHashCache pairs
= \occ -> lookupOccEnv env occ
where
env = foldr add_decl emptyOccEnv pairs
add_decl (v,d) env0 = foldr add env0 (ifaceDeclFingerprints v d)
where
add (occ,hash) env0 = extendOccEnv env0 occ (occ,hash)
emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
emptyIfaceHashCache _occ = Nothing
-- | The 'ModDetails' is essentially a cache for information in the 'ModIface'
-- for home modules only. Information relating to packages will be loaded into
-- global environments in 'ExternalPackageState'.
......@@ -1460,24 +1476,6 @@ class Monad m => MonadThings m where
lookupTyCon = liftM tyThingTyCon . lookupThing
\end{code}
\begin{code}
-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
-> (OccName -> Maybe (OccName, Fingerprint))
mkIfaceHashCache pairs
= \occ -> lookupOccEnv env occ
where
env = foldr add_decl emptyOccEnv pairs
add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclImplicitBndrs d)
where
decl_name = ifName d
env1 = extendOccEnv env0 decl_name (decl_name, v)
add_imp bndr env = extendOccEnv env bndr (decl_name, v)
emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
emptyIfaceHashCache _occ = Nothing
\end{code}
%************************************************************************
%* *
\subsection{Auxiliary types}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment