Commit b4229ab6 authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au

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.
parent aed0554e
......@@ -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
......
......@@ -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 })
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment