\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 PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
- setWorkerInfo, workerInfo,
+ setWorkerInfo, workerInfo, setSpecInfoHead,
setInlinePragInfo, inlinePragInfo,
setSpecInfo, specInfo, specInfoRules )
import CoreUtils ( coreBindsSize )
import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
-import CoreLint ( endPass )
+import CoreLint ( endPass, endIteration )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FamInstEnv
import StrictAnal ( saBinds )
import CprAnalyse ( cprAnalyse )
#endif
+import Vectorise ( vectorise )
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import IO ( hPutStr, stderr )
doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
-> ModGuts -> IO (SimplCount, ModGuts)
-doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws
-doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram
-doCorePass CoreLiberateCase = _scc_ "LiberateCase" liberateCase
-doCorePass CoreDoFloatInwards = _scc_ "FloatInwards" trBinds floatInwards
-doCorePass (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
-doCorePass CoreDoStaticArgs = _scc_ "StaticArgs" trBinds doStaticArgs
-doCorePass CoreDoStrictness = _scc_ "Stranal" trBinds dmdAnalPgm
-doCorePass CoreDoWorkerWrapper = _scc_ "WorkWrap" trBindsU wwTopBinds
-doCorePass CoreDoSpecialising = _scc_ "Specialise" trBindsU specProgram
-doCorePass CoreDoSpecConstr = _scc_ "SpecConstr" trBindsU specConstrProgram
+doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-} simplifyPgm mode sws
+doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} trBinds cseProgram
+doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} liberateCase
+doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} trBinds floatInwards
+doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
+doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} trBinds doStaticArgs
+doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} trBinds dmdAnalPgm
+doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU wwTopBinds
+doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram
+doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} trBindsU specConstrProgram
doCorePass CoreDoGlomBinds = trBinds glomBinds
+doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} vectorise
doCorePass CoreDoPrintCore = observe printCore
-doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
+doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
doCorePass CoreDoNothing = observe (\ _ _ -> return ())
#ifdef OLD_STRICTNESS
-doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness
+doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
#else
doCorePass CoreDoOldStrictness = panic "CoreDoOldStrictness"
#endif
printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
-ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
- printDump (ruleCheckProgram phase pat binds)
+ruleCheck phase pat hsc_env us rb guts
+ = do let dflags = hsc_dflags hsc_env
+ showPass dflags "RuleCheck"
+ printDump (ruleCheckProgram phase pat rb (mg_binds guts))
+ return (zeroSimplCount dflags, guts)
-- Most passes return no stats and don't change rules
trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
env = setInScopeSet gentleSimplEnv local_ids
(better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
- (mapSmpl (simplRule env) local_rules)
+ (mapM (simplRule env) local_rules)
home_pkg_rules = hptRules hsc_env (dep_mods deps)
-- Find the rules for locally-defined Ids; then we can attach them
\begin{code}
simplRule env rule@(BuiltinRule {})
- = returnSmpl rule
+ = return rule
simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
- = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
- mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
- simplExprGently env rhs `thenSmpl` \ rhs' ->
- returnSmpl (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 = rhs' })
-- It's important that simplExprGently does eta reduction.
-- For example, in a rule like:
-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
-- enforce that; it just simplifies the expression twice
-simplExprGently env expr
- = simplExpr env (occurAnalyseExpr expr) `thenSmpl` \ expr1 ->
+simplExprGently env expr = do
+ expr1 <- simplExpr env (occurAnalyseExpr expr)
simplExpr env (occurAnalyseExpr expr1)
\end{code}
text "",
pprSimplCount counts_out]);
- endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
+ endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_dump_simpl_phases binds';
return (counts_out, guts { mg_binds = binds' })
}
if max_iterations > 2 then
hPutStr stderr ("NOTE: Simplifier still going after " ++
show max_iterations ++
- " iterations; bailing out.\n")
+ " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" )
else
return ();
#endif
| let sz = coreBindsSize binds in sz == sz
= do {
-- Occurrence analysis
- let { tagged_binds = _scc_ "OccAnal" occurAnalysePgm binds } ;
+ let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
eps <- hscEPS hsc_env ;
let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
; simpl_env = mkSimplEnv mode sw_chkr
- ; simpl_binds = _scc_ "SimplTopBinds"
+ ; simpl_binds = {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
--
-- ToDo: alas, this means that indirection-shorting does not happen at all
-- if the simplifier does nothing (not common, I know, but unsavoury)
- let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ;
+ let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
-- Dump the result of this iteration
dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
(pprSimplCount counts') ;
- endPass dflags herald Opt_D_dump_simpl_iterations binds'' ;
+ endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
-- Loop
do_iteration us2 (iteration_no + 1) all_counts binds''
transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
`setWorkerInfo` workerInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
- `setSpecInfo` addSpecInfo (specInfo exp_info)
- (specInfo local_info)
+ `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
+ new_info = setSpecInfoHead (idName exported_id)
+ (specInfo local_info)
+ -- Remember to set the function-name field of the
+ -- rules as we transfer them from one function to another
\end{code}