From: simonpj@microsoft.com <unknown>
Date: Wed, 25 Apr 2007 14:15:30 +0000 (+0000)
Subject: Improve hashing of expressions for CSE (reduces warnings about extendCSEnv)
X-Git-Tag: 2007-05-06~54
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=4550f26cb03baa3b1cb5eb81f5980a8ce0b300b9

Improve hashing of expressions for CSE (reduces warnings about extendCSEnv)
---

diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index 75198bb..883668b 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -260,8 +260,11 @@ localiseName n = n { n_sort = Internal }
 %************************************************************************
 
 \begin{code}
-hashName :: Name -> Int
-hashName name = getKey (nameUnique name)
+hashName :: Name -> Int		-- ToDo: should really be Word
+hashName name = getKey (nameUnique name) + 1
+	-- The +1 avoids keys with lots of zeros in the ls bits, which 
+	-- interacts badly with the cheap and cheerful multiplication in
+	-- hashExpr
 \end{code}
 
 
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index a43be02..d4d58df 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1386,10 +1386,10 @@ fast_hash_expr env other        = 1
 
 fast_hash_type :: HashEnv -> Type -> Word32
 fast_hash_type env ty 
-  | Just tv <- getTyVar_maybe ty          = hashVar env tv
-  | Just (tc,_) <- splitTyConApp_maybe ty
-                              = fromIntegral (hashName (tyConName tc))
-  | otherwise				  = 1
+  | Just tv <- getTyVar_maybe ty            = hashVar env tv
+  | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
+					      in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
+  | otherwise				    = 1
 
 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
 extend_env (n,env) b = (n+1, extendVarEnv env b n)
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index e7dd217..f8259c7 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -315,7 +315,9 @@ extendCSEnv (CS cs in_scope sub) expr expr'
   = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
   where
     hash   = hashExpr expr
-    combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
+    combine old new = WARN( result `lengthExceeds` 4, ((text "extendCSEnv: long list (length" <+> int (length result) <> comma 
+							<+> text "hash code" <+> text (show hash) <> char ')')
+							$$ nest 4 (ppr result)) )
 		      result
 		    where
 		      result = new ++ old