Allow -ddump-simpl-phases to specify which phases to dump

We can now say -ddump-simpl-phases=1,2 to dump only these two phases and
nothing else.

compiler/coreSyn/CoreLint.lhs

@@ -10,7 +10,7 @@ A ``lint'' pass to check for Core correctness
 module CoreLint (
 	lintCoreBindings,
 	lintUnfolding, 
-	showPass, endPass, endIteration
+	showPass, endPass, endPassIf, endIteration
     ) where
 
 #include "HsVersions.h"
@@ -57,6 +57,9 @@ and do Core Lint when necessary.
 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
 endPass = dumpAndLint dumpIfSet_core
 
+endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endPassIf cond = dumpAndLint (dumpIf_core cond)
+
 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
 endIteration = dumpAndLint dumpIfSet_dyn
 

compiler/main/DynFlags.hs

@@ -301,6 +301,7 @@ data DynFlags = DynFlags {
   optLevel		:: Int,		-- optimisation level
   simplPhases           :: Int,         -- number of simplifier phases
   maxSimplIterations    :: Int,		-- max simplifier iterations
+  shouldDumpSimplPhase  :: SimplifierMode -> Bool,
   ruleCheck		:: Maybe String,
 
   specConstrThreshold   :: Maybe Int,	-- Threshold for SpecConstr
@@ -492,6 +493,7 @@ defaultDynFlags =
 	optLevel		= 0,
         simplPhases             = 2,
 	maxSimplIterations	= 4,
+        shouldDumpSimplPhase    = const False,
 	ruleCheck		= Nothing,
 	specConstrThreshold	= Just 200,
         liberateCaseThreshold   = Just 200,
@@ -1116,7 +1118,7 @@ dynamic_flags = [
   ,  ( "ddump-rn",           	 setDumpFlag Opt_D_dump_rn)
   ,  ( "ddump-simpl",        	 setDumpFlag Opt_D_dump_simpl)
   ,  ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations)
-  ,  ( "ddump-simpl-phases",     setDumpFlag Opt_D_dump_simpl_phases)
+  ,  ( "ddump-simpl-phases",     OptPrefix setDumpSimplPhases)
   ,  ( "ddump-spec",         	 setDumpFlag Opt_D_dump_spec)
   ,  ( "ddump-prep",          	 setDumpFlag Opt_D_dump_prep)
   ,  ( "ddump-stg",          	 setDumpFlag Opt_D_dump_stg)
@@ -1135,7 +1137,7 @@ dynamic_flags = [
   ,  ( "ddump-simpl-stats",      setDumpFlag Opt_D_dump_simpl_stats)
   ,  ( "ddump-bcos",             setDumpFlag Opt_D_dump_BCOs)
   ,  ( "dsource-stats",          setDumpFlag Opt_D_source_stats)
-  ,  ( "dverbose-core2core",     setDumpFlag Opt_D_verbose_core2core)
+  ,  ( "dverbose-core2core",     NoArg setVerboseCore2Core)
   ,  ( "dverbose-stg2stg",       setDumpFlag Opt_D_verbose_stg2stg)
   ,  ( "ddump-hi",               setDumpFlag Opt_D_dump_hi)
   ,  ( "ddump-minimal-imports",  setDumpFlag Opt_D_dump_minimal_imports)
@@ -1466,6 +1468,36 @@ setDumpFlag dump_flag
 	-- Whenver we -ddump, switch off the recompilation checker,
 	-- else you don't see the dump!
 
+setVerboseCore2Core = do setDynFlag Opt_ForceRecomp
+                         setDynFlag Opt_D_verbose_core2core
+                         upd (\s -> s { shouldDumpSimplPhase = const True })
+
+setDumpSimplPhases s = do setDynFlag Opt_ForceRecomp
+                          upd (\s -> s { shouldDumpSimplPhase = spec })
+  where
+    spec = join (||)
+         . map (join (&&))
+         . map (map match)
+         . map (split '+')
+         . split ','
+         $ case s of
+             '=' : s' -> s'
+             _        -> s
+
+    join op [] = const True
+    join op ss = foldr1 (\f g x -> f x `op` g x) ss
+
+    match "" = const True
+    match s  = case reads s of
+                [(n,"")] -> phase_num  n
+                _        -> phase_name s
+
+    phase_num n (SimplPhase k) = n == k
+    phase_num _ _              = False
+
+    phase_name "gentle" SimplGently = True
+    phase_name _        _           = False
+
 setVerbosity :: Maybe Int -> DynP ()
 setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })
 

compiler/main/ErrUtils.lhs

@@ -16,7 +16,8 @@ module ErrUtils (
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
-	dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, dumpSDoc,
+	dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+        mkDumpDoc, dumpSDoc,
 
 	--  * Messages during compilation
 	putMsg,
@@ -195,13 +196,18 @@ 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
-  | dopt flag dflags
-	|| verbosity dflags >= 4
-	|| dopt Opt_D_verbose_core2core dflags
-  = dumpSDoc dflags flag hdr doc
-  | otherwise                                   = return ()
+  = dumpIf_core (dopt flag dflags) dflags flag hdr doc
 
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc

compiler/simplCore/SimplCore.lhs

@@ -17,7 +17,7 @@ module SimplCore ( core2core, simplifyExpr ) where
 
 import DynFlags		( CoreToDo(..), SimplifierSwitch(..),
 			  SimplifierMode(..), DynFlags, DynFlag(..), dopt,
-			  getCoreToDo )
+			  getCoreToDo, shouldDumpSimplPhase )
 import CoreSyn
 import HscTypes
 import CSE		( cseProgram )
@@ -35,7 +35,7 @@ import Simplify		( simplTopBinds, simplExpr )
 import SimplEnv		( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
 import SimplMonad
 import ErrUtils		( dumpIfSet, dumpIfSet_dyn, showPass )
-import CoreLint		( endPass, endIteration )
+import CoreLint		( endPassIf, endIteration )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FamInstEnv
@@ -448,14 +448,15 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
 	(termination_msg, it_count, counts_out, binds') 
 	   <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
 
-	dumpIfSet (dopt Opt_D_verbose_core2core dflags 
-                   && dopt Opt_D_dump_simpl_stats dflags)
+	dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
 		  "Simplifier statistics"
 		  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
 			 text "",
 			 pprSimplCount counts_out]);
 
-	endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_dump_simpl_phases binds';
+	endPassIf dump_phase dflags
+                  ("Simplify phase " ++ phase_info ++ " done")
+                  Opt_D_dump_simpl_phases binds';
 
 	return (counts_out, guts { mg_binds = binds' })
     }
@@ -464,6 +465,8 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts
     phase_info	   = case mode of
 		   	  SimplGently  -> "gentle"
 		   	  SimplPhase n -> show n
+
+    dump_phase     = shouldDumpSimplPhase dflags mode
 		   
     sw_chkr	   = isAmongSimpl switches
     max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2