Continue refactoring the core-to-core pipeline

This patch mainly concerns the plumbing for running
the passes and printing intermediate output

compiler/coreSyn/CoreLint.lhs

@@ -36,7 +36,6 @@ import BasicTypes
 import StaticFlags
 import ListSetOps
 import PrelNames
-import DynFlags
 import Outputable
 import FastString
 import Util
@@ -96,29 +95,11 @@ find an occurence of an Id, we fetch it from the in-scope set.
 
 
 \begin{code}
-lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
-
-lintCoreBindings dflags _whoDunnit _binds
-  | not (dopt Opt_DoCoreLinting dflags)
-  = return ()
-
-lintCoreBindings dflags whoDunnit binds
-  | isEmptyBag errs
-  = do { showPass dflags ("Core Linted result of " ++ whoDunnit)
-       ; unless (isEmptyBag warns || opt_NoDebugOutput) $ printDump $
-         (banner "warnings" $$ displayMessageBag warns)
-       ; return () }
-
-  | otherwise
-  = do { printDump (vcat [ banner "errors", displayMessageBag errs
-			 , ptext (sLit "*** Offending Program ***")
-			 , pprCoreBindings binds
-			 , ptext (sLit "*** End of Offense ***") ])
-
-       ; ghcExit dflags 1 }
+lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message)
+--   Returns (warnings, errors)
+lintCoreBindings binds
+  = initL (lint_binds binds)
   where
-    (warns, errs) = initL (lint_binds binds)
-
 	-- Put all the top-level binders in scope at the start
 	-- This is because transformation rules can bring something
 	-- into use 'unexpectedly'
@@ -128,13 +109,6 @@ lintCoreBindings dflags whoDunnit binds
 
     lint_bind (Rec prs)		= mapM_ (lintSingleBinding TopLevel Recursive) prs
     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
-
-    banner string = ptext (sLit "*** Core Lint")      <+> text string 
-                    <+> ptext (sLit ": in result of") <+> text whoDunnit 
-                    <+> ptext (sLit "***")
-
-displayMessageBag :: Bag Message -> SDoc
-displayMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
 \end{code}
 
 %************************************************************************
@@ -154,7 +128,7 @@ lintUnfolding :: SrcLoc
 
 lintUnfolding locn vars expr
   | isEmptyBag errs = Nothing
-  | otherwise       = Just (displayMessageBag errs)
+  | otherwise       = Just (pprMessageBag errs)
   where
     (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
                             addInScopeVars vars	           $

compiler/coreSyn/CorePrep.lhs

@@ -15,7 +15,7 @@ import PrelNames	( lazyIdKey, hasKey )
 import CoreUtils
 import CoreArity
 import CoreFVs
-import CoreMonad	( endPass )
+import CoreMonad	( endPass, CoreToDo(..) )
 import CoreSyn
 import Type
 import Coercion
@@ -147,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
-    endPass dflags "CorePrep" Opt_D_dump_prep binds_out []
+    endPass dflags CorePrep binds_out []
     return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr

compiler/deSugar/Desugar.lhs

@@ -28,7 +28,7 @@ import Module
 import RdrName
 import NameSet
 import Rules
-import CoreMonad	( endPass )
+import CoreMonad	( endPass, CoreToDo(..) )
 import ErrUtils
 import Outputable
 import SrcLoc
@@ -114,7 +114,7 @@ deSugar hsc_env
 	-- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
 	-- Lint result if necessary
-	; endPass dflags "Desugar" Opt_D_dump_ds ds_binds ds_rules
+	; endPass dflags CoreDesugar ds_binds ds_rules
 
 	-- Dump output
 	; doIfSet (dopt Opt_D_dump_ds dflags) 

compiler/main/ErrUtils.lhs

@@ -5,7 +5,7 @@
 
 \begin{code}
 module ErrUtils (
-	Message, mkLocMessage, printError,
+	Message, mkLocMessage, printError, pprMessageBag,
 	Severity(..),
 
 	ErrMsg, WarnMsg,
@@ -18,7 +18,7 @@ module ErrUtils (
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
-	dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+	dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or,
         mkDumpDoc, dumpSDoc,
 
 	--  * Messages during compilation
@@ -49,6 +49,9 @@ import System.IO
 
 type Message = SDoc
 
+pprMessageBag :: Bag Message -> SDoc
+pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
+
 data Severity
   = SevInfo
   | SevWarning
@@ -202,19 +205,6 @@ dumpIfSet flag hdr doc
   | not flag   = return ()
   | otherwise  = printDump (mkDumpDoc hdr doc)
 
-dumpIf_core :: Bool -> DynFlags -> DynFlag -> String -> SDoc -> IO ()
-dumpIf_core cond dflags dflag hdr doc
-  | cond
-    || verbosity dflags >= 4
-    || dopt Opt_D_verbose_core2core dflags
-  = dumpSDoc dflags dflag hdr doc
-
-  | otherwise = return ()
-
-dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
-dumpIfSet_core dflags flag hdr doc
-  = dumpIf_core (dopt flag dflags) dflags flag hdr doc
-
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
   | dopt flag dflags || verbosity dflags >= 4 

compiler/main/TidyPgm.lhs

@@ -18,6 +18,7 @@ import CoreFVs
 import CoreTidy
 import CoreMonad
 import CoreUtils
+import Rules
 import CoreArity	( exprArity, exprBotStrictness_maybe )
 import Class		( classSelIds )
 import VarEnv
@@ -38,11 +39,11 @@ import TyCon
 import Module
 import HscTypes
 import Maybes
-import ErrUtils
 import UniqSupply
 import Outputable
 import FastBool hiding ( fastOr )
 import Util
+import FastString
 
 import Data.List	( sortBy )
 import Data.IORef	( IORef, readIORef, writeIORef )
@@ -133,7 +134,7 @@ mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing
                  -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
 mkBootModDetails hsc_env exports type_env insts fam_insts
   = do	{ let dflags = hsc_dflags hsc_env 
-	; showPass dflags "Tidy [hoot] type env"
+	; showPass dflags CoreTidy
 
 	; let { insts'     = tidyInstances globaliseAndTidyId insts
 	      ; dfun_ids   = map instanceDFunId insts'
@@ -301,7 +302,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
 	      ; expose_all = dopt Opt_ExposeAllUnfoldings  dflags
 	      ; th	   = dopt Opt_TemplateHaskell      dflags
               }
-	; showPass dflags "Tidy Core"
+	; showPass dflags CoreTidy
 
     	; let { implicit_binds = getImplicitBinds type_env }
 
@@ -342,7 +343,15 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
 	      ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
 	      }
 
-   	; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules
+   	; endPass dflags CoreTidy all_tidy_binds tidy_rules
+
+	  -- If the endPass didn't print the rules, but ddump-rules is on, print now
+	; dumpIfSet (dopt Opt_D_dump_rules dflags 
+                     && (not (dopt Opt_D_dump_simpl dflags))) 
+		    CoreTidy
+                    (ptext (sLit "rules"))
+                    (pprRulesForUser tidy_rules)
+
         ; let dir_imp_mods = moduleEnvKeys dir_imps
 
 	; return (CgGuts { cg_module   = mod, 

compiler/simplCore/CoreMonad.lhs

@@ -36,13 +36,13 @@ module CoreMonad (
     getAnnotations, getFirstAnnotations,
     
     -- ** Debug output
-    endPass, endPassIf, endIteration,
+    showPass, endPass, endIteration, dumpIfSet,
 
     -- ** Screen output
     putMsg, putMsgS, errorMsg, errorMsgS, 
     fatalErrorMsg, fatalErrorMsgS, 
     debugTraceMsg, debugTraceMsgS,
-    dumpIfSet_dyn,
+    dumpIfSet_dyn, 
 
 #ifdef GHCI
     -- * Getting 'Name's
@@ -75,6 +75,7 @@ import TcRnMonad        ( TcM, initTc )
 import Outputable
 import FastString
 import qualified ErrUtils as Err
+import Bag
 import Maybes
 import UniqSupply
 import LazyUniqFM       ( UniqFM, mapUFM, filterUFM )
@@ -106,35 +107,80 @@ be, and it makes a conveneint place.  place for them.  They print out
 stuff before and after core passes, and do Core Lint when necessary.
 
 \begin{code}
-endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endPass = dumpAndLint Err.dumpIfSet_core
+showPass :: DynFlags -> CoreToDo -> IO ()
+showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
 
-endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
+endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
+endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
 
 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
-endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endIteration = dumpAndLint Err.dumpIfSet_dyn
+endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
+endIteration dflags pass n
+  = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
+                (Just Opt_D_dump_simpl_iterations)
 
-dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
-            -> DynFlags -> String -> DynFlag 
+dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
+dumpIfSet dump_me pass extra_info doc
+  = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
+
+dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
             -> [CoreBind] -> [CoreRule] -> IO ()
-dumpAndLint dump dflags pass_name dump_flag binds rules
+-- The "show_all" parameter says to print dump if -dverbose-core2core is on
+dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
   = do {  -- Report result size if required
 	  -- This has the side effect of forcing the intermediate to be evaluated
        ; Err.debugTraceMsg dflags 2 $
 		(text "    Result size =" <+> int (coreBindsSize binds))
 
 	-- Report verbosely, if required
-       ; dump dflags dump_flag pass_name
-              (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
+       ; let pass_name = showSDoc (ppr pass <+> extra_info)
+             dump_doc  = pprCoreBindings binds 
+                         $$ ppUnless (null rules) pp_rules
+
+       ; case mb_dump_flag of
+            Nothing        -> return ()
+            Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
+               where
+                 dump_flags | show_all  = [dump_flag, Opt_D_verbose_core2core]
+		 	    | otherwise = [dump_flag] 
 
 	-- Type check
-       ; lintCoreBindings dflags pass_name binds }
+       ; when (dopt Opt_DoCoreLinting dflags) $
+         do { let (warns, errs) = lintCoreBindings binds
+            ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
+            ; displayLintResults dflags pass warns errs binds  } }
   where
     pp_rules = vcat [ blankLine
                     , ptext (sLit "------ Local rules for imported ids --------")
                     , pprRules rules ]
+
+displayLintResults :: DynFlags -> CoreToDo
+                   -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
+                   -> IO ()
+displayLintResults dflags pass warns errs binds
+  | not (isEmptyBag errs)
+  = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
+			 , ptext (sLit "*** Offending Program ***")
+			 , pprCoreBindings binds
+			 , ptext (sLit "*** End of Offense ***") ])
+       ; Err.ghcExit dflags 1 }
+
+  | not (isEmptyBag warns)
+  , not opt_NoDebugOutput
+  , showLintWarnings pass
+  = printDump (banner "warnings" $$ Err.pprMessageBag warns)
+
+  | otherwise = return ()
+  where
+    banner string = ptext (sLit "*** Core Lint")      <+> text string 
+                    <+> ptext (sLit ": in result of") <+> ppr pass
+                    <+> ptext (sLit "***")
+
+showLintWarnings :: CoreToDo -> Bool
+-- Disable Lint warnings on the first simplifier pass, because
+-- there may be some INLINE knots still tied, which is tiresomely noisy
+showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
+showLintWarnings _                                     = True
 \end{code}
 
 
@@ -152,9 +198,9 @@ data CoreToDo           -- These are diff core-to-core passes,
 
   = CoreDoSimplify      -- The core-to-core simplifier.
         SimplifierMode
-        [SimplifierSwitch]
-                        -- Each run of the simplifier can take a different
-                        -- set of simplifier-specific flags.
+	Int		       -- Max iterations
+        [SimplifierSwitch]     -- Each run of the simplifier can take a different
+                               -- set of simplifier-specific flags.
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
@@ -164,7 +210,6 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoWorkerWrapper
   | CoreDoSpecialising
   | CoreDoSpecConstr
-  | CoreDoOldStrictness
   | CoreDoGlomBinds
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
@@ -173,7 +218,59 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
+  | CoreDesugar	 -- Not strictly a core-to-core pass, but produces
+                 -- Core output, and hence useful to pass to endPass
+
+  | CoreTidy
+  | CorePrep
+
+coreDumpFlag :: CoreToDo -> Maybe DynFlag
+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStaticArgs 	      = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStrictness 	      = Just Opt_D_dump_stranal
+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
+coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
+coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar	      = Just Opt_D_dump_ds 
+coreDumpFlag CoreTidy 		      = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep 		      = Just Opt_D_dump_prep
+
+coreDumpFlag CoreDoPrintCore         = Nothing
+coreDumpFlag (CoreDoRuleCheck {})    = Nothing
+coreDumpFlag CoreDoNothing           = Nothing
+coreDumpFlag CoreDoGlomBinds         = Nothing
+coreDumpFlag (CoreDoPasses {})       = Nothing
+
+instance Outputable CoreToDo where
+  ppr (CoreDoSimplify md n _)  = ptext (sLit "Simplifier") 
+                                 <+> ppr md
+                                 <+> ptext (sLit "max-iterations=") <> int n
+  ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
+  ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
+  ppr CoreLiberateCase         = ptext (sLit "Liberate case")
+  ppr CoreDoStaticArgs 	       = ptext (sLit "Static argument")
+  ppr CoreDoStrictness 	       = ptext (sLit "Demand analysis")
+  ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
+  ppr CoreDoSpecialising       = ptext (sLit "Specialise")
+  ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
+  ppr CoreCSE                  = ptext (sLit "Common sub-expression")
+  ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
+  ppr CoreDesugar	       = ptext (sLit "Desugar")
+  ppr CoreTidy 		       = ptext (sLit "Tidy Core")
+  ppr CorePrep 		       = ptext (sLit "CorePrep")
+  ppr CoreDoPrintCore          = ptext (sLit "Print core")
+  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
+  ppr CoreDoGlomBinds          = ptext (sLit "Glom binds")
+  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
+  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
+\end{code}
 
+\begin{code}
 data SimplifierMode             -- See comments in SimplMonad
   = SimplGently
 	{ sm_rules :: Bool	-- Whether RULES are enabled 
@@ -185,7 +282,7 @@ data SimplifierMode             -- See comments in SimplMonad
 
 instance Outputable SimplifierMode where
     ppr (SimplPhase { sm_num = n, sm_names = ss })
-       = int n <+> brackets (text (concat $ intersperse "," ss))
+       = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
     ppr (SimplGently { sm_rules = r, sm_inline = i }) 
        = ptext (sLit "gentle") <> 
            brackets (pp_flag r (sLit "rules") <> comma <>
@@ -194,15 +291,16 @@ instance Outputable SimplifierMode where
            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
 
 data SimplifierSwitch
-  = MaxSimplifierIterations Int
-  | NoCaseOfCase
+  = NoCaseOfCase
+\end{code}
+
 
+\begin{code}
 data FloatOutSwitches = FloatOutSwitches {
         floatOutLambdas :: Bool,     -- ^ True <=> float lambdas to top level
         floatOutConstants :: Bool    -- ^ True <=> float constants to top level,
                                      --            even if they do not escape a lambda
     }
-
 instance Outputable FloatOutSwitches where
     ppr = pprFloatOutSwitches
 
@@ -254,11 +352,10 @@ getCoreToDo dflags
 
     simpl_phase phase names iter
       = CoreDoPasses
-          [ maybe_strictness_before phase,
-            CoreDoSimplify (SimplPhase phase names) [
-              MaxSimplifierIterations iter
-            ],
-            maybe_rule_check phase
+          [ maybe_strictness_before phase
+          , CoreDoSimplify (SimplPhase phase names) 
+                           iter []
+          , maybe_rule_check phase
           ]
 
     vectorisation
@@ -284,6 +381,7 @@ getCoreToDo dflags
         -- initial simplify: mk specialiser happy: minimum effort please
     simpl_gently = CoreDoSimplify 
                        (SimplGently { sm_rules = True, sm_inline = False })
+                       max_iter
                        [
                         --      Simplify "gently"
                         -- Don't inline anything till full laziness has bitten
@@ -295,9 +393,8 @@ getCoreToDo dflags
                         -- Similarly, don't apply any rules until after full
                         -- laziness.  Notably, list fusion can prevent floating.
 
-            NoCaseOfCase,       -- Don't do case-of-case transformations.
+            NoCaseOfCase        -- Don't do case-of-case transformations.
                                 -- This makes full laziness work better
-            MaxSimplifierIterations max_iter
         ]
 
     core_todo =

compiler/simplCore/SimplCore.lhs

@@ -130,57 +130,55 @@ simplifyExpr dflags expr
 	}
 
 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
-doCorePasses passes guts = foldM (flip doCorePass) guts passes
+doCorePasses passes guts 
+  = foldM do_pass guts passes
+  where
+    do_pass guts CoreDoNothing = return guts
+    do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
+    do_pass guts pass 
+       = do { dflags <- getDynFlags
+       	    ; liftIO $ showPass dflags pass
+       	    ; guts' <- doCorePass pass guts
+       	    ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
+       	    ; return guts' }
 
 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
-doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
-                                       simplifyPgm mode sws
+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
+                                       simplifyPgm pass
 
 doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}   
-	   			       describePass "Common sub-expression" Opt_D_dump_cse $ 
 				       doPass cseProgram
 
 doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
-	   			       describePass "Liberate case" Opt_D_verbose_core2core $ 
                                        doPassD liberateCase
 
 doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
-                                       describePass "Float inwards" Opt_D_verbose_core2core $ 
                                        doPass floatInwards
 
 doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
-                                       describePassD (text "Float out" <+> parens (ppr f)) 
-                                                     Opt_D_verbose_core2core $ 
                                        doPassDUM (floatOutwards f)
 
 doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
-                                       describePass "Static argument" Opt_D_verbose_core2core $ 
                                        doPassU doStaticArgs
 
 doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
-                                       describePass "Demand analysis" Opt_D_dump_stranal $
                                        doPassDM dmdAnalPgm
 
 doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
-                                       describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
                                        doPassU wwTopBinds
 
 doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
-                                       describePassR "Specialise" Opt_D_dump_spec $ 
                                        doPassU specProgram
 
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
-                                       describePassR "SpecConstr" Opt_D_dump_spec $
                                        specConstrProgram
 
 doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}
-                                       describePass "Vectorisation" Opt_D_dump_vect $ 
                                        vectorise be
 
-doCorePass CoreDoGlomBinds              = dontDescribePass $ doPassDM  glomBinds
-doCorePass CoreDoPrintCore              = dontDescribePass $ observe   printCore
-doCorePass (CoreDoRuleCheck phase pat)  = dontDescribePass $ ruleCheck phase pat
-
+doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
+doCorePass CoreDoPrintCore              = observe   printCore
+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheck phase pat
 doCorePass CoreDoNothing                = return
 doCorePass (CoreDoPasses passes)        = doCorePasses passes
 \end{code}
@@ -192,30 +190,6 @@ doCorePass (CoreDoPasses passes)        = doCorePasses passes
 %************************************************************************
 
 \begin{code}
-
-dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-dontDescribePass = ($)
-
-describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePass name dflag pass guts = do
-    dflags <- getDynFlags
-    
-    liftIO $ Err.showPass dflags name
-    guts' <- pass guts
-    liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
-
-    return guts'
-
-describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePassD doc = describePass (showSDoc doc)
-
-describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePassR name dflag pass guts = do
-    guts' <- describePass name dflag pass guts
-    dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
-                (pprRulesForUser (rulesOfBinds (mg_binds guts')))
-    return guts'
-
 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
 
 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
@@ -468,26 +442,23 @@ glomBinds dflags binds
 %************************************************************************
 
 \begin{code}
-simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
-simplifyPgm mode switches
-  = describePassD doc Opt_D_dump_simpl_phases $ \guts -> 
-    do { hsc_env <- getHscEnv
+simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
+simplifyPgm pass guts
+  = do { hsc_env <- getHscEnv
        ; us <- getUniqueSupplyM
        ; rb <- getRuleBase
        ; liftIOWithCount $  
-       	 simplifyPgmIO mode switches hsc_env us rb guts }
-  where
-    doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) 
+       	 simplifyPgmIO pass hsc_env us rb guts }
 
-simplifyPgmIO :: SimplifierMode
-	      -> [SimplifierSwitch]
+simplifyPgmIO :: CoreToDo
 	      -> HscEnv
 	      -> UniqSupply
 	      -> RuleBase
 	      -> ModGuts
 	      -> IO (SimplCount, ModGuts)  -- New bindings
 
-simplifyPgmIO mode switches hsc_env us hpt_rule_base 
+simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
+              hsc_env us hpt_rule_base 
               guts@(ModGuts { mg_binds = binds, mg_rules = rules
                             , mg_fam_inst_env = fam_inst_env })
   = do {
@@ -505,10 +476,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
   where
     dflags     	 = hsc_dflags hsc_env
     dump_phase 	 = dumpSimplPhase dflags mode
-		   
-    sw_chkr	   = isAmongSimpl switches
-    max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
- 
+    sw_chkr	 = isAmongSimpl switches
     do_iteration :: UniqSupply
                  -> Int		-- Counts iterations
 		 -> SimplCount	-- Logs optimisations performed
@@ -587,7 +555,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
 	   let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
 
 		-- Dump the result of this iteration
-	   end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
+	   end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
 
 		-- Loop
   	   do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
@@ -596,18 +564,15 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
   	  (us1, us2) = splitUniqSupply us
 
 -------------------
-end_iteration :: DynFlags -> SimplifierMode -> Int -> Int 
+end_iteration :: DynFlags -> CoreToDo -> Int 
              -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
 -- Same as endIteration but with simplifier counts
-end_iteration dflags mode iteration_no max_iterations counts binds rules
-  = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
-		             (pprSimplCount counts) ;
+end_iteration dflags pass iteration_no counts binds rules
+  = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
+                   pass (ptext (sLit "Simplifier counts"))
+		   (pprSimplCount counts)
 
-       ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
-  where
-    pass_name = "Simplifier mode " ++ showPpr mode ++ 
-	     	", iteration " ++ show iteration_no ++
-	     	" out of " ++ show max_iterations
+       ; endIteration dflags pass iteration_no binds rules }
 \end{code}
 
 

compiler/simplCore/SimplMonad.lhs

@@ -201,8 +201,6 @@ isAmongSimpl on_switches		-- Switches mentioned later occur *earlier*
     -- (avoid some unboxing, bounds checking, and other horrible things:)
     \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
   where
-    mk_assoc_elem k@(MaxSimplifierIterations lvl)
-	= (iBox (tagOf_SimplSwitch k), SwInt lvl)
     mk_assoc_elem k
 	= (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!