Less voluminous debug

[ghc-hetmet.git] / compiler / simplCore / CSE.lhs

diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 3cec4a1..11eec3e 100644 (file)
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -19,6 +19,7 @@ import CoreSyn
 import VarEnv  
 import CoreLint                ( showPass, endPass )
 import Outputable
+import StaticFlags     ( opt_PprStyle_Debug )
 import BasicTypes      ( isAlwaysActive )
 import Util            ( mapAccumL, lengthExceeds )
 import UniqFM
@@ -157,7 +158,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...
@@ -223,6 +224,7 @@ cseExpr env (Var v)            = Var (lookupSubst env v)
 cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
 cseExpr evn (Note InlineMe e)     = Note InlineMe e    -- See Note [INLINE and NOINLINE]
 cseExpr env (Note n e)            = Note n (cseExpr env e)
+cseExpr env (Cast e co)            = Cast (cseExpr env e) co
 cseExpr env (Lam b e)             = let (env', b') = addBinder env b
                                     in Lam b' (cseExpr env' e)
 cseExpr env (Let bind e)          = let (env', bind') = cseBind env bind
@@ -313,11 +315,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