Shorten debug messages

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

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index fc5b903..9a4c1eb 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -57,11 +57,13 @@ import StrictAnal   ( saBinds )
 import CprAnalyse       ( cprAnalyse )
 #endif
 import Vectorise        ( vectorise )
+import Util
 
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import IO              ( hPutStr, stderr )
 import Outputable
-import List            ( partition )
+import Control.Monad
+import List            ( partition, intersperse )
 import Maybes
 \end{code}
 
@@ -153,7 +155,7 @@ doCorePass CoreCSE                 = {-# SCC "CommonSubExpr" #-} trBinds  cseProgram
 doCorePass CoreLiberateCase           = {-# SCC "LiberateCase" #-}  liberateCase
 doCorePass CoreDoFloatInwards          = {-# SCC "FloatInwards" #-}  trBinds  floatInwards
 doCorePass (CoreDoFloatOutwards f)     = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
-doCorePass CoreDoStaticArgs           = {-# SCC "StaticArgs" #-}    trBinds  doStaticArgs
+doCorePass CoreDoStaticArgs           = {-# SCC "StaticArgs" #-}    trBindsU  doStaticArgs
 doCorePass CoreDoStrictness           = {-# SCC "Stranal" #-}       trBinds  dmdAnalPgm
 doCorePass CoreDoWorkerWrapper         = {-# SCC "WorkWrap" #-}      trBindsU wwTopBinds
 doCorePass CoreDoSpecialising          = {-# SCC "Specialise" #-}    trBindsU specProgram
@@ -337,12 +339,19 @@ updateBinders local_rules binds
                                -- arising from specialisation pragmas
 \end{code}
 
-
-We must do some gentle simplification on the template (but not the RHS)
-of each rule.  The case that forced me to add this was the fold/build rule,
+Note [Simplifying the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must do some gentle simplification on the lhs (template) of each
+rule.  The case that forced me to add this was the fold/build rule,
 which without simplification looked like:
        fold k z (build (/\a. g a))  ==>  ...
 This doesn't match unless you do eta reduction on the build argument.
+Similarly for a LHS like
+       augment g (build h) 
+we do not want to get
+       augment (\a. g a) (build h)
+otherwise we don't match when given an argument like
+       augment (\a. h a a) (build h)
 
 \begin{code}
 simplRule env rule@(BuiltinRule {})
@@ -373,11 +382,17 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 --     alone leaves tons of crud.
 -- Used (a) for user expressions typed in at the interactive prompt
 --     (b) the LHS and RHS of a RULE
+--     (c) Template Haskell splices
 --
 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 -- enforce that; it just simplifies the expression twice
 
+-- It's important that simplExprGently does eta reduction; see
+-- Note [Simplifying the left-hand side of a RULE] above.  The
+-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
+-- but only if -O is on.
+
 simplExprGently env expr = do
     expr1 <- simplExpr env (occurAnalyseExpr expr)
     simplExpr env (occurAnalyseExpr expr1)
@@ -463,8 +478,11 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
   where
     dflags        = hsc_dflags hsc_env
     phase_info    = case mode of
-                         SimplGently  -> "gentle"
-                         SimplPhase n -> show n
+                         SimplGently     -> "gentle"
+                         SimplPhase n ss -> shows n
+                                           . showString " ["
+                                           . showString (concat $ intersperse "," ss)
+                                           $ "]"
 
     dump_phase     = shouldDumpSimplPhase dflags mode
                   
@@ -476,17 +494,13 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
        -- about to begin, with '1' for the first
       | iteration_no > max_iterations  -- Stop if we've run out of iterations
       = do {
-#ifdef DEBUG
-           if  max_iterations > 2 then
-               hPutStr stderr ("NOTE: Simplifier still going after " ++ 
+           when (debugIsOn && (max_iterations > 2)) $
+                   hPutStr stderr ("NOTE: Simplifier still going after " ++ 
                                show max_iterations ++ 
                                " iterations; bailing out.  Size = " ++ show (coreBindsSize binds) ++ "\n" )
-           else 
-               return ();
-#endif
                -- Subtract 1 from iteration_no to get the
                -- number of iterations we actually completed
-           return ("Simplifier baled out", iteration_no - 1, counts, binds)
+           ; return ("Simplifier bailed out", iteration_no - 1, counts, binds)
        }
 
       -- Try and force thunks off the binds; significantly reduces