X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCSE.lhs;h=66d6adc86ed9716de102a58d89c203c65462b205;hp=de5763b9fdb2a6716e9cada4c80e3eed94cbd8ef;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=bb394e57361d9910b05f1145cbc894d33759d2a6

diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index de5763b..66d6adc 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -4,6 +4,13 @@
 \section{Common subexpression}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CSE (
 	cseProgram
     ) where
@@ -19,9 +26,12 @@ import CoreSyn
 import VarEnv	
 import CoreLint		( showPass, endPass )
 import Outputable
+import StaticFlags	( opt_PprStyle_Debug )
 import BasicTypes	( isAlwaysActive )
-import Util		( mapAccumL, lengthExceeds )
+import Util		( lengthExceeds )
 import UniqFM
+
+import Data.List
 \end{code}
 
 
@@ -157,7 +167,7 @@ bar will be inlined (when it should not be). Even if we remove INLINE foo,
 we'd still like foo to be inlined if rhs is small. This won't happen
 with foo = bar.
 
-Not CSE-ing inside INLLINE also solves an annoying bug in CSE. Consider
+Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
 a worker/wrapper, in which the worker has turned into a single variable:
 	$wf = h
 	f = \x -> ...$wf...
@@ -314,11 +324,14 @@ addCSEnvItem env expr expr' | exprIsBig expr = env
 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 )
-		      result
-		    where
-		      result = new ++ old
+    hash = hashExpr expr
+    combine old new 
+	= WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
+	where
+	  result = new ++ old
+	  short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result)
+	  long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result 
+		   | otherwise	        = empty
 
 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
 			       Just y  -> y
@@ -330,7 +343,7 @@ addBinder :: CSEnv -> Id -> (CSEnv, Id)
 addBinder env@(CS cs in_scope sub) v
   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,		       v)
   | isId v			      = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
-  | not (isId v)		      = WARN( True, ppr v )
+  | otherwise			      = WARN( True, ppr v )
 				        (CS emptyUFM in_scope		      sub,		       v)
 	-- This last case is the unusual situation where we have shadowing of
 	-- a type variable; we have to discard the CSE mapping