\section[SimplCore]{Driver for simplifying @Core@ programs}
\begin{code}
-module SimplCore ( core2core ) where
+module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
- SwitchResult(..), switchIsOn, intSwitchSet,
- opt_D_dump_occur_anal, opt_D_dump_rules,
- opt_D_dump_simpl_iterations,
- opt_D_dump_simpl_stats,
- opt_D_dump_simpl, opt_D_dump_rules,
- opt_D_verbose_core2core,
- opt_D_dump_occur_anal,
- opt_UsageSPOn,
- )
-import CoreLint ( beginPass, endPass )
-import CoreTidy ( tidyCorePgm )
+import DynFlags ( CoreToDo(..), SimplifierSwitch(..),
+ SimplifierMode(..), DynFlags, DynFlag(..), dopt,
+ getCoreToDo )
import CoreSyn
+import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
+ Dependencies( dep_mods ),
+ hscEPS, hptRules )
import CSE ( cseProgram )
-import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
-import CoreUnfold
-import PprCore ( pprCoreBindings )
-import OccurAnal ( occurAnalyseBinds )
-import CoreUtils ( exprIsTrivial, coreExprType )
+import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
+ extendRuleBaseList, pprRuleBase, ruleCheckProgram,
+ addSpecInfo, addIdSpecialisations )
+import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
+import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
+import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
+ setWorkerInfo, workerInfo,
+ setSpecInfo, specInfo, specInfoRules )
+import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
-import SimplUtils ( etaCoreExpr, findDefault, simplBinders )
+import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
import SimplMonad
-import Const ( Con(..), Literal(..), literalType, mkMachInt )
-import ErrUtils ( dumpIfSet )
+import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
+import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,
- idType, setIdType, idName, idInfo, setIdNoDiscard
- )
-import VarEnv
+import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
+ idSpecialisation, idName )
import VarSet
-import Module ( Module )
-import Name ( mkLocalName, tidyOccName, tidyTopName,
- NamedThing(..), OccName
- )
-import TyCon ( TyCon, isDataTyCon )
-import PrimOp ( PrimOp(..) )
-import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
-import Type ( Type, splitAlgTyConApp_maybe,
- isUnLiftedType,
- tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
- Type
- )
-import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
+import VarEnv
+import NameEnv ( lookupNameEnv )
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
-import UsageSPInf ( doUsageSPInf )
-import StrictAnal ( saBinds )
+import SpecConstr ( specConstrProgram)
+import DmdAnal ( dmdAnalPgm )
import WorkWrap ( wwTopBinds )
+#ifdef OLD_STRICTNESS
+import StrictAnal ( saBinds )
import CprAnalyse ( cprAnalyse )
+#endif
-import Unique ( Unique, Uniquable(..),
- ratioTyConKey
- )
-import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
-import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
-import Util ( mapAccumL )
-import SrcLoc ( noSrcLoc )
-import Bag
-import Maybes
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import IO ( hPutStr, stderr )
import Outputable
-
-import Ratio ( numerator, denominator )
+import List ( partition )
+import Maybes ( orElse )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
- -> [CoreBind] -- Binds in
- -> [ProtoCoreRule] -- Rules
- -> IO ([CoreBind], [ProtoCoreRule])
+core2core :: HscEnv
+ -> ModGuts
+ -> IO ModGuts
-core2core core_todos binds rules
+core2core hsc_env guts
= do
- us <- mkSplitUniqSupply 's'
- let (cp_us, us1) = splitUniqSupply us
- (ru_us, ps_us) = splitUniqSupply us1
+ let dflags = hsc_dflags hsc_env
+ core_todos = getCoreToDo dflags
- better_rules <- simplRules ru_us rules binds
+ us <- mkSplitUniqSupply 's'
+ let (cp_us, ru_us) = splitUniqSupply us
- let (binds1, rule_base) = prepareRuleBase binds better_rules
+ -- COMPUTE THE RULE BASE TO USE
+ (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
- -- Do the main business
- (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
- rule_base core_todos
+ -- DO THE BUSINESS
+ (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
+ (zeroSimplCount dflags)
+ guts' core_todos
- dumpIfSet opt_D_dump_simpl_stats
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
(pprSimplCount stats)
- -- Do the post-simplification business
- post_simpl_binds <- doPostSimplification ps_us processed_binds
+ return guts''
- -- Return results
- return (post_simpl_binds, filter orphanRule better_rules)
-
-doCorePasses stats us binds irs []
- = return (stats, binds)
+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
+simplifyExpr dflags expr
+ = do {
+ ; showPass dflags "Simplify"
-doCorePasses stats us binds irs (to_do : to_dos)
- = do
- let (us1, us2) = splitUniqSupply us
- (stats1, binds1) <- doCorePass us1 binds irs to_do
- doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
-
-doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
-doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
-doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
-doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
-doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
-doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
-doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
-doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
-doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
-doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
-doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
-doCorePass us binds rb CoreDoUSPInf
- = _scc_ "CoreUsageSPInf"
- if opt_UsageSPOn then
- noStats (doUsageSPInf us binds)
- else
- trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
- noStats (return binds)
+ ; us <- mkSplitUniqSupply 's'
+
+ ; let (expr', _counts) = initSmpl dflags us $
+ simplExprGently gentleSimplEnv expr
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+ (pprCoreExpr expr')
+
+ ; return expr'
+ }
+
+gentleSimplEnv :: SimplEnv
+gentleSimplEnv = mkSimplEnv SimplGently
+ (isAmongSimpl [])
+ emptyRuleBase
+
+doCorePasses :: HscEnv
+ -> RuleBase -- the imported main rule base
+ -> UniqSupply -- uniques
+ -> SimplCount -- simplifier stats
+ -> ModGuts -- local binds in (with rules attached)
+ -> [CoreToDo] -- which passes to do
+ -> IO (SimplCount, ModGuts)
-printCore binds = do dumpIfSet True "Print Core"
- (pprCoreBindings binds)
- return binds
+doCorePasses hsc_env rb us stats guts []
+ = return (stats, guts)
-noStats thing = do { result <- thing; return (zeroSimplCount, result) }
+doCorePasses hsc_env rb us stats guts (to_do : to_dos)
+ = do
+ let (us1, us2) = splitUniqSupply us
+ (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
+ doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
+
+doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws
+doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram
+doCorePass CoreLiberateCase = _scc_ "LiberateCase" trBinds 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 CoreDoPrintCore = observe printCore
+doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
+doCorePass CoreDoNothing = observe (\ _ _ -> return ())
+#ifdef OLD_STRICTNESS
+doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness
+#endif
+
+#ifdef OLD_STRICTNESS
+doOldStrictness dfs binds
+ = do binds1 <- saBinds dfs binds
+ binds2 <- cprAnalyse dfs binds1
+ return binds2
+#endif
+
+printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
+
+ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
+ printDump (ruleCheckProgram phase pat binds)
+
+-- Most passes return no stats and don't change rules
+trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
+ -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
+ -> IO (SimplCount, ModGuts)
+trBinds do_pass hsc_env us rb guts
+ = do { binds' <- do_pass dflags (mg_binds guts)
+ ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
+ where
+ dflags = hsc_dflags hsc_env
+
+trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
+ -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
+ -> IO (SimplCount, ModGuts)
+trBindsU do_pass hsc_env us rb guts
+ = do { binds' <- do_pass dflags us (mg_binds guts)
+ ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
+ where
+ dflags = hsc_dflags hsc_env
+
+-- Observer passes just peek; don't modify the bindings at all
+observe :: (DynFlags -> [CoreBind] -> IO a)
+ -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
+ -> IO (SimplCount, ModGuts)
+observe do_pass hsc_env us rb guts
+ = do { binds <- do_pass dflags (mg_binds guts)
+ ; return (zeroSimplCount dflags, guts) }
+ where
+ dflags = hsc_dflags hsc_env
\end{code}
+
%************************************************************************
%* *
\subsection{Dealing with rules}
%* *
%************************************************************************
-We must do some gentle simplifiation on the template (but not the RHS)
+-- 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,
+ -- (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 })
+ us
+ = do { 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 gentleSimplEnv local_ids
+ (better_rules,_) = initSmpl dflags us (mapSmpl (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
+ -- 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
+ (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
+ local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
+ binds_w_rules = updateBinders local_rule_base binds
+
+ hpt_rule_base = mkRuleBase home_pkg_rules
+ imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ (vcat [text "Local rules", pprRules better_rules,
+ text "",
+ text "Imported rules", pprRuleBase imp_rule_base])
+
+ ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
+ mg_rules = rules_for_imps })
+ }
+
+updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
+updateBinders local_rules binds
+ = map update_bndrs binds
+ where
+ update_bndrs (NonRec b r) = NonRec (update_bndr b) r
+ update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
+
+ update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
+ Nothing -> bndr
+ Just rules -> bndr `addIdSpecialisations` rules
+ -- The binder might have some existing rules,
+ -- arising from specialisation pragmas
+\end{code}
+
+
+We must do some gentle simplification on the template (but not the RHS)
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.
\begin{code}
-simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
-simplRules us rules binds
- = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
-
- dumpIfSet opt_D_dump_rules
- "Transformation rules"
- (vcat (map pprProtoCoreRule better_rules))
+simplRule env rule@(BuiltinRule {})
+ = returnSmpl 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' })
+
+-- It's important that simplExprGently does eta reduction.
+-- For example, in a rule 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
+-- (\a. h a a)
+--
+-- The simplifier does indeed do eta reduction (it's in
+-- Simplify.completeLam) but only if -O is on.
+\end{code}
- return better_rules
- where
- black_list_all v = True -- This stops all inlining
- sw_chkr any = SwBool False -- A bit bogus
-
- -- Boringly, we need to gather the in-scope set.
- -- Typically this thunk won't even be force, but the test in
- -- simpVar fails if it isn't right, and it might conceivably matter
- bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-
-
-simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
- | not is_local
- = returnSmpl rule -- No need to fiddle with imported rules
- | otherwise
- = simplBinders bndrs $ \ bndrs' ->
- mapSmpl simplExpr args `thenSmpl` \ args' ->
- simplExpr rhs `thenSmpl` \ rhs' ->
- returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+\begin{code}
+simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+-- Simplifies an expression
+-- does occurrence analysis, then simplification
+-- and repeats (twice currently) because one pass
+-- alone leaves tons of crud.
+-- Used (a) for user expressions typed in at the interactive prompt
+-- (b) the LHS and RHS of a RULE
+--
+-- The name 'Gently' suggests that the SimplifierMode is SimplGently,
+-- 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 ->
+ simplExpr env (occurAnalyseExpr expr1)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Glomming}
+%* *
+%************************************************************************
+
+\begin{code}
+glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
+-- Glom all binds together in one Rec, in case any
+-- transformations have introduced any new dependencies
+--
+-- NB: the global invariant is this:
+-- *** the top level bindings are never cloned, and are always unique ***
+--
+-- We sort them into dependency order, but applying transformation rules may
+-- make something at the top refer to something at the bottom:
+-- f = \x -> p (q x)
+-- h = \y -> 3
+--
+-- RULE: p (q x) = h x
+--
+-- Applying this rule makes f refer to h,
+-- although it doesn't appear to in the source program.
+-- This pass lets us control where it happens.
+--
+-- NOTICE that this cannot happen for rules whose head is a locally-defined
+-- function. It only happens for rules whose head is an imported function
+-- (p in the example above). So, for example, the rule had been
+-- RULE: f (p x) = h x
+-- then the rule for f would be attached to f itself (in its IdInfo)
+-- by prepareLocalRuleBase and h would be regarded by the occurrency
+-- analyser as free in f.
+
+glomBinds dflags binds
+ = do { showPass dflags "GlomBinds" ;
+ let { recd_binds = [Rec (flattenBinds binds)] } ;
+ return recd_binds }
+ -- Not much point in printing the result...
+ -- just consumes output bandwidth
+\end{code}
+
+
%************************************************************************
%* *
\subsection{The driver for the simplifier}
%************************************************************************
\begin{code}
-simplifyPgm :: RuleBase
- -> (SimplifierSwitch -> SwitchResult)
+simplifyPgm :: SimplifierMode
+ -> [SimplifierSwitch]
+ -> HscEnv
-> UniqSupply
- -> [CoreBind] -- Input
- -> IO (SimplCount, [CoreBind]) -- New bindings
+ -> RuleBase
+ -> ModGuts
+ -> IO (SimplCount, ModGuts) -- New bindings
-simplifyPgm (imported_rule_ids, rule_lhs_fvs)
- sw_chkr us binds
+simplifyPgm mode switches hsc_env us imp_rule_base guts
= do {
- beginPass "Simplify";
-
- -- Glom all binds together in one Rec, in case any
- -- transformations have introduced any new dependencies
- let { recd_binds = [Rec (flattenBinds binds)] };
+ showPass dflags "Simplify";
- (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
+ (termination_msg, it_count, counts_out, binds')
+ <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
- dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
+ dumpIfSet (dopt Opt_D_verbose_core2core dflags
+ && dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics"
(vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
text "",
pprSimplCount counts_out]);
- endPass "Simplify"
- (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
- binds' ;
+ endPass dflags "Simplify" Opt_D_verbose_core2core binds';
- return (counts_out, binds')
+ return (counts_out, guts { mg_binds = binds' })
}
where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
-
- core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
- | otherwise = empty
-
- iteration us iteration_no counts binds
+ dflags = hsc_dflags hsc_env
+ phase_info = case mode of
+ SimplGently -> "gentle"
+ SimplPhase n -> show n
+
+ sw_chkr = isAmongSimpl switches
+ max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
+
+ do_iteration us iteration_no counts binds
+ -- 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
+ = do {
+#ifdef DEBUG
+ if max_iterations > 2 then
+ hPutStr stderr ("NOTE: Simplifier still going after " ++
+ show max_iterations ++
+ " iterations; bailing out.\n")
+ else
+ return ();
+#endif
+ -- Subtract 1 from iteration_no to get the
+ -- number of iterations we actually completed
+ return ("Simplifier baled out", iteration_no - 1, counts, binds)
+ }
+
+ -- 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" occurAnalyseBinds binds } ;
-
- dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
+ let { tagged_binds = _scc_ "OccAnal" occurAnalysePgm binds } ;
+ dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
- -- Simplify
- let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
- black_list_fn
- (simplTopBinds tagged_binds);
- all_counts = counts `plusSimplCount` counts'
- } ;
+ -- Get any new rules, and extend the rule base
+ -- 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
+ -- miss the rules for Ids hidden inside imported inlinings
+ eps <- hscEPS hsc_env ;
+ let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
+ ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
+
+ -- Simplify the program
+ -- We do this with a *case* not a *let* because lazy pattern
+ -- matching bit us with bad space leak!
+ -- With a let, we ended up with
+ -- let
+ -- t = initSmpl ...
+ -- counts' = snd t
+ -- in
+ -- case t of {(_,counts') -> if counts'=0 then ... }
+ -- So the conditional didn't force counts', because the
+ -- selection got duplicated. Sigh!
+ case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
+ (binds', counts') -> do {
+
+ let { all_counts = counts `plusSimplCount` counts'
+ ; herald = "Simplifier phase " ++ phase_info ++
+ ", iteration " ++ show iteration_no ++
+ " out of " ++ show max_iterations
+ } ;
-- Stop if nothing happened; don't dump output
if isZeroSimplCount counts' then
- return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
+ return ("Simplifier reached fixed point", iteration_no,
+ all_counts, binds')
else do {
+ -- Short out indirections
+ -- We do this *after* at least one run of the simplifier
+ -- because indirection-shorting uses the export flag on *occurrences*
+ -- and that isn't guaranteed to be ok until after the first run propagates
+ -- stuff from the binding site to its occurrences
+ let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ;
-- Dump the result of this iteration
- dumpIfSet opt_D_dump_simpl_iterations
- ("Simplifier iteration " ++ show iteration_no
- ++ " out of " ++ show max_iterations)
- (pprSimplCount counts') ;
-
- if opt_D_dump_simpl_iterations then
- endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
- opt_D_verbose_core2core
- binds'
- else
- return [] ;
-
- -- Stop if we've run out of iterations
- if iteration_no == max_iterations then
- do {
- if max_iterations > 2 then
- hPutStr stderr ("NOTE: Simplifier still going after " ++
- show max_iterations ++
- " iterations; bailing out.\n")
- else return ();
-
- return ("Simplifier baled out", iteration_no, all_counts, binds')
- }
-
- -- Else loop
- else iteration us2 (iteration_no + 1) all_counts binds'
- } }
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
+ (pprSimplCount counts') ;
+ endPass dflags herald Opt_D_dump_simpl_iterations binds'' ;
+
+ -- Loop
+ do_iteration us2 (iteration_no + 1) all_counts binds''
+ } } } }
where
(us1, us2) = splitUniqSupply us
\end{code}
%************************************************************************
%* *
-\subsection{PostSimplification}
+ Shorting out indirections
%* *
%************************************************************************
-Several tasks are performed by the post-simplification pass
-
-1. Make the representation of NoRep literals explicit, and
- float their bindings to the top level. We only do the floating
- part for NoRep lits inside a lambda (else no gain). We need to
- take care with let x = "foo" in e
- that we don't end up with a silly binding
- let x = y in e
- with a floated "foo". What a bore.
-
-4. Do eta reduction for lambda abstractions appearing in:
- - the RHS of case alternatives
- - the body of a let
-
- These will otherwise turn into local bindings during Core->STG;
- better to nuke them if possible. (In general the simplifier does
- eta expansion not eta reduction, up to this point. It does eta
- on the RHSs of bindings but not the RHSs of case alternatives and
- let bodies)
-
+If we have this:
-------------------- NOT DONE ANY MORE ------------------------
-[March 98] Indirections are now elimianted by the occurrence analyser
-1. Eliminate indirections. The point here is to transform
- x_local = E
+ x_local = <expression>
+ ...bindings...
x_exported = x_local
- ==>
- x_exported = E
-[Dec 98] [Not now done because there is no penalty in the code
- generator for using the former form]
-2. Convert
- case x of {...; x' -> ...x'...}
- ==>
- case x of {...; _ -> ...x... }
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.
---------------------------------------------------------------
+where x_exported is exported, and x_local is not, then we replace it with this:
-Special case
-~~~~~~~~~~~~
+ x_exported = <expression>
+ x_local = x_exported
+ ...bindings...
-NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
-things, and we need local Ids for non-floated stuff):
+Without this we never get rid of the x_exported = x_local thing. This
+save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
+makes strictness information propagate better. This used to happen in
+the final phase, but it's tidier to do it here.
- Don't float stuff out of a binder that's marked as a bottoming Id.
- Reason: it doesn't do any good, and creates more CAFs that increase
- the size of SRTs.
+STRICTNESS: if we have done strictness analysis, we want the strictness info on
+x_local to transfer to x_exported. Hence the copyIdInfo call.
-eg.
+RULES: we want to *add* any RULES for x_local to x_exported.
- f = error "string"
+Note [Rules and indirection-zapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem: what if x_exported has a RULE that mentions something in ...bindings...?
+Then the things mentioned can be out of scope! Solution
+ a) Make sure that in this pass the usage-info from x_exported is
+ available for ...bindings...
+ b) If there are any such RULES, rec-ify the entire top-level.
+ It'll get sorted out next time round
-is translated to
-
- f' = unpackCString# "string"
- f = error f'
-
-hence f' and f become CAFs. Instead, the special case for
-tidyTopBinding below makes sure this comes out as
-
- f = let f' = unpackCString# "string" in error f'
-
-and we can safely ignore f as a CAF, since it can only ever be entered once.
+Messing up the rules
+~~~~~~~~~~~~~~~~~~~~
+The example that went bad on me at one stage was this one:
+
+ iterate :: (a -> a) -> a -> [a]
+ [Exported]
+ iterate = iterateList
+
+ iterateFB c f x = x `c` iterateFB c f (f x)
+ iterateList f x = x : iterateList f (f x)
+ [Not exported]
+
+ {-# RULES
+ "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
+ "iterateFB" iterateFB (:) = iterateList
+ #-}
+This got shorted out to:
+ iterateList :: (a -> a) -> a -> [a]
+ iterateList = iterate
+
+ iterateFB c f x = x `c` iterateFB c f (f x)
+ iterate f x = x : iterate f (f x)
+
+ {-# RULES
+ "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
+ "iterateFB" iterateFB (:) = iterate
+ #-}
+
+And now we get an infinite loop in the rule system
+ iterate f x -> build (\cn -> iterateFB c f x)
+ -> iterateFB (:) f x
+ -> iterate f x
+
+Tiresome old solution:
+ don't do shorting out if f has rewrite rules (see shortableIdInfo)
+
+New solution (I think):
+ use rule switching-off pragmas to get rid
+ of iterateList in the first place
+
+
+Other remarks
+~~~~~~~~~~~~~
+If more than one exported thing is equal to a local thing (i.e., the
+local thing really is shared), then we do one only:
+\begin{verbatim}
+ x_local = ....
+ x_exported1 = x_local
+ x_exported2 = x_local
+==>
+ x_exported1 = ....
+
+ x_exported2 = x_exported1
+\end{verbatim}
+
+We rely on prior eta reduction to simplify things like
+\begin{verbatim}
+ x_exported = /\ tyvars -> x_local tyvars
+==>
+ x_exported = x_local
+\end{verbatim}
+Hence,there's a possibility of leaving unchanged something like this:
+\begin{verbatim}
+ x_local = ....
+ x_exported1 = x_local Int
+\end{verbatim}
+By the time we've thrown away the types in STG land this
+could be eliminated. But I don't think it's very common
+and it's dangerous to do this fiddling in STG land
+because we might elminate a binding that's mentioned in the
+unfolding for something.
\begin{code}
-doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
-doPostSimplification us binds_in
- = do
- beginPass "Post-simplification pass"
- let binds_out = initPM us (postSimplTopBinds binds_in)
- endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
-
-postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
-postSimplTopBinds binds
- = mapPM postSimplTopBind binds `thenPM` \ binds' ->
- returnPM (bagToList (unionManyBags binds'))
-
-postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
-postSimplTopBind (NonRec bndr rhs)
- | isBottomingId bndr -- Don't lift out floats for bottoming Ids
- -- See notes above
- = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
- returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
-
-postSimplTopBind bind
- = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
- returnPM (floats `snocBag` bind')
-
-postSimplBind (NonRec bndr rhs)
- = postSimplExpr rhs `thenPM` \ rhs' ->
- returnPM (NonRec bndr rhs')
-
-postSimplBind (Rec pairs)
- = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
- returnPM (Rec (bndrs `zip` rhss'))
- where
- (bndrs, rhss) = unzip pairs
-\end{code}
+type IndEnv = IdEnv Id -- Maps local_id -> exported_id
-
-Expressions
-~~~~~~~~~~~
-\begin{code}
-postSimplExpr (Var v) = returnPM (Var v)
-postSimplExpr (Type ty) = returnPM (Type ty)
-
-postSimplExpr (App fun arg)
- = postSimplExpr fun `thenPM` \ fun' ->
- postSimplExpr arg `thenPM` \ arg' ->
- returnPM (App fun' arg')
-
-postSimplExpr (Con (Literal lit) args)
- = ASSERT( null args )
- litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
- getInsideLambda `thenPM` \ in_lam ->
- if in_lam && not (exprIsTrivial lit_expr) then
- -- It must have been a no-rep literal with a
- -- non-trivial representation; and we're inside a lambda;
- -- so float it to the top
- addTopFloat lit_ty lit_expr `thenPM` \ v ->
- returnPM (Var v)
- else
- returnPM lit_expr
-
-postSimplExpr (Con con args)
- = mapPM postSimplExpr args `thenPM` \ args' ->
- returnPM (Con con args')
-
-postSimplExpr (Lam bndr body)
- = insideLambda bndr $
- postSimplExpr body `thenPM` \ body' ->
- returnPM (Lam bndr body')
-
-postSimplExpr (Let bind body)
- = postSimplBind bind `thenPM` \ bind' ->
- postSimplExprEta body `thenPM` \ body' ->
- returnPM (Let bind' body')
-
-postSimplExpr (Note note body)
- = postSimplExprEta body `thenPM` \ body' ->
- returnPM (Note note body')
-
-postSimplExpr (Case scrut case_bndr alts)
- = postSimplExpr scrut `thenPM` \ scrut' ->
- mapPM ps_alt alts `thenPM` \ alts' ->
- returnPM (Case scrut' case_bndr alts')
+shortOutIndirections :: [CoreBind] -> [CoreBind]
+shortOutIndirections binds
+ | isEmptyVarEnv ind_env = binds
+ | no_need_to_flatten = binds'
+ | otherwise = [Rec (flattenBinds binds')] -- See Note [Rules and indirect-zapping]
where
- ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
- returnPM (con, bndrs, rhs')
-
-postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
- returnPM (etaCoreExpr e')
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[coreToStg-lits]{Converting literals}
-%* *
-%************************************************************************
-
-Literals: the NoRep kind need to be de-no-rep'd.
-We always replace them with a simple variable, and float a suitable
-binding out to the top level.
-
-\begin{code}
-litToRep :: Literal -> PostM (Type, CoreExpr)
-
-litToRep (NoRepStr s ty)
- = returnPM (ty, rhs)
+ ind_env = makeIndEnv binds
+ exp_ids = varSetElems ind_env -- These exported Ids are the subjects
+ exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
+ no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
+ binds' = concatMap zap binds
+
+ zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
+ zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
+
+ zapPair (bndr, rhs)
+ | bndr `elemVarSet` exp_id_set = []
+ | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
+ (bndr, Var exp_id)]
+ | otherwise = [(bndr,rhs)]
+
+makeIndEnv :: [CoreBind] -> IndEnv
+makeIndEnv binds
+ = foldr add_bind emptyVarEnv binds
where
- rhs = if (any is_NUL (_UNPK_ s))
-
- then -- Must cater for NULs in literal string
- mkApps (Var unpackCString2Id)
- [mkLit (MachStr s),
- mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
-
- else -- No NULs in the string
- App (Var unpackCStringId) (mkLit (MachStr s))
-
- is_NUL c = c == '\0'
-\end{code}
+ add_bind :: CoreBind -> IndEnv -> IndEnv
+ add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
+ add_bind (Rec pairs) env = foldr add_pair env pairs
+
+ 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
+
+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
+ = if isExportedId exported_id && -- Only if this is exported
+
+ isLocalId local_id && -- Only if this one is defined in this
+ -- module, so that we *can* change its
+ -- binding to be the exported thing!
+
+ not (isExportedId local_id) && -- Only if this one is not itself exported,
+ -- since the transformation will nuke it
+
+ not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
+ then
+ True
+
+{- No longer needed
+ if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
+ then True -- See note on "Messing up rules"
+ else
+#ifdef DEBUG
+ pprTrace "shortMeOut:" (ppr exported_id)
+#endif
+ False
+-}
+ else
+ False
-If an Integer is small enough (Haskell implementations must support
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
-otherwise, wrap with @addr2Integer@.
-\begin{code}
-litToRep (NoRepInteger i integer_ty)
- = returnPM (integer_ty, rhs)
- where
- rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int
- i < tARGET_MAX_INT
- = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
-
- | otherwise -- Big, so start from a string
- = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
-
-
-litToRep (NoRepRational r rational_ty)
- = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
- postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
- returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
+-----------------
+transferIdInfo :: Id -> Id -> Id
+transferIdInfo exported_id local_id
+ = modifyIdInfo transfer exported_id
where
- (ratio_data_con, integer_ty)
- = case (splitAlgTyConApp_maybe rational_ty) of
- Just (tycon, [i_ty], [con])
- -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
- (con, i_ty)
-
- _ -> (panic "ratio_data_con", panic "integer_ty")
-
-litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The monad}
-%* *
-%************************************************************************
-
-\begin{code}
-type PostM a = Bool -- True <=> inside a *value* lambda
- -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
- -> (a, (UniqSupply, Bag CoreBind))
-
-initPM :: UniqSupply -> PostM a -> a
-initPM us m
- = case m False {- not inside lambda -} (us, emptyBag) of
- (result, _) -> result
-
-returnPM v in_lam usf = (v, usf)
-thenPM m k in_lam usf = case m in_lam usf of
- (r, usf') -> k r in_lam usf'
-
-mapPM f [] = returnPM []
-mapPM f (x:xs) = f x `thenPM` \ r ->
- mapPM f xs `thenPM` \ rs ->
- returnPM (r:rs)
-
-insideLambda :: CoreBndr -> PostM a -> PostM a
-insideLambda bndr m in_lam usf | isId bndr = m True usf
- | otherwise = m in_lam usf
-
-getInsideLambda :: PostM Bool
-getInsideLambda in_lam usf = (in_lam, usf)
-
-getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
-getFloatsPM m in_lam (us, floats)
- = let
- (a, (us', floats')) = m in_lam (us, emptyBag)
- in
- ((a, floats'), (us', floats))
-
-addTopFloat :: Type -> CoreExpr -> PostM Id
-addTopFloat lit_ty lit_rhs in_lam (us, floats)
- = let
- (us1, us2) = splitUniqSupply us
- uniq = uniqFromSupply us1
- lit_id = mkSysLocal SLIT("lf") uniq lit_ty
- in
- (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
+ local_info = idInfo local_id
+ transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
+ `setWorkerInfo` workerInfo local_info
+ `setSpecInfo` addSpecInfo (specInfo exp_info)
+ (specInfo local_info)
\end{code}
-
-