Commit d4a19643 authored by ian@well-typed.com's avatar ian@well-typed.com

Refactor the way dump flags are handled

We were being inconsistent about how we tested whether dump flags
were enabled; in particular, sometimes we also checked the verbosity,
and sometimes we didn't.

This lead to oddities such as "ghc -v4" printing an "Asm code" section
which didn't contain any code, and "-v4" enabled some parts of
"-ddump-deriv" but not others.

Now all the tests use dopt, which also takes the verbosity into account
as appropriate.
parent 51da4ee2
......@@ -85,7 +85,7 @@ cpsTop hsc_env proc =
return call_pps
let noncall_pps = proc_points `setDifference` call_pps
when (not (setNull noncall_pps) && gopt Opt_D_dump_cmmz dflags) $
when (not (setNull noncall_pps) && dopt Opt_D_dump_cmmz dflags) $
pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
----------- Sink and inline assignments *before* stack layout -----------
......@@ -184,7 +184,7 @@ runUniqSM m = do
return (initUs_ us m)
dumpGraph :: DynFlags -> GeneralFlag -> String -> CmmGraph -> IO ()
dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
when (gopt Opt_DoCmmLinting dflags) $ do_lint g
dumpWith dflags flag name g
......@@ -195,12 +195,12 @@ dumpGraph dflags flag name g = do
}
Nothing -> return ()
dumpWith :: Outputable a => DynFlags -> GeneralFlag -> String -> a -> IO ()
dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO ()
dumpWith dflags flag txt g = do
-- ToDo: No easy way of say "dump all the cmmz, *and* split
-- them into files." Also, -ddump-cmmz doesn't play nicely
-- with -ddump-to-file, since the headers get omitted.
dumpIfSet_dyn dflags flag txt (ppr g)
when (not (gopt flag dflags)) $
when (not (dopt flag dflags)) $
dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
......@@ -76,7 +76,7 @@ import Unique
import UniqSupply
import Maybes
import ErrUtils
import DynFlags ( DynFlags, GeneralFlag(..) )
import DynFlags
import BasicTypes ( isAlwaysActive )
import Util
import Pair
......
......@@ -908,7 +908,7 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
| active_unfolding -> tryUnfolding dflags id lone_variable
arg_infos cont_info unf_template is_top
is_wf is_exp uf_arity guidance
| gopt Opt_D_dump_inlinings dflags && gopt Opt_D_verbose_core2core dflags
| dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
-> pprTrace "Inactive unfolding:" (ppr id) Nothing
| otherwise -> Nothing
NoUnfolding -> Nothing
......@@ -923,7 +923,7 @@ tryUnfolding dflags id lone_variable
is_wf is_exp uf_arity guidance
-- uf_arity will typically be equal to (idArity id),
-- but may be less for InlineRules
| gopt Opt_D_dump_inlinings dflags && gopt Opt_D_verbose_core2core dflags
| dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
= pprTrace ("Considering inlining: " ++ showSDocDump dflags (ppr id))
(vcat [text "arg infos" <+> ppr arg_infos,
text "uf arity" <+> ppr uf_arity,
......
......@@ -106,7 +106,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
hashNo <- writeMixEntries dflags mod count entries orig_file2
modBreaks <- mkModBreaks dflags count entries
doIfSet_dyn dflags Opt_D_dump_ticked $
when (dopt Opt_D_dump_ticked dflags) $
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(pprLHsBinds binds1)
......
......@@ -23,6 +23,7 @@ import DynFlags
import HsSyn
import TcHsSyn
import TcEvidence
import TcRnMonad
import Check
import CoreSyn
import Literal
......@@ -301,7 +302,7 @@ match vars@(v:_) ty eqns
; let grouped = groupEquations dflags tidy_eqns
-- print the view patterns that are commoned up to help debug
; whenGOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- mapM match_group grouped
; return (adjustMatchResult (foldr1 (.) aux_binds) $
......
......@@ -224,7 +224,7 @@ pprTypeAndContents id = do
--------------------------------------------------------------
-- Utils
traceOptIf :: GhcMonad m => GeneralFlag -> SDoc -> m ()
traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m ()
traceOptIf flag doc = do
dflags <- GHC.getSessionDynFlags
when (gopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc
when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc
......@@ -335,7 +335,7 @@ endMkDependHS dflags
dumpModCycles :: DynFlags -> [ModSummary] -> IO ()
dumpModCycles dflags mod_summaries
| not (gopt Opt_D_dump_mod_cycles dflags)
| not (dopt Opt_D_dump_mod_cycles dflags)
= return ()
| null cycles
......
......@@ -13,6 +13,7 @@
module DynFlags (
-- * Dynamic flags and associated configuration types
DumpFlag(..),
GeneralFlag(..),
WarningFlag(..),
ExtensionFlag(..),
......@@ -21,15 +22,10 @@ module DynFlags (
FatalMessager, LogAction, FlushOut(..), FlushErr(..),
ProfAuto(..),
glasgowExtsFlags,
gopt,
gopt_set,
gopt_unset,
wopt,
wopt_set,
wopt_unset,
xopt,
xopt_set,
xopt_unset,
dopt,
gopt, gopt_set, gopt_unset,
wopt, wopt_set, wopt_unset,
xopt, xopt_set, xopt_unset,
lang_set,
DynFlags(..),
HasDynFlags(..), ContainsDynFlags(..),
......@@ -169,8 +165,7 @@ import qualified Data.IntSet as IntSet
-- -----------------------------------------------------------------------------
-- DynFlags
-- | Enumerates the simple on-or-off dynamic flags
data GeneralFlag
data DumpFlag
-- debugging flags
= Opt_D_dump_cmm
......@@ -234,15 +229,21 @@ data GeneralFlag
| Opt_D_dump_ticked
| Opt_D_dump_rtti
| Opt_D_source_stats
| Opt_D_verbose_core2core
| Opt_D_verbose_stg2stg
| Opt_D_dump_hi
| Opt_D_dump_hi_diffs
| Opt_D_dump_minimal_imports
| Opt_D_dump_mod_cycles
| Opt_D_dump_view_pattern_commoning
| Opt_D_verbose_core2core
deriving (Eq, Show, Enum)
-- | Enumerates the simple on-or-off dynamic flags
data GeneralFlag
= Opt_DumpToFile -- ^ Append dump output to files instead of stdout.
| Opt_D_faststring_stats
| Opt_DumpToFile -- ^ Append dump output to files instead of stdout.
| Opt_D_dump_minimal_imports
| Opt_DoCoreLinting
| Opt_DoStgLinting
| Opt_DoCmmLinting
......@@ -639,7 +640,8 @@ data DynFlags = DynFlags {
generatedDumps :: IORef (Set FilePath),
-- hsc dynamic flags
flags :: IntSet,
dumpFlags :: IntSet,
generalFlags :: IntSet,
warningFlags :: IntSet,
-- Don't change this without updating extensionFlags:
language :: Maybe Language,
......@@ -1194,7 +1196,8 @@ defaultDynFlags mySettings =
filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean",
generatedDumps = panic "defaultDynFlags: No generatedDumps",
haddockOptions = Nothing,
flags = IntSet.fromList (map fromEnum (defaultFlags mySettings)),
dumpFlags = IntSet.empty,
generalFlags = IntSet.fromList (map fromEnum (defaultFlags mySettings)),
warningFlags = IntSet.fromList (map fromEnum standardWarnings),
ghciScripts = [],
language = Nothing,
......@@ -1343,17 +1346,50 @@ languageExtensions (Just Haskell2010)
Opt_DoAndIfThenElse,
Opt_RelaxedPolyRec]
-- | Test whether a 'DumpFlag' is set
dopt :: DumpFlag -> DynFlags -> Bool
dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)
|| (verbosity dflags >= 4 && enableIfVerbose f)
where enableIfVerbose Opt_D_dump_tc_trace = False
enableIfVerbose Opt_D_dump_rn_trace = False
enableIfVerbose Opt_D_dump_cs_trace = False
enableIfVerbose Opt_D_dump_if_trace = False
enableIfVerbose Opt_D_dump_vt_trace = False
enableIfVerbose Opt_D_dump_tc = False
enableIfVerbose Opt_D_dump_rn = False
enableIfVerbose Opt_D_dump_rn_stats = False
enableIfVerbose Opt_D_dump_hi_diffs = False
enableIfVerbose Opt_D_verbose_core2core = False
enableIfVerbose Opt_D_verbose_stg2stg = False
enableIfVerbose Opt_D_dump_splices = False
enableIfVerbose Opt_D_dump_rule_firings = False
enableIfVerbose Opt_D_dump_rule_rewrites = False
enableIfVerbose Opt_D_dump_rtti = False
enableIfVerbose Opt_D_dump_inlinings = False
enableIfVerbose Opt_D_dump_core_stats = False
enableIfVerbose Opt_D_dump_asm_stats = False
enableIfVerbose Opt_D_dump_types = False
enableIfVerbose Opt_D_dump_simpl_iterations = False
enableIfVerbose Opt_D_dump_ticked = False
enableIfVerbose Opt_D_dump_view_pattern_commoning = False
enableIfVerbose Opt_D_dump_mod_cycles = False
enableIfVerbose _ = True
-- | Set a 'DumpFlag'
dopt_set :: DynFlags -> DumpFlag -> DynFlags
dopt_set dfs f = dfs{ dumpFlags = IntSet.insert (fromEnum f) (dumpFlags dfs) }
-- | Test whether a 'GeneralFlag' is set
gopt :: GeneralFlag -> DynFlags -> Bool
gopt f dflags = fromEnum f `IntSet.member` flags dflags
gopt f dflags = fromEnum f `IntSet.member` generalFlags dflags
-- | Set a 'GeneralFlag'
gopt_set :: DynFlags -> GeneralFlag -> DynFlags
gopt_set dfs f = dfs{ flags = IntSet.insert (fromEnum f) (flags dfs) }
gopt_set dfs f = dfs{ generalFlags = IntSet.insert (fromEnum f) (generalFlags dfs) }
-- | Unset a 'GeneralFlag'
gopt_unset :: DynFlags -> GeneralFlag -> DynFlags
gopt_unset dfs f = dfs{ flags = IntSet.delete (fromEnum f) (flags dfs) }
gopt_unset dfs f = dfs{ generalFlags = IntSet.delete (fromEnum f) (generalFlags dfs) }
-- | Test whether a 'WarningFlag' is set
wopt :: WarningFlag -> DynFlags -> Bool
......@@ -2013,13 +2049,13 @@ dynamic_flags = [
setVerboseCore2Core))
, Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg)
, Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi)
, Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports)
, Flag "ddump-minimal-imports" (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))
, Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect)
, Flag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat
, Flag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked)
, Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles)
, Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning)
, Flag "ddump-to-file" (setDumpFlag Opt_DumpToFile)
, Flag "ddump-to-file" (NoArg (setGeneralFlag Opt_DumpToFile))
, Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs)
, Flag "ddump-rtti" (setDumpFlag Opt_D_dump_rtti)
, Flag "dcore-lint" (NoArg (setGeneralFlag Opt_DoCoreLinting))
......@@ -2786,7 +2822,7 @@ optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)
-> OptKind (CmdLineP DynFlags)
optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))
setDumpFlag :: GeneralFlag -> OptKind (CmdLineP DynFlags)
setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)
setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
--------------------------
......@@ -2831,16 +2867,15 @@ alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags
alterSettings f dflags = dflags { settings = f (settings dflags) }
--------------------------
setDumpFlag' :: GeneralFlag -> DynP ()
setDumpFlag' :: DumpFlag -> DynP ()
setDumpFlag' dump_flag
= do setGeneralFlag dump_flag
= do upd (\dfs -> dopt_set dfs dump_flag)
when want_recomp forceRecompile
where
-- Certain dumpy-things are really interested in what's going
-- on during recompilation checking, so in those cases we
-- don't want to turn it off.
want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,
Opt_D_dump_hi_diffs]
where -- Certain dumpy-things are really interested in what's going
-- on during recompilation checking, so in those cases we
-- don't want to turn it off.
want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,
Opt_D_dump_hi_diffs]
forceRecompile :: DynP ()
-- Whenver we -ddump, force recompilation (by switching off the
......@@ -2853,8 +2888,7 @@ forceRecompile = do dfs <- liftEwM getCmdLineState
force_recomp dfs = isOneShot (ghcMode dfs)
setVerboseCore2Core :: DynP ()
setVerboseCore2Core = do forceRecompile
setGeneralFlag Opt_D_verbose_core2core
setVerboseCore2Core = do setDumpFlag' Opt_D_verbose_core2core
upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing })
setDumpSimplPhases :: String -> DynP ()
......
......@@ -206,9 +206,9 @@ dumpIfSet dflags flag hdr doc
| not flag = return ()
| otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
dumpIfSet_dyn :: DynFlags -> GeneralFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| gopt flag dflags || verbosity dflags >= 4
| dopt flag dflags
= dumpSDoc dflags flag hdr doc
| otherwise
= return ()
......@@ -229,7 +229,7 @@ mkDumpDoc hdr doc
--
-- When hdr is empty, we print in a more compact format (no separators and
-- blank lines)
dumpSDoc :: DynFlags -> GeneralFlag -> String -> SDoc -> IO ()
dumpSDoc :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDoc dflags flag hdr doc
= do let mFile = chooseDumpFile dflags flag
case mFile of
......@@ -263,7 +263,7 @@ dumpSDoc dflags flag hdr doc
-- | Choose where to put a dump file based on DynFlags
--
chooseDumpFile :: DynFlags -> GeneralFlag -> Maybe String
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String
chooseDumpFile dflags flag
| gopt Opt_DumpToFile dflags
......@@ -289,11 +289,13 @@ chooseDumpFile dflags flag
Nothing -> f
-- | Build a nice file name from name of a GeneralFlag constructor
beautifyDumpName :: GeneralFlag -> String
beautifyDumpName :: DumpFlag -> String
beautifyDumpName flag
= let str = show flag
cut = if isPrefixOf "Opt_D_" str then drop 6 str else str
dash = map (\c -> if c == '_' then '-' else c) cut
= let str = show flag
suff = case stripPrefix "Opt_D_" str of
Just x -> x
Nothing -> panic ("Bad flag name: " ++ str)
dash = map (\c -> if c == '_' then '-' else c) suff
in dash
......
......@@ -1779,8 +1779,8 @@ dumpIfaceStats hsc_env = do
(ifaceStats eps)
where
dflags = hsc_dflags hsc_env
dump_rn_stats = gopt Opt_D_dump_rn_stats dflags
dump_if_trace = gopt Opt_D_dump_if_trace dflags
dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
dump_if_trace = dopt Opt_D_dump_if_trace dflags
{- **********************************************************************
......
......@@ -706,7 +706,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
++ "improvement for a type")) hsc_env
Just subst -> do
let dflags = hsc_dflags hsc_env
when (gopt Opt_D_dump_rtti dflags) $
when (dopt Opt_D_dump_rtti dflags) $
printInfoForUser dflags alwaysQualify $
fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
......
......@@ -373,14 +373,14 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- If the endPass didn't print the rules, but ddump-rules is
-- on, print now
; unless (gopt Opt_D_dump_simpl dflags) $
; unless (dopt Opt_D_dump_simpl dflags) $
Err.dumpIfSet_dyn dflags Opt_D_dump_rules
(showSDoc dflags (ppr CoreTidy <+> ptext (sLit "rules")))
(pprRulesForUser tidy_rules)
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
; when (gopt Opt_D_dump_core_stats dflags)
; when (dopt Opt_D_dump_core_stats dflags)
(log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(ptext (sLit "Tidy size (terms,types,coercions)")
<+> ppr (moduleName mod) <> colon
......
......@@ -356,8 +356,8 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
-- and then using 'seq' doesn't work, because the let
-- apparently gets inlined first.
lsPprNative <- return $!
if gopt Opt_D_dump_asm dflags
|| gopt Opt_D_dump_asm_stats dflags
if dopt Opt_D_dump_asm dflags
|| dopt Opt_D_dump_asm_stats dflags
then native
else []
......@@ -466,7 +466,7 @@ cmmNativeGen dflags ncgImpl us cmm count
$ zip [0..] regAllocStats)
let mPprStats =
if gopt Opt_D_dump_asm_stats dflags
if dopt Opt_D_dump_asm_stats dflags
then Just regAllocStats else Nothing
-- force evaluation of the Maybe to avoid space leak
......@@ -498,7 +498,7 @@ cmmNativeGen dflags ncgImpl us cmm count
(vcat $ map (pprNatCmmDecl ncgImpl) alloced)
let mPprStats =
if gopt Opt_D_dump_asm_stats dflags
if dopt Opt_D_dump_asm_stats dflags
then Just (catMaybes regAllocStats) else Nothing
-- force evaluation of the Maybe to avoid space leak
......
......@@ -91,9 +91,9 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
-- intermediate structures in the allocator - otherwise tell the
-- allocator to ditch them early so we don't end up creating space leaks.
let dump = or
[ gopt Opt_D_dump_asm_regalloc_stages dflags
, gopt Opt_D_dump_asm_stats dflags
, gopt Opt_D_dump_asm_conflicts dflags ]
[ dopt Opt_D_dump_asm_regalloc_stages dflags
, dopt Opt_D_dump_asm_stats dflags
, dopt Opt_D_dump_asm_conflicts dflags ]
-- check that we're not running off down the garden path.
when (spinCount > maxSpinCount)
......
......@@ -142,8 +142,8 @@ endPass dflags pass binds rules
; lintPassResult dflags pass binds }
where
mb_flag = case coreDumpFlag pass of
Just flag | gopt flag dflags -> Just flag
| gopt Opt_D_verbose_core2core dflags -> Just flag
Just flag | dopt flag dflags -> Just flag
| dopt Opt_D_verbose_core2core dflags -> Just flag
_ -> Nothing
dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
......@@ -151,7 +151,7 @@ dumpIfSet dflags dump_me pass extra_info doc
= Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
dumpPassResult :: DynFlags
-> Maybe GeneralFlag -- Just df => show details in a file whose
-> Maybe DumpFlag -- Just df => show details in a file whose
-- name is specified by df
-> SDoc -- Header
-> SDoc -- Extra info to appear after header
......@@ -265,7 +265,7 @@ data CoreToDo -- These are diff core-to-core passes,
\end{code}
\begin{code}
coreDumpFlag :: CoreToDo -> Maybe GeneralFlag
coreDumpFlag :: CoreToDo -> Maybe DumpFlag
coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_dump_core_pipeline
coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
......@@ -384,7 +384,7 @@ dumpSimplPhase dflags mode
| Just spec_string <- shouldDumpSimplPhase dflags
= match_spec spec_string
| otherwise
= gopt Opt_D_verbose_core2core dflags
= dopt Opt_D_verbose_core2core dflags
where
match_spec :: String -> Bool
......@@ -510,7 +510,7 @@ simplCountN (SimplCount { ticks = n }) = n
zeroSimplCount dflags
-- This is where we decide whether to do
-- the VerySimpl version or the full-stats version
| gopt Opt_D_dump_simpl_stats dflags
| dopt Opt_D_dump_simpl_stats dflags
= SimplCount {ticks = 0, details = Map.empty,
n_log = 0, log1 = [], log2 = []}
| otherwise
......@@ -1019,7 +1019,7 @@ debugTraceMsg :: SDoc -> CoreM ()
debugTraceMsg = msg (flip Err.debugTraceMsg 3)
-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
dumpIfSet_dyn :: GeneralFlag -> String -> SDoc -> CoreM ()
dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
\end{code}
......
......@@ -22,7 +22,7 @@ import MkCore
import CoreArity ( etaExpand )
import CoreMonad ( FloatOutSwitches(..) )
import DynFlags ( DynFlags, GeneralFlag(..) )
import DynFlags
import ErrUtils ( dumpIfSet_dyn )
import Id ( Id, idArity, isBottomingId )
import Var ( Var )
......
......@@ -497,7 +497,7 @@ simplifyExpr dflags expr
; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
simplExprGently (simplEnvForGHCi dflags) expr
; Err.dumpIfSet dflags (gopt Opt_D_dump_simpl_stats dflags)
; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics" (pprSimplCount counts)
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
......@@ -560,7 +560,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
= do { (termination_msg, it_count, counts_out, guts')
<- do_iteration us 1 [] binds rules
; Err.dumpIfSet dflags (dump_phase && gopt Opt_D_dump_simpl_stats dflags)
; Err.dumpIfSet dflags (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics for following pass"
(vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
blankLine,
......@@ -676,7 +676,7 @@ end_iteration dflags pass iteration_no counts binds rules
= do { dumpPassResult dflags mb_flag hdr pp_counts binds rules
; lintPassResult dflags pass binds }
where
mb_flag | gopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases
mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases
| otherwise = Nothing
-- Show details if Opt_D_dump_simpl_iterations is on
......
......@@ -218,7 +218,7 @@ simplTopBinds env0 binds0
-- See note [Glomming] in OccurAnal.
; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
; dflags <- getDynFlags
; let dump_flag = gopt Opt_D_verbose_core2core dflags
; let dump_flag = dopt Opt_D_verbose_core2core dflags
; env2 <- simpl_binds dump_flag env1 binds0
; freeTick SimplifierDone
; return env2 }
......@@ -1420,8 +1420,8 @@ completeCall env var cont
}}}
where
dump_inline dflags unfolding cont
| not (gopt Opt_D_dump_inlinings dflags) = return ()
| not (gopt Opt_D_verbose_core2core dflags)
| not (dopt Opt_D_dump_inlinings dflags) = return ()
| not (dopt Opt_D_verbose_core2core dflags)
= when (isExternalName (idName var)) $
liftIO $ printInfoForUser dflags alwaysQualify $
sep [text "Inlining done:", nest 4 (ppr var)]
......@@ -1571,14 +1571,14 @@ tryRules env rules fn args call_cont
; return (Just (ruleArity rule, rule_rhs)) }}}
where
dump dflags rule rule_rhs
| gopt Opt_D_dump_rule_rewrites dflags
| dopt Opt_D_dump_rule_rewrites dflags
= log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
[ text "Rule:" <+> ftext (ru_name rule)
, text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args))
, text "After: " <+> pprCoreExpr rule_rhs
, text "Cont: " <+> ppr call_cont ]
| gopt Opt_D_dump_rule_firings dflags
| dopt Opt_D_dump_rule_firings dflags
= log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
ftext (ru_name rule)
......
......@@ -16,8 +16,7 @@ import StgLint ( lintStgBindings )
import StgStats ( showStgStats )
import UnariseStg ( unarise )
import DynFlags ( DynFlags(..), GeneralFlag(..), gopt, StgToDo(..),
getStgToDo )
import DynFlags
import Module ( Module )
import ErrUtils
import SrcLoc
......@@ -37,8 +36,8 @@ stg2stg dflags module_name binds
= do { showPass dflags "Stg2Stg"
; us <- mkSplitUniqSupply 'g'
; doIfSet_dyn dflags Opt_D_verbose_stg2stg
(log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
; when (dopt Opt_D_verbose_stg2stg dflags)
(log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
......
......@@ -1779,7 +1779,7 @@ tcDump env
= do { dflags <- getDynFlags ;
-- Dump short output if -ddump-types or -ddump-tc
when (gopt Opt_D_dump_types dflags || gopt Opt_D_dump_tc dflags)
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(dumpTcRn short_dump) ;
-- Dump bindings if -ddump-tc
......@@ -1794,7 +1794,7 @@ tcDump env
tcCoreDump :: ModGuts -> TcM ()
tcCoreDump mod_guts
= do { dflags <- getDynFlags ;
when (gopt Opt_D_dump_types dflags || gopt Opt_D_dump_tc dflags)
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(dumpTcRn (pprModGuts mod_guts)) ;
-- Dump bindings if -ddump-tc
......
......@@ -263,6 +263,9 @@ Command-line flags
xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
......@@ -282,6 +285,10 @@ unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} )
-- | Do it flag is true
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM flag thing_inside = do b <- doptM flag
when b thing_inside
whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM flag thing_inside = do b <- goptM flag
when b thing_inside
......@@ -437,14 +444,14 @@ traceIf = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
traceOptIf :: GeneralFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
traceOptIf flag doc = whenGOptM flag $
traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
traceOptIf flag doc = whenDOptM flag $
do dflags <- getDynFlags
liftIO (printInfoForUser dflags alwaysQualify doc)
traceOptTcRn :: GeneralFlag -> SDoc -> TcRn ()
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
-- Output the message, with current location if opt_PprStyle_Debug
traceOptTcRn flag doc = whenGOptM flag $ do
traceOptTcRn flag doc = whenDOptM flag $ do
{ loc <- getSrcSpanM
; let real_doc
| opt_PprStyle_Debug = mkLocMessage SevInfo loc doc
......@@ -461,8 +468,8 @@ debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
| otherwise = dumpTcRn doc
dumpOptTcRn :: GeneralFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = whenGOptM flag (dumpTcRn doc)
dumpOptTcRn :: DumpFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = whenDOptM flag (dumpTcRn doc)
\end{code}
......@@ -654,7 +661,7 @@ reportWarning warn
dumpDerivingInfo :: SDoc -> TcM ()
dumpDerivingInfo doc
= do { dflags <- getDynFlags
; when (gopt Opt_D_dump_deriv dflags) $ do
; when (dopt Opt_D_dump_deriv dflags) $ do
{ rdr_env <- getGlobalRdrEnv
; let unqual = mkPrintUnqualified dflags rdr_env
; liftIO (putMsgWith dflags unqual doc) } }
......@@ -1262,7 +1269,7 @@ forkM_maybe doc thing_inside