X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FCoreMonad.lhs;h=7f43ce528f3657afe253eb7472b9985b9728cc59;hb=5126e7cd4594d05cd78bcaccf044a30c0051fd9b;hp=ef8c428c8e4c461a4e1030dff31d469ec8f9c6b7;hpb=63e3a41126771e71c44705480c2bde7043a41df3;p=ghc-hetmet.git diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index ef8c428..7f43ce5 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -15,7 +15,7 @@ module CoreMonad ( getCoreToDo, dumpSimplPhase, -- * Counting - SimplCount, doSimplTick, doFreeSimplTick, + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..), -- * The monad @@ -36,13 +36,13 @@ module CoreMonad ( getAnnotations, getFirstAnnotations, -- ** Debug output - endPass, endPassIf, endIteration, + showPass, endPass, endIteration, dumpIfSet, -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, - dumpIfSet_dyn, + dumpIfSet_dyn, #ifdef GHCI -- * Getting 'Name's @@ -75,9 +75,10 @@ import TcRnMonad ( TcM, initTc ) import Outputable import FastString import qualified ErrUtils as Err +import Bag import Maybes import UniqSupply -import LazyUniqFM ( UniqFM, mapUFM, filterUFM ) +import UniqFM ( UniqFM, mapUFM, filterUFM ) import FiniteMap import Util ( split ) @@ -106,35 +107,85 @@ be, and it makes a conveneint place. place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endPass = dumpAndLint Err.dumpIfSet_core +showPass :: DynFlags -> CoreToDo -> IO () +showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass)) -endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endPassIf cond = dumpAndLint (Err.dumpIf_core cond) +endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO () +endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass) -- Same as endPass but doesn't dump Core even with -dverbose-core2core -endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endIteration = dumpAndLint Err.dumpIfSet_dyn +endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO () +endIteration dflags pass n + = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n) + (Just Opt_D_dump_simpl_iterations) -dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) - -> DynFlags -> String -> DynFlag +dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet dump_me pass extra_info doc + = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc + +dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag -> [CoreBind] -> [CoreRule] -> IO () -dumpAndLint dump dflags pass_name dump_flag binds rules +-- The "show_all" parameter says to print dump if -dverbose-core2core is on +dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules = do { -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated ; Err.debugTraceMsg dflags 2 $ (text " Result size =" <+> int (coreBindsSize binds)) -- Report verbosely, if required - ; dump dflags dump_flag pass_name - (pprCoreBindings binds $$ ppUnless (null rules) pp_rules) + ; let pass_name = showSDoc (ppr pass <+> extra_info) + dump_doc = pprCoreBindings binds + $$ ppUnless (null rules) pp_rules + + ; case mb_dump_flag of + Nothing -> return () + Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc + where + dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core] + | otherwise = [dump_flag] -- Type check - ; lintCoreBindings dflags pass_name binds } + ; when (dopt Opt_DoCoreLinting dflags) $ + do { let (warns, errs) = lintCoreBindings binds + ; Err.showPass dflags ("Core Linted result of " ++ pass_name) + ; displayLintResults dflags pass warns errs binds } } where pp_rules = vcat [ blankLine , ptext (sLit "------ Local rules for imported ids --------") , pprRules rules ] + +displayLintResults :: DynFlags -> CoreToDo + -> Bag Err.Message -> Bag Err.Message -> [CoreBind] + -> IO () +displayLintResults dflags pass warns errs binds + | not (isEmptyBag errs) + = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs + , ptext (sLit "*** Offending Program ***") + , pprCoreBindings binds + , ptext (sLit "*** End of Offense ***") ]) + ; Err.ghcExit dflags 1 } + + | not (isEmptyBag warns) + , not (case pass of { CoreDesugar -> True; _ -> False }) + -- Suppress warnings after desugaring pass because some + -- are legitimate. Notably, the desugarer generates instance + -- methods with INLINE pragmas that form a mutually recursive + -- group. Only afer a round of simplification are they unravelled. + , not opt_NoDebugOutput + , showLintWarnings pass + = printDump (banner "warnings" $$ Err.pprMessageBag warns) + + | otherwise = return () + where + banner string = ptext (sLit "*** Core Lint") <+> text string + <+> ptext (sLit ": in result of") <+> ppr pass + <+> ptext (sLit "***") + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False +showLintWarnings _ = True \end{code} @@ -152,9 +203,9 @@ data CoreToDo -- These are diff core-to-core passes, = CoreDoSimplify -- The core-to-core simplifier. SimplifierMode - [SimplifierSwitch] - -- Each run of the simplifier can take a different - -- set of simplifier-specific flags. + Int -- Max iterations + [SimplifierSwitch] -- Each run of the simplifier can take a different + -- set of simplifier-specific flags. | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches | CoreLiberateCase @@ -164,7 +215,6 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoWorkerWrapper | CoreDoSpecialising | CoreDoSpecConstr - | CoreDoOldStrictness | CoreDoGlomBinds | CoreCSE | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules @@ -173,7 +223,59 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things + | CoreDesugar -- Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + +coreDumpFlag :: CoreToDo -> Maybe DynFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases +coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec +coreDumpFlag CoreCSE = Just Opt_D_dump_cse +coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep + +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag CoreDoGlomBinds = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +instance Outputable CoreToDo where + ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier") + <+> ppr md + <+> ptext (sLit "max-iterations=") <> int n + ppr CoreDoFloatInwards = ptext (sLit "Float inwards") + ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f) + ppr CoreLiberateCase = ptext (sLit "Liberate case") + ppr CoreDoStaticArgs = ptext (sLit "Static argument") + ppr CoreDoStrictness = ptext (sLit "Demand analysis") + ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds") + ppr CoreDoSpecialising = ptext (sLit "Specialise") + ppr CoreDoSpecConstr = ptext (sLit "SpecConstr") + ppr CoreCSE = ptext (sLit "Common sub-expression") + ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation") + ppr CoreDesugar = ptext (sLit "Desugar") + ppr CoreTidy = ptext (sLit "Tidy Core") + ppr CorePrep = ptext (sLit "CorePrep") + ppr CoreDoPrintCore = ptext (sLit "Print core") + ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") + ppr CoreDoGlomBinds = ptext (sLit "Glom binds") + ppr CoreDoNothing = ptext (sLit "CoreDoNothing") + ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") +\end{code} +\begin{code} data SimplifierMode -- See comments in SimplMonad = SimplGently { sm_rules :: Bool -- Whether RULES are enabled @@ -185,7 +287,7 @@ data SimplifierMode -- See comments in SimplMonad instance Outputable SimplifierMode where ppr (SimplPhase { sm_num = n, sm_names = ss }) - = int n <+> brackets (text (concat $ intersperse "," ss)) + = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss)) ppr (SimplGently { sm_rules = r, sm_inline = i }) = ptext (sLit "gentle") <> brackets (pp_flag r (sLit "rules") <> comma <> @@ -194,15 +296,16 @@ instance Outputable SimplifierMode where pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s data SimplifierSwitch - = MaxSimplifierIterations Int - | NoCaseOfCase + = NoCaseOfCase +\end{code} + +\begin{code} data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level floatOutConstants :: Bool -- ^ True <=> float constants to top level, -- even if they do not escape a lambda } - instance Outputable FloatOutSwitches where ppr = pprFloatOutSwitches @@ -254,11 +357,10 @@ getCoreToDo dflags simpl_phase phase names iter = CoreDoPasses - [ maybe_strictness_before phase, - CoreDoSimplify (SimplPhase phase names) [ - MaxSimplifierIterations iter - ], - maybe_rule_check phase + [ maybe_strictness_before phase + , CoreDoSimplify (SimplPhase phase names) + iter [] + , maybe_rule_check phase ] vectorisation @@ -284,20 +386,14 @@ getCoreToDo dflags -- initial simplify: mk specialiser happy: minimum effort please simpl_gently = CoreDoSimplify (SimplGently { sm_rules = True, sm_inline = False }) + -- See Note [Gentle mode] and + -- Note [RULEs enabled in SimplGently] in SimplUtils + max_iter [ - -- Simplify "gently" - -- Don't inline anything till full laziness has bitten - -- In particular, inlining wrappers inhibits floating - -- e.g. ...(case f x of ...)... - -- ==> ...(case (case x of I# x# -> fw x#) of ...)... - -- ==> ...(case x of I# x# -> case fw x# of ...)... - -- and now the redex (f x) isn't floatable any more - -- Similarly, don't apply any rules until after full - -- laziness. Notably, list fusion can prevent floating. - - NoCaseOfCase, -- Don't do case-of-case transformations. + + + NoCaseOfCase -- Don't do case-of-case transformations. -- This makes full laziness work better - MaxSimplifierIterations max_iter ] core_todo = @@ -449,9 +545,7 @@ plusSimplCount :: SimplCount -> SimplCount -> SimplCount \begin{code} data SimplCount - = VerySimplZero -- These two are used when - | VerySimplNonZero -- we are only interested in - -- termination info + = VerySimplCount !Int -- Used when don't want detailed stats | SimplCount { ticks :: !Int, -- Total ticks @@ -467,6 +561,10 @@ data SimplCount type TickCounts = FiniteMap Tick Int +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + zeroSimplCount dflags -- This is where we decide whether to do -- the VerySimpl version or the full-stats version @@ -474,11 +572,10 @@ zeroSimplCount dflags = SimplCount {ticks = 0, details = emptyFM, n_log = 0, log1 = [], log2 = []} | otherwise - = VerySimplZero + = VerySimplCount 0 -isZeroSimplCount VerySimplZero = True -isZeroSimplCount (SimplCount { ticks = 0 }) = True -isZeroSimplCount _ = False +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 doFreeSimplTick tick sc@SimplCount { details = dts } = sc { details = dts `addTick` tick } @@ -490,7 +587,7 @@ doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = where sc1 = sc { ticks = tks+1, details = dts `addTick` tick } -doSimplTick _ _ = VerySimplNonZero -- The very simple case +doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1) -- Don't use plusFM_C because that's lazy, and we want to @@ -512,11 +609,11 @@ plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) | null (log2 sc2) = sc2 { log2 = log1 sc1 } | otherwise = sc2 -plusSimplCount VerySimplZero VerySimplZero = VerySimplZero -plusSimplCount _ _ = VerySimplNonZero +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount _ _ = panic "plusSimplCount" + -- We use one or the other consistently -pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!") -pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!") +pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) = vcat [ptext (sLit "Total ticks: ") <+> int tks, blankLine,