\section[SimplCore]{Driver for simplifying @Core@ programs}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
-import DynFlags ( CoreToDo(..), SimplifierSwitch(..),
- SimplifierMode(..), DynFlags, DynFlag(..), dopt,
- getCoreToDo, shouldDumpSimplPhase )
+import DynFlags ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import CoreSubst
import HscTypes
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
- extendRuleBaseList, pprRuleBase, pprRulesForUser,
- ruleCheckProgram, rulesOfBinds,
- addSpecInfo, addIdSpecialisations )
-import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
+ extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
+import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
-import SimplUtils ( simplEnvForGHCi, simplEnvForRules )
+import SimplUtils ( simplEnvForGHCi, activeRule )
import SimplEnv
import SimplMonad
import CoreMonad
import qualified ErrUtils as Err
-import CoreLint
-import CoreMonad ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FamInstEnv
import Id
-import DataCon
-import TyCon ( tyConDataCons )
-import Class ( classSelIds )
-import BasicTypes ( CompilerPhase, isActive, isDefaultInlinePragma )
+import BasicTypes ( CompilerPhase, isDefaultInlinePragma )
import VarSet
import VarEnv
-import NameEnv ( lookupNameEnv )
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import Outputable
import Control.Monad
-import Data.List
-import System.IO
-import Maybes
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-core2core :: HscEnv
- -> ModGuts
- -> IO ModGuts
-
-core2core hsc_env guts = do
- let dflags = hsc_dflags hsc_env
-
- us <- mkSplitUniqSupply 's'
- let (cp_us, ru_us) = splitUniqSupply us
+core2core :: HscEnv -> ModGuts -> IO ModGuts
+core2core hsc_env guts
+ = do { us <- mkSplitUniqSupply 's'
+ ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $
+ doCorePasses (getCoreToDo dflags) guts
- -- COMPUTE THE RULE BASE TO USE
- (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
+ ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
- -- Get the module out of the current HscEnv so we can retrieve it from the monad.
+ ; return guts2 }
+ where
+ dflags = hsc_dflags hsc_env
+ home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
+ hpt_rule_base = mkRuleBase home_pkg_rules
+ mod = mg_module guts
+ -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
-- This is very convienent for the users of the monad (e.g. plugins do not have to
-- consume the ModGuts to find the module) but somewhat ugly because mg_module may
-- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
-- would mean our cached value would go out of date.
- let mod = mg_module guts
- (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do
- -- FIND BUILT-IN PASSES
- let builtin_core_todos = getCoreToDo dflags
-
- -- DO THE BUSINESS
- doCorePasses builtin_core_todos guts1
-
- Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
- "Grand total simplifier statistics"
- (pprSimplCount stats)
-
- return guts2
type CorePass = CoreToDo
-simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
- -> CoreExpr
- -> IO CoreExpr
--- simplifyExpr is called by the driver to simplify an
--- expression typed in at the interactive prompt
---
--- Also used by Template Haskell
-simplifyExpr dflags expr
- = do {
- ; Err.showPass dflags "Simplify"
-
- ; us <- mkSplitUniqSupply 's'
-
- ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
- simplExprGently simplEnvForGHCi expr
-
- ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
- (pprCoreExpr expr')
-
- ; return 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
+ 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 CoreDoVectorisation = {-# SCC "Vectorise" #-}
+ vectorise
+doCorePass CoreDoGlomBinds = doPassDM glomBinds
+doCorePass CoreDoPrintCore = observe printCore
+doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
doCorePass CoreDoNothing = return
doCorePass (CoreDoPasses passes) = doCorePasses passes
+doCorePass pass = pprPanic "doCorePass" (ppr pass)
\end{code}
%************************************************************************
%************************************************************************
\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 :: a -> [CoreBind] -> IO ()
printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
return guts
-doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
-doPassDMS do_pass = doPassM $ \binds -> do
- dflags <- getDynFlags
- liftIOWithCount $ do_pass dflags binds
-
doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
doPassDUM do_pass = doPassM $ \binds -> do
dflags <- getDynFlags
binds' <- bind_f (mg_binds guts)
return (guts { mg_binds = binds' })
-doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
-doPassMG bind_f guts = do
- binds' <- bind_f guts
- return (guts { mg_binds = binds' })
-
doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
observe do_pass = doPassM $ \binds -> do
dflags <- getDynFlags
- liftIO $ do_pass dflags binds
+ _ <- liftIO $ do_pass dflags binds
return binds
\end{code}
%************************************************************************
%* *
- Dealing with rules
+ Gentle simplification
%* *
%************************************************************************
--- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
--- It attaches those rules that are for local Ids to their binders, and
--- returns the remainder attached to Ids in an IdSet.
-
\begin{code}
-prepareRules :: HscEnv
- -> ModGuts
- -> UniqSupply
- -> IO (RuleBase, -- Rule base for imported things, incl
- -- (a) rules defined in this module (orphans)
- -- (b) rules from other modules in home package
- -- but not things from other packages
-
- ModGuts) -- Modified fields are
- -- (a) Bindings have rules attached,
- -- and INLINE rules simplified
- -- (b) Rules are now just orphan rules
-
-prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
- guts@(ModGuts { mg_binds = binds, mg_deps = deps
- , mg_rules = local_rules, mg_rdr_env = rdr_env })
- us
- = do { us <- mkSplitUniqSupply 'w'
-
- ; let -- Simplify the local rules; boringly, we need to make an in-scope set
- -- from the local binders, to avoid warnings from Simplify.simplVar
- local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
- env = setInScopeSet simplEnvForRules local_ids
- (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
- mapM (simplRule env) local_rules
-
- ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
-
- home_pkg_rules = hptRules hsc_env (dep_mods deps)
- hpt_rule_base = mkRuleBase home_pkg_rules
- binds_w_rules = updateBinders rules_for_locals binds
-
-
- ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
- (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
- vcat [text "Local rules", pprRules simpl_rules,
- blankLine,
- text "Imported rules", pprRuleBase hpt_rule_base])
-
- ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
- mg_rules = rules_for_imps })
- }
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+ -> CoreExpr
+ -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
+--
+-- Also used by Template Haskell
+simplifyExpr dflags expr
+ = do {
+ ; Err.showPass dflags "Simplify"
--- Note [Attach rules to local ids]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Find the rules for locally-defined Ids; then we can attach them
--- to the binders in the top-level bindings
---
--- Reason
--- - It makes the rules easier to look up
--- - It means that transformation rules and specialisations for
--- locally defined Ids are handled uniformly
--- - It keeps alive things that are referred to only from a rule
--- (the occurrence analyser knows about rules attached to Ids)
--- - It makes sure that, when we apply a rule, the free vars
--- of the RHS are more likely to be in scope
--- - The imported rules are carried in the in-scope set
--- which is extended on each iteration by the new wave of
--- local binders; any rules which aren't on the binding will
--- thereby get dropped
-
-updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
-updateBinders rules_for_locals binds
- = map update_bind binds
- where
- local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
-
- update_bind (NonRec b r) = NonRec (add_rules b) r
- update_bind (Rec prs) = Rec (mapFst add_rules prs)
-
- -- See Note [Attach rules to local ids]
- -- NB: the binder might have some existing rules,
- -- arising from specialisation pragmas
- add_rules bndr
- | Just rules <- lookupNameEnv local_rules (idName bndr)
- = bndr `addIdSpecialisations` rules
- | otherwise
- = bndr
-\end{code}
+ ; us <- mkSplitUniqSupply 's'
-Note [Simplifying the left-hand side of a RULE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must do some gentle simplification on the lhs (template) of each
-rule. The case that forced me to add this was the fold/build rule,
-which without simplification looked like:
- fold k z (build (/\a. g a)) ==> ...
-This doesn't match unless you do eta reduction on the build argument.
-Similarly for a LHS like
- augment g (build h)
-we do not want to get
- augment (\a. g a) (build h)
-otherwise we don't match when given an argument like
- augment (\a. h a a) (build h)
-
-The simplifier does indeed do eta reduction (it's in
-Simplify.completeLam) but only if -O is on.
+ ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+ simplExprGently (simplEnvForGHCi dflags) expr
-\begin{code}
-simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
-simplRule env rule@(BuiltinRule {})
- = return rule
-simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
- = do (env, bndrs') <- simplBinders env bndrs
- args' <- mapM (simplExprGently env) args
- rhs' <- simplExprGently env rhs
- return (rule { ru_bndrs = bndrs', ru_args = args'
- , ru_rhs = occurAnalyseExpr rhs' })
-\end{code}
+ ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+ (pprCoreExpr expr')
+
+ ; return expr'
+ }
-\begin{code}
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-- Simplifies an expression
-- does occurrence analysis, then simplification
%************************************************************************
\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 max_iterations mode)
+ hsc_env us hpt_rule_base
guts@(ModGuts { mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
- = do {
- (termination_msg, it_count, counts_out, guts')
- <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
+ = do { (termination_msg, it_count, counts_out, guts')
+ <- do_iteration us 1 [] binds rules
- Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
+ ; Err.dumpIfSet (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,
- pprSimplCount counts_out]);
+ pprSimplCount counts_out])
- return (counts_out, guts')
+ ; return (counts_out, guts')
}
where
- dflags = hsc_dflags hsc_env
- dump_phase = shouldDumpSimplPhase dflags mode
-
- sw_chkr = isAmongSimpl switches
- max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
-
+ dflags = hsc_dflags hsc_env
+ dump_phase = dumpSimplPhase dflags mode
+ simpl_env = mkSimplEnv mode
+ active_rule = activeRule dflags simpl_env
+
do_iteration :: UniqSupply
- -> Int -- Counts iterations
- -> SimplCount -- Logs optimisations performed
- -> [CoreBind] -- Bindings in
- -> [CoreRule] -- and orphan rules
+ -> Int -- Counts iterations
+ -> [SimplCount] -- Counts from earlier iterations, reversed
+ -> [CoreBind] -- Bindings in
+ -> [CoreRule] -- and orphan rules
-> IO (String, Int, SimplCount, ModGuts)
- do_iteration us iteration_no counts binds rules
+ do_iteration us iteration_no counts_so_far binds rules
-- iteration_no is the number of the iteration we are
-- about to begin, with '1' for the first
| iteration_no > max_iterations -- Stop if we've run out of iterations
- = WARN(debugIsOn && (max_iterations > 2),
- text ("Simplifier still going after " ++
- show max_iterations ++
- " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
+ = WARN( debugIsOn && (max_iterations > 2)
+ , ptext (sLit "Simplifier baling out after") <+> int max_iterations
+ <+> ptext (sLit "iterations")
+ <+> (brackets $ hsep $ punctuate comma $
+ map (int . simplCountN) (reverse counts_so_far))
+ <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
+
-- Subtract 1 from iteration_no to get the
-- number of iterations we actually completed
- return ("Simplifier bailed out", iteration_no - 1, counts,
- guts { mg_binds = binds, mg_rules = rules })
+ return ( "Simplifier baled out", iteration_no - 1
+ , totalise counts_so_far
+ , guts { mg_binds = binds, mg_rules = rules } )
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
| let sz = coreBindsSize binds in sz == sz
= do {
-- Occurrence analysis
- let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
+ let { tagged_binds = {-# SCC "OccAnal" #-}
+ occurAnalysePgm active_rule rules [] binds } ;
Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
-- Get any new rules, and extend the rule base
+ -- See Note [Overall plumbing for rules] in Rules.lhs
-- We need to do this regularly, because simplification can
-- poke on IdInfo thunks, which in turn brings in new rules
-- behind the scenes. Otherwise there's a danger we'll simply
eps <- hscEPS hsc_env ;
let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
; rule_base2 = extendRuleBaseList rule_base1 rules
- ; simpl_env = mkSimplEnv sw_chkr mode
; simpl_binds = {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
-- With a let, we ended up with
-- let
-- t = initSmpl ...
- -- counts' = snd t
+ -- counts1 = snd t
-- in
- -- case t of {(_,counts') -> if counts'=0 then ... }
- -- So the conditional didn't force counts', because the
+ -- case t of {(_,counts1) -> if counts1=0 then ... }
+ -- So the conditional didn't force counts1, because the
-- selection got duplicated. Sigh!
case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
(env1, counts1) -> do {
- let { all_counts = counts `plusSimplCount` counts1
- ; binds1 = getFloats env1
- ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
+ let { binds1 = getFloats env1
+ ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
} ;
-- Stop if nothing happened; don't dump output
if isZeroSimplCount counts1 then
- return ("Simplifier reached fixed point", iteration_no, all_counts,
- guts { mg_binds = binds1, mg_rules = rules1 })
+ return ( "Simplifier reached fixed point", iteration_no
+ , totalise (counts1 : counts_so_far) -- Include "free" ticks
+ , guts { mg_binds = binds1, mg_rules = rules1 } )
else do {
-- Short out indirections
-- We do this *after* at least one run of the simplifier
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
- } } } }
+ do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
+ } } } }
+ | otherwise = panic "do_iteration"
where
- (us1, us2) = splitUniqSupply us
+ (us1, us2) = splitUniqSupply us
+
+ -- Remember the counts_so_far are reversed
+ totalise :: [SimplCount] -> SimplCount
+ totalise = foldr (\c acc -> acc `plusSimplCount` c)
+ (zeroSimplCount dflags)
+
+simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
-------------------
-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}
add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
add_pair (exported_id, Var local_id) env
| shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
- add_pair (exported_id, rhs) env
- = env
+ add_pair _ env = env
-----------------
+shortMeOut :: IndEnv -> Id -> Id -> Bool
shortMeOut ind_env exported_id local_id
-- The if-then-else stuff is just so I can get a pprTrace to see
-- how often I don't get shorting out becuase of IdInfo stuff
projects / ghc-hetmet.git / blobdiff