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.

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 421f3b0..e903c6a 100644 (file)
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/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
 

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index fb87391..76658cc 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/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 })
 

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 0b61295..72d0e93 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/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

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index a7671a4..fc5b903 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/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