Commit d4f4391a authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Continue refactoring the core-to-core pipeline

This patch mainly concerns the plumbing for running
the passes and printing intermediate output
parent b8ee6f14
......@@ -36,7 +36,6 @@ import BasicTypes
import StaticFlags
import ListSetOps
import PrelNames
import DynFlags
import Outputable
import FastString
import Util
......@@ -96,29 +95,11 @@ find an occurence of an Id, we fetch it from the in-scope set.
\begin{code}
lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
lintCoreBindings dflags _whoDunnit _binds
| not (dopt Opt_DoCoreLinting dflags)
= return ()
lintCoreBindings dflags whoDunnit binds
| isEmptyBag errs
= do { showPass dflags ("Core Linted result of " ++ whoDunnit)
; unless (isEmptyBag warns || opt_NoDebugOutput) $ printDump $
(banner "warnings" $$ displayMessageBag warns)
; return () }
| otherwise
= do { printDump (vcat [ banner "errors", displayMessageBag errs
, ptext (sLit "*** Offending Program ***")
, pprCoreBindings binds
, ptext (sLit "*** End of Offense ***") ])
; ghcExit dflags 1 }
lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message)
-- Returns (warnings, errors)
lintCoreBindings binds
= initL (lint_binds binds)
where
(warns, errs) = initL (lint_binds binds)
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
-- into use 'unexpectedly'
......@@ -128,13 +109,6 @@ lintCoreBindings dflags whoDunnit binds
lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
banner string = ptext (sLit "*** Core Lint") <+> text string
<+> ptext (sLit ": in result of") <+> text whoDunnit
<+> ptext (sLit "***")
displayMessageBag :: Bag Message -> SDoc
displayMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
\end{code}
%************************************************************************
......@@ -154,7 +128,7 @@ lintUnfolding :: SrcLoc
lintUnfolding locn vars expr
| isEmptyBag errs = Nothing
| otherwise = Just (displayMessageBag errs)
| otherwise = Just (pprMessageBag errs)
where
(_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
addInScopeVars vars $
......
......@@ -15,7 +15,7 @@ import PrelNames ( lazyIdKey, hasKey )
import CoreUtils
import CoreArity
import CoreFVs
import CoreMonad ( endPass )
import CoreMonad ( endPass, CoreToDo(..) )
import CoreSyn
import Type
import Coercion
......@@ -147,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do
floats2 <- corePrepTopBinds implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2))
endPass dflags "CorePrep" Opt_D_dump_prep binds_out []
endPass dflags CorePrep binds_out []
return binds_out
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
......
......@@ -28,7 +28,7 @@ import Module
import RdrName
import NameSet
import Rules
import CoreMonad ( endPass )
import CoreMonad ( endPass, CoreToDo(..) )
import ErrUtils
import Outputable
import SrcLoc
......@@ -114,7 +114,7 @@ deSugar hsc_env
-- things into the in-scope set before simplifying; so we get no unfolding for F#!
-- Lint result if necessary
; endPass dflags "Desugar" Opt_D_dump_ds ds_binds ds_rules
; endPass dflags CoreDesugar ds_binds ds_rules
-- Dump output
; doIfSet (dopt Opt_D_dump_ds dflags)
......
......@@ -5,7 +5,7 @@
\begin{code}
module ErrUtils (
Message, mkLocMessage, printError,
Message, mkLocMessage, printError, pprMessageBag,
Severity(..),
ErrMsg, WarnMsg,
......@@ -18,7 +18,7 @@ module ErrUtils (
ghcExit,
doIfSet, doIfSet_dyn,
dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or,
mkDumpDoc, dumpSDoc,
-- * Messages during compilation
......@@ -49,6 +49,9 @@ import System.IO
type Message = SDoc
pprMessageBag :: Bag Message -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
data Severity
= SevInfo
| SevWarning
......@@ -202,19 +205,6 @@ 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
= dumpIf_core (dopt flag dflags) dflags flag hdr doc
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags || verbosity dflags >= 4
......
......@@ -18,6 +18,7 @@ import CoreFVs
import CoreTidy
import CoreMonad
import CoreUtils
import Rules
import CoreArity ( exprArity, exprBotStrictness_maybe )
import Class ( classSelIds )
import VarEnv
......@@ -38,11 +39,11 @@ import TyCon
import Module
import HscTypes
import Maybes
import ErrUtils
import UniqSupply
import Outputable
import FastBool hiding ( fastOr )
import Util
import FastString
import Data.List ( sortBy )
import Data.IORef ( IORef, readIORef, writeIORef )
......@@ -133,7 +134,7 @@ mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing
-> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
mkBootModDetails hsc_env exports type_env insts fam_insts
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy [hoot] type env"
; showPass dflags CoreTidy
; let { insts' = tidyInstances globaliseAndTidyId insts
; dfun_ids = map instanceDFunId insts'
......@@ -301,7 +302,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
; expose_all = dopt Opt_ExposeAllUnfoldings dflags
; th = dopt Opt_TemplateHaskell dflags
}
; showPass dflags "Tidy Core"
; showPass dflags CoreTidy
; let { implicit_binds = getImplicitBinds type_env }
......@@ -342,7 +343,15 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules
; endPass dflags CoreTidy all_tidy_binds tidy_rules
-- If the endPass didn't print the rules, but ddump-rules is on, print now
; dumpIfSet (dopt Opt_D_dump_rules dflags
&& (not (dopt Opt_D_dump_simpl dflags)))
CoreTidy
(ptext (sLit "rules"))
(pprRulesForUser tidy_rules)
; let dir_imp_mods = moduleEnvKeys dir_imps
; return (CgGuts { cg_module = mod,
......
......@@ -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,6 +75,7 @@ import TcRnMonad ( TcM, initTc )
import Outputable
import FastString
import qualified ErrUtils as Err
import Bag
import Maybes
import UniqSupply
import LazyUniqFM ( UniqFM, mapUFM, filterUFM )
......@@ -106,35 +107,80 @@ 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 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 +198,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 +210,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 +218,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 +282,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 +291,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 +352,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,6 +381,7 @@ getCoreToDo dflags
-- initial simplify: mk specialiser happy: minimum effort please
simpl_gently = CoreDoSimplify
(SimplGently { sm_rules = True, sm_inline = False })
max_iter
[
-- Simplify "gently"
-- Don't inline anything till full laziness has bitten
......@@ -295,9 +393,8 @@ getCoreToDo dflags
-- 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 =
......
......@@ -130,57 +130,55 @@ simplifyExpr dflags expr
}
doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
doCorePasses passes guts = foldM (flip doCorePass) guts passes
doCorePasses passes guts
= foldM do_pass guts passes
where
do_pass guts CoreDoNothing = return guts
do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
do_pass guts pass
= do { dflags <- getDynFlags
; liftIO $ showPass dflags pass
; guts' <- doCorePass pass guts
; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
; return guts' }
doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
simplifyPgm mode sws
doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}
simplifyPgm pass
doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
describePass "Common sub-expression" Opt_D_dump_cse $
doPass cseProgram
doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
describePass "Liberate case" Opt_D_verbose_core2core $
doPassD liberateCase
doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
describePass "Float inwards" Opt_D_verbose_core2core $
doPass floatInwards
doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
describePassD (text "Float out" <+> parens (ppr f))
Opt_D_verbose_core2core $
doPassDUM (floatOutwards f)
doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
describePass "Static argument" Opt_D_verbose_core2core $
doPassU doStaticArgs
doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
describePass "Demand analysis" Opt_D_dump_stranal $
doPassDM dmdAnalPgm
doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
doPassU wwTopBinds
doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
describePassR "Specialise" Opt_D_dump_spec $
doPassU specProgram
doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
describePassR "SpecConstr" Opt_D_dump_spec $
specConstrProgram
doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
describePass "Vectorisation" Opt_D_dump_vect $
vectorise be
doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
doCorePass CoreDoGlomBinds = doPassDM glomBinds
doCorePass CoreDoPrintCore = observe printCore
doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
doCorePass CoreDoNothing = return
doCorePass (CoreDoPasses passes) = doCorePasses passes
\end{code}
......@@ -192,30 +190,6 @@ doCorePass (CoreDoPasses passes) = doCorePasses passes
%************************************************************************
\begin{code}
dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
dontDescribePass = ($)
describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
describePass name dflag pass guts = do
dflags <- getDynFlags
liftIO $ Err.showPass dflags name
guts' <- pass guts
liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
return guts'
describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
describePassD doc = describePass (showSDoc doc)
describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
describePassR name dflag pass guts = do
guts' <- describePass name dflag pass guts
dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
(pprRulesForUser (rulesOfBinds (mg_binds guts')))
return guts'
printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
......@@ -468,26 +442,23 @@ glomBinds dflags binds
%************************************************************************
\begin{code}
simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
simplifyPgm mode switches
= describePassD doc Opt_D_dump_simpl_phases $ \guts ->
do { hsc_env <- getHscEnv
simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm pass guts
= do { hsc_env <- getHscEnv
; us <- getUniqueSupplyM
; rb <- getRuleBase
; liftIOWithCount $
simplifyPgmIO mode switches hsc_env us rb guts }
where
doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
simplifyPgmIO pass hsc_env us rb guts }
simplifyPgmIO :: SimplifierMode
-> [SimplifierSwitch]
simplifyPgmIO :: CoreToDo
-> HscEnv
-> UniqSupply
-> RuleBase
-> ModGuts
-> IO (SimplCount, ModGuts) -- New bindings
simplifyPgmIO mode switches hsc_env us hpt_rule_base
simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
hsc_env us hpt_rule_base
guts@(ModGuts { mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
= do {
......@@ -505,10 +476,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
where
dflags = hsc_dflags hsc_env
dump_phase = dumpSimplPhase dflags mode
sw_chkr = isAmongSimpl switches
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
sw_chkr = isAmongSimpl switches
do_iteration :: UniqSupply
-> Int -- Counts iterations
-> SimplCount -- Logs optimisations performed
......@@ -587,7 +555,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
-- Dump the result of this iteration
end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
-- Loop
do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
......@@ -596,18 +564,15 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
(us1, us2) = splitUniqSupply us
-------------------
end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
end_iteration :: DynFlags -> CoreToDo -> Int
-> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
-- Same as endIteration but with simplifier counts
end_iteration dflags mode iteration_no max_iterations counts binds rules
= do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
(pprSimplCount counts) ;
end_iteration dflags pass iteration_no counts binds rules
= do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
pass (ptext (sLit "Simplifier counts"))
(pprSimplCount counts)
; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
where
pass_name = "Simplifier mode " ++ showPpr mode ++
", iteration " ++ show iteration_no ++
" out of " ++ show max_iterations
; endIteration dflags pass iteration_no binds rules }
\end{code}
......
......@@ -201,8 +201,6 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
-- (avoid some unboxing, bounds checking, and other horrible things:)
\ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
where
mk_assoc_elem k@(MaxSimplifierIterations lvl)
= (iBox (tagOf_SimplSwitch k), SwInt lvl)
mk_assoc_elem k
= (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
......@@ -252,8 +250,7 @@ instance Ord SimplifierSwitch where
tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
tagOf_SimplSwitch NoCaseOfCase = _ILIT(1)
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
......
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