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/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!
 
@@ -252,8 +250,7 @@ instance Ord SimplifierSwitch where
 
 
 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
-tagOf_SimplSwitch (MaxSimplifierIterations _)	= _ILIT(1)
-tagOf_SimplSwitch NoCaseOfCase			= _ILIT(2)
+tagOf_SimplSwitch NoCaseOfCase			= _ILIT(1)
 
 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!