\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(..), intSwitchSet,
- opt_UsageSPOn,
- DynFlags, DynFlag(..), dopt
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
+ SimplifierMode(..), DynFlags, DynFlag(..), dopt,
+ dopt_CoreToDo, buildCoreToDo
)
-import CoreLint ( beginPass, endPass )
import CoreSyn
-import CoreFVs ( ruleSomeFreeVars )
-import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) )
+import TcIface ( loadImportedRules )
+import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
+ Dependencies( dep_mods ),
+ hscEPS, hptRules )
import CSE ( cseProgram )
-import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, extendRuleBaseList, addRuleBaseFVs )
-import Module ( moduleEnvElts )
-import CoreUnfold
-import PprCore ( pprCoreBindings, pprIdCoreRule )
-import OccurAnal ( occurAnalyseBinds )
-import CoreUtils ( etaReduceExpr, coreBindsSize )
+import Rules ( RuleBase, ruleBaseIds, emptyRuleBase,
+ extendRuleBaseList, pprRuleBase, ruleCheckProgram )
+import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
+import OccurAnal ( occurAnalysePgm, occurAnalyseGlobalExpr )
+import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
+ setWorkerInfo, workerInfo,
+ setSpecInfo, specInfo )
+import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
-import SimplUtils ( simplBinders )
+import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
import SimplMonad
-import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
+import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
+import CoreLint ( endPass )
+import VarEnv ( mkInScopeSet )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, isDataConWrapId, setIdNoDiscard )
+import Id ( Id, modifyIdInfo, idInfo, idIsFrom, isExportedId, isLocalId,
+ idSpecialisation, setIdSpecialisation )
+import Rules ( addRules )
import VarSet
+import VarEnv
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 UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import IO ( hPutStr, stderr )
import Outputable
-
-import List ( partition )
+import List ( partition )
+import Maybes ( orElse )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-core2core :: DynFlags
- -> PackageRuleBase -- Rule-base accumulated from imported packages
- -> HomeSymbolTable
- -> [CoreToDo] -- Spec of what core-to-core passes to do
- -> [CoreBind] -- Binds in
- -> [IdCoreRule] -- Rules in
- -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out
-
-core2core dflags pkg_rule_base hst core_todos binds rules
+core2core :: HscEnv
+ -> ModGuts
+ -> IO ModGuts
+
+core2core hsc_env guts
= do
- us <- mkSplitUniqSupply 's'
+ let dflags = hsc_dflags hsc_env
+ core_todos
+ | Just todo <- dopt_CoreToDo dflags = todo
+ | otherwise = buildCoreToDo dflags
+
+ us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
- (rule_base, binds1, orphan_rules)
- <- prepareRules dflags pkg_rule_base hst ru_us binds rules
-
+ (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
-- DO THE BUSINESS
- (stats, processed_binds)
- <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
+ (stats, guts'') <- doCorePasses hsc_env cp_us
+ (zeroSimplCount dflags)
+ imp_rule_base guts' core_todos
dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
(pprSimplCount stats)
- -- Return results
- -- We only return local orphan rules, i.e., local rules not attached to an Id
- -- The bindings cotain more rules, embedded in the Ids
- return (processed_binds, orphan_rules)
+ return guts''
-doCorePasses :: DynFlags
- -> RuleBase -- the main rule base
- -> SimplCount -- simplifier stats
+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"
+
+ ; 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
-> UniqSupply -- uniques
- -> [CoreBind] -- local binds in (with rules attached)
+ -> SimplCount -- simplifier stats
+ -> RuleBase -- the main rule base
+ -> ModGuts -- local binds in (with rules attached)
-> [CoreToDo] -- which passes to do
- -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
+ -> IO (SimplCount, ModGuts)
-doCorePasses dflags rb stats us binds []
- = return (stats, binds)
+doCorePasses hsc_env us stats rb guts []
+ = return (stats, guts)
-doCorePasses dflags rb stats us binds (to_do : to_dos)
+doCorePasses hsc_env us stats rb guts (to_do : to_dos)
= do
let (us1, us2) = splitUniqSupply us
+ (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
+ doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 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
- (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
-
- doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
-
-doCorePass dfs rb us binds (CoreDoSimplify sw_chkr)
- = _scc_ "Simplify" simplifyPgm dfs rb sw_chkr us binds
-doCorePass dfs rb us binds CoreCSE
- = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
-doCorePass dfs rb us binds CoreLiberateCase
- = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
-doCorePass dfs rb us binds CoreDoFloatInwards
- = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
-doCorePass dfs rb us binds (CoreDoFloatOutwards f)
- = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
-doCorePass dfs rb us binds CoreDoStaticArgs
- = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
-doCorePass dfs rb us binds CoreDoStrictness
- = _scc_ "Stranal" noStats dfs (saBinds dfs binds)
-doCorePass dfs rb us binds CoreDoWorkerWrapper
- = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
-doCorePass dfs rb us binds CoreDoSpecialising
- = _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
-doCorePass dfs rb us binds CoreDoCPResult
- = _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
-doCorePass dfs rb us binds CoreDoPrintCore
- = _scc_ "PrintCore" noStats dfs (printCore binds)
-doCorePass dfs rb us binds CoreDoUSPInf
- = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
-doCorePass dfs rb us binds CoreDoGlomBinds
- = noStats dfs (glomBinds dfs binds)
-
-printCore binds = do dumpIfSet True "Print Core"
- (pprCoreBindings binds)
- return binds
-
--- most passes return no stats and don't change rules
-noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
+#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, RuleBase, ModGuts)
+trBinds do_pass hsc_env us rb guts
+ = do { binds' <- do_pass dflags (mg_binds guts)
+ ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
+ where
+ dflags = hsc_dflags hsc_env
+
+trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
+ -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
+ -> IO (SimplCount, RuleBase, ModGuts)
+trBindsU do_pass hsc_env us rb guts
+ = do { binds' <- do_pass dflags us (mg_binds guts)
+ ; return (zeroSimplCount dflags, rb, 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, RuleBase, ModGuts)
+observe do_pass hsc_env us rb guts
+ = do { binds <- do_pass dflags (mg_binds guts)
+ ; return (zeroSimplCount dflags, rb, guts) }
+ where
+ dflags = hsc_dflags hsc_env
\end{code}
-- 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. It also returns
--- Ids mentioned on LHS of some rule; these should be blacklisted.
-
--- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
--- so that the opportunity to apply the rule isn't lost too soon
+-- returns the remainder attached to Ids in an IdSet.
\begin{code}
-prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
+prepareRules :: HscEnv
+ -> ModGuts
-> UniqSupply
- -> [CoreBind] -> [IdCoreRule] -- Local bindings and rules
- -> IO (RuleBase, -- Full rule base
- [CoreBind], -- Bindings augmented with rules
- [IdCoreRule]) -- Orphan rules
-
-prepareRules dflags pkg_rule_base hst us binds rules
- = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
- (mapSmpl simplRule rules)
+ -> IO (RuleBase, -- Rule base for imported things, incl
+ -- (a) rules defined in this module (orphans)
+ -- (b) rules from other packages
+ -- (c) rules from other modules in home package
+ 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 { eps <- hscEPS hsc_env
+
+ ; 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)
+
+ (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
+ -- Get the rules for locally-defined Ids out of the RuleBase
+ -- If we miss any rules for Ids defined here, then we end up
+ -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
+ -- same as the non-local-rule-id set, so the Id looks as if it's in scope
+ -- and hence should be cloned), and now the binding for the class method
+ -- doesn't have the same Unique as the one in the Class and the tc-env
+ -- Example: class Foo a where
+ -- op :: a -> a
+ -- {-# RULES "op" op x = x #-}
+
+ -- NB: we assume that the imported rules dont include
+ -- rules for Ids in this module; if there is, the above bad things may happen
+
+ pkg_rule_base = eps_rule_base eps
+ hpt_rule_base = extendRuleBaseList pkg_rule_base home_pkg_rules
+ imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
+
+ -- Update the binders in the local bindings with the lcoal rules
+ -- Update the binders of top-level bindings by
+ -- attaching the rules for each locally-defined Id to that Id.
+ --
+ -- 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
+ local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
+ binds_w_rules = updateBinders local_rule_base binds
; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
- (vcat (map pprIdCoreRule better_rules))
+ (vcat [text "Local rules", pprIdRules better_rules,
+ text "",
+ text "Imported rules", pprRuleBase imp_rule_base])
- ; let (local_id_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
- (binds1, local_rule_fvs) = addRulesToBinds binds local_id_rules
- imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst)
- rule_base = extendRuleBaseList imp_rule_base orphan_rules
- final_rule_base = addRuleBaseFVs rule_base local_rule_fvs
- -- The last step black-lists the free vars of local rules too
-
- ; return (final_rule_base, binds1, orphan_rules)
+#ifdef DEBUG
+ ; let bad_rules = filter (idIsFrom (mg_module guts))
+ (varSetElems (ruleBaseIds imp_rule_base))
+ ; WARN( not (null bad_rules), ppr bad_rules ) return ()
+#endif
+ ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
}
- where
- sw_chkr any = SwBool False -- A bit bogus
- black_list_all v = not (isDataConWrapId v)
- -- This stops all inlining except the
- -- wrappers for data constructors
-
- add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
-
- -- Boringly, we need to gather the in-scope set.
- -- Typically this thunk won't even be forced, but the test in
- -- simpVar fails if it isn't right, and it might conceiveably matter
- local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-
-addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], IdSet)
- -- A horrible function
-
- -- Attach the rules for each locally-defined Id to that Id.
- -- - This 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
- --
- -- Both the LHS and RHS Ids are marked 'no-discard'.
- -- This means that the binding won't be discarded EVEN if the binding
- -- ends up being trivial (v = w) -- the simplifier would usually just
- -- substitute w for v throughout, but we don't apply the substitution to
- -- the rules (maybe we should?), so this substitution would make the rule
- -- bogus.
-
-addRulesToBinds binds local_rules
- = (map zap_bind binds, rule_lhs_fvs)
- where
- -- rule_fvs is the set of all variables mentioned in this module's rules
- rule_fvs = unionVarSets [ ruleSomeFreeVars isId rule | (_,rule) <- local_rules ]
- rule_base = extendRuleBaseList emptyRuleBase local_rules
- rule_lhs_fvs = ruleBaseFVs rule_base
- rule_ids = ruleBaseIds rule_base
+updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
+updateBinders rule_base binds
+ = map update_bndrs binds
+ where
+ rule_ids = ruleBaseIds rule_base
- zap_bind (NonRec b r) = NonRec (zap_bndr b) r
- zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
+ update_bndrs (NonRec b r) = NonRec (update_bndr b) r
+ update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
- zap_bndr bndr = case lookupVarSet rule_ids bndr of
- Just bndr' -> setIdNoDiscard bndr'
- Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
- | otherwise -> bndr
+ update_bndr bndr = case lookupVarSet rule_ids bndr of
+ Nothing -> bndr
+ Just id -> bndr `setIdSpecialisation` idSpecialisation id
\end{code}
This doesn't match unless you do eta reduction on the build argument.
\begin{code}
-simplRule rule@(id, BuiltinRule _)
+simplRule env rule@(IdCoreRule id _ (BuiltinRule _ _))
= returnSmpl rule
-simplRule rule@(id, Rule name bndrs args rhs)
- = simplBinders bndrs $ \ bndrs' ->
- mapSmpl simpl_arg args `thenSmpl` \ args' ->
- simplExpr rhs `thenSmpl` \ rhs' ->
- returnSmpl (id, Rule name bndrs' args' rhs')
-
-simpl_arg e
--- I've seen rules in which a LHS like
+simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs))
+ = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
+ simplExprGently env rhs `thenSmpl` \ rhs' ->
+ returnSmpl (IdCoreRule id is_orph (Rule act name bndrs' args' rhs'))
+
+-- It's important that simplExprGently does eta reduction.
+-- For example, in a rule like:
-- augment g (build h)
--- turns into
+-- we do not want to get
-- augment (\a. g a) (build h)
--- So it's a help to eta-reduce the args as we simplify them.
--- Otherwise we don't match when given an argument like
+-- otherwise we don't match when given an argument like
-- (\a. h a a)
- = simplExpr e `thenSmpl` \ e' ->
- returnSmpl (etaReduceExpr e')
+--
+-- The simplifier does indeed do eta reduction (it's in
+-- Simplify.completeLam) but only if -O is on.
+\end{code}
+
+\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 (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
+ simplExpr env (occurAnalyseGlobalExpr expr1)
\end{code}
-- analyser as free in f.
glomBinds dflags binds
- = do { beginPass dflags "GlomBinds" ;
+ = do { showPass dflags "GlomBinds" ;
let { recd_binds = [Rec (flattenBinds binds)] } ;
return recd_binds }
-- Not much point in printing the result...
%************************************************************************
\begin{code}
-simplifyPgm :: DynFlags
- -> RuleBase
- -> (SimplifierSwitch -> SwitchResult)
+simplifyPgm :: SimplifierMode
+ -> [SimplifierSwitch]
+ -> HscEnv
-> UniqSupply
- -> [CoreBind] -- Input
- -> IO (SimplCount, [CoreBind]) -- New bindings
+ -> RuleBase
+ -> ModGuts
+ -> IO (SimplCount, RuleBase, ModGuts) -- New bindings
-simplifyPgm dflags rule_base
- sw_chkr us binds
+simplifyPgm mode switches hsc_env us rule_base guts
= do {
- beginPass dflags "Simplify";
+ showPass dflags "Simplify";
- (termination_msg, it_count, counts_out, binds')
- <- iteration us 1 (zeroSimplCount dflags) binds;
+ (termination_msg, it_count, counts_out, rule_base', guts')
+ <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
dumpIfSet (dopt Opt_D_verbose_core2core dflags
&& dopt Opt_D_dump_simpl_stats dflags)
text "",
pprSimplCount counts_out]);
- endPass dflags "Simplify"
- (dopt Opt_D_verbose_core2core dflags
- && not (dopt Opt_D_dump_simpl_iterations dflags))
- binds' ;
+ endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
- return (counts_out, binds')
+ return (counts_out, rule_base', guts')
}
where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
- imported_rule_ids = ruleBaseIds rule_base
- rule_lhs_fvs = ruleBaseFVs rule_base
+ 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
- iteration us iteration_no counts binds
+ do_iteration us rule_base iteration_no counts guts
+ -- 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, rule_base, guts)
+ }
+
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
- | let sz = coreBindsSize binds in sz == sz
+ | let sz = coreBindsSize (mg_binds guts) in sz == sz
= do {
-- Occurrence analysis
- let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
+ let { short_inds = _scc_ "ZapInd" shortOutIndirections (mg_binds guts) ;
+ tagged_binds = _scc_ "OccAnal" occurAnalysePgm short_inds } ;
+
+ dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Short indirections"
+ (pprCoreBindings short_inds);
dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
- -- SIMPLIFY
+ -- Get any new rules, and extend the rule base
+ -- (on the side this extends the package rule base in the
+ -- ExternalPackageTable, ready for the next complation
+ -- in --make mode)
+ -- 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
+ new_rules <- loadImportedRules hsc_env guts ;
+ let { rule_base' = extendRuleBaseList rule_base new_rules
+ ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
+ -- The new rule base Ids are used to initialise
+ -- the in-scope set. That way, the simplifier will change any
+ -- occurrences of the imported id to the one in the imported_rule_ids
+ -- set, which are decorated with their rules.
+
+ -- 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
-- t = initSmpl ...
-- counts' = snd t
-- in
- -- case t of {(_,counts') -> if counts'=0 then ...
+ -- case t of {(_,counts') -> if counts'=0 then ... }
-- So the conditional didn't force counts', because the
-- selection got duplicated. Sigh!
- case initSmpl dflags sw_chkr us1 imported_rule_ids black_list_fn
- (simplTopBinds tagged_binds)
- of { (binds', counts') -> do {
- -- The imported_rule_ids are used by initSmpl to initialise
- -- the in-scope set. That way, the simplifier will change any
- -- occurrences of the imported id to the one in the imported_rule_ids
- -- set, which are decorated with their rules.
+ case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
+ (binds', counts') -> do {
- let { all_counts = counts `plusSimplCount` counts' } ;
+ let { guts' = guts { mg_binds = binds' }
+ ; 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, rule_base', guts')
else do {
-- Dump the result of this iteration
- dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations
- ("Simplifier iteration " ++ show iteration_no
- ++ " out of " ++ show max_iterations)
- (pprSimplCount counts') ;
-
- if dopt Opt_D_dump_simpl_iterations dflags then
- endPass dflags
- ("Simplifier iteration " ++ show iteration_no ++ " result")
- (dopt Opt_D_verbose_core2core dflags)
- binds'
- else
- return [] ;
-
- -- Stop if we've run out of iterations
- if iteration_no == max_iterations then
- do {
-#ifdef DEBUG
- if max_iterations > 2 then
- hPutStr stderr ("NOTE: Simplifier still going after " ++
- show max_iterations ++
- " iterations; bailing out.\n")
- else
-#endif
- return ();
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
+ (pprSimplCount counts') ;
- return ("Simplifier baled out", iteration_no, all_counts, binds')
- }
+ endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
- -- Else loop
- else iteration us2 (iteration_no + 1) all_counts binds'
+ -- Loop
+ do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
} } } }
where
(us1, us2) = splitUniqSupply us
\end{code}
+
+
+%************************************************************************
+%* *
+ Top-level occurrence analysis
+ [In here, not OccurAnal, because it uses
+ Rules.lhs, which depends on OccurAnal]
+%* *
+%************************************************************************
+
+In @occAnalPgm@ we do indirection-shorting. That is, if we have this:
+
+ x_local = <expression>
+ ...bindings...
+ x_exported = x_local
+
+where x_exported is exported, and x_local is not, then we replace it with this:
+
+ x_exported = <expression>
+ x_local = x_exported
+ ...bindings...
+
+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.
+
+STRICTNESS: if we have done strictness analysis, we want the strictness info on
+x_local to transfer to x_exported. Hence the copyIdInfo call.
+
+RULES: we want to *add* any RULES for x_local to x_exported.
+
+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
+
+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}
+type IndEnv = IdEnv Id -- Maps local_id -> exported_id
+
+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
+ ind_env = makeIndEnv binds
+ exp_ids = varSetElems ind_env
+ exp_id_set = mkVarSet exp_ids
+ no_need_to_flatten = all (null . rulesRules . 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
+ 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 isEmptyCoreRules (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
+
+
+-----------------
+transferIdInfo :: Id -> Id -> Id
+transferIdInfo exported_id local_id
+ = modifyIdInfo transfer exported_id
+ where
+ local_info = idInfo local_id
+ transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
+ `setWorkerInfo` workerInfo local_info
+ `setSpecInfo` addRules exported_id (specInfo exp_info)
+ (rulesRules (specInfo local_info))
+\end{code}
projects / ghc-hetmet.git / blobdiff