[commit: ghc] ghc-7.6: Fix #7215: we weren't calculating the hashes correctly for sub-binders (1aa031e)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.6

http://hackage.haskell.org/trac/ghc/changeset/1aa031e7013caf59f3297d29e81ed573eb306356

>---------------------------------------------------------------

commit 1aa031e7013caf59f3297d29e81ed573eb306356
Author: Simon Marlow <[email protected]>
Date:   Wed Sep 5 16:38:50 2012 +0100

    Fix #7215: we weren't calculating the hashes correctly for sub-binders
    
    MERGED from commit 583c87d00d2058b1a073ea1f5d7f4e0d92b7a9a4

>---------------------------------------------------------------

 compiler/iface/IfaceSyn.lhs |   22 ++++++++++++++++++++++
 compiler/iface/MkIface.lhs  |   17 ++---------------
 compiler/main/HscTypes.lhs  |   34 ++++++++++++++++------------------
 3 files changed, 40 insertions(+), 33 deletions(-)

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index bc5fc95..a41a9da 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -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
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index c94b19a..443a7ea 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -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) <- 
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 793740e..7c1f169 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -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}