Don't dump simplifier iterations with -dverbose-core2core

[ghc-hetmet.git] / compiler / coreSyn / CoreLint.lhs

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 395c72a..bd88b5f 100644 (file)
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -17,7 +17,7 @@ A ``lint'' pass to check for Core correctness
 module CoreLint (
        lintCoreBindings,
        lintUnfolding, 
-       showPass, endPass
+       showPass, endPass, endIteration
     ) where
 
 #include "HsVersions.h"
@@ -62,7 +62,14 @@ and do Core Lint when necessary.
 
 \begin{code}
 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
-endPass dflags pass_name dump_flag binds
+endPass = dumpAndLint dumpIfSet_core
+
+endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endIteration = dumpAndLint dumpIfSet_dyn
+
+dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
+            -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+dumpAndLint dump dflags pass_name dump_flag binds
   = do 
        -- Report result size if required
        -- This has the side effect of forcing the intermediate to be evaluated
@@ -70,7 +77,7 @@ endPass dflags pass_name dump_flag binds
                (text "    Result size =" <+> int (coreBindsSize binds))
 
        -- Report verbosely, if required
-       dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
+       dump dflags dump_flag pass_name (pprCoreBindings binds)
 
        -- Type check
        lintCoreBindings dflags pass_name binds
@@ -519,9 +526,10 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
          {    -- Check the pattern
                 -- Scrutinee type must be a tycon applicn; checked by caller
                 -- This code is remarkably compact considering what it does!
-                -- NB: args must be in scope here so that the lintCoreArgs line works.
-                -- NB: relies on existential type args coming *after* ordinary type args
-
+                -- NB: args must be in scope here so that the lintCoreArgs
+                --     line works. 
+                -- NB: relies on existential type args coming *after*
+                --     ordinary type args 
          ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
          ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) 
          }