Commit 339d5220 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-12-24 16:14:36 by simonpj]

---------------------------
          Refactor the simplifier
  	---------------------------

Driven by a GADT bug, I have refactored the simpifier, and the way GHC
treats substitutions.  I hope I have gotten it right.  Be cautious about updating.

* coreSyn/Subst.lhs has gone

* coreSyn/CoreSubst replaces it, except that it's quite a bit simpler

* simplCore/SimplEnv is added, and contains the simplifier-specific substitution
  stuff

Previously Subst was trying to be all things to all men, and that was making
it Too Complicated.

There may be a little more code now, but it's much easier to understand.
parent 0498d355
...@@ -19,7 +19,7 @@ import Id ( Id, setIdExported, idName, idIsFrom, isLocalId ) ...@@ -19,7 +19,7 @@ import Id ( Id, setIdExported, idName, idIsFrom, isLocalId )
import Name ( Name, isExternalName ) import Name ( Name, isExternalName )
import CoreSyn import CoreSyn
import PprCore ( pprIdRules, pprCoreExpr ) import PprCore ( pprIdRules, pprCoreExpr )
import Subst ( SubstResult(..), substExpr, mkSubst, extendIdSubstList ) import CoreSubst ( substExpr, mkSubst )
import DsMonad import DsMonad
import DsExpr ( dsLExpr ) import DsExpr ( dsLExpr )
import DsBinds ( dsHsBinds, AutoScc(..) ) import DsBinds ( dsHsBinds, AutoScc(..) )
...@@ -282,10 +282,11 @@ ds_lhs all_vars lhs ...@@ -282,10 +282,11 @@ ds_lhs all_vars lhs
-- Substitute the dict bindings eagerly, -- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form -- and take the body apart into a (f args) form
let let
subst = extendIdSubstList (mkSubst all_vars) pairs subst = mkSubst all_vars emptyVarEnv (mkVarEnv id_pairs)
pairs = [(id, ContEx subst rhs) | (id,rhs) <- dict_binds'] id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds']
-- Note recursion here... substitution won't terminate -- Note recursion here... substitution won't terminate
-- if there is genuine recursion... which there isn't -- if there is genuine recursion... which there isn't
body'' = substExpr subst body' body'' = substExpr subst body'
in in
......
...@@ -58,8 +58,8 @@ import CoreSyn ...@@ -58,8 +58,8 @@ import CoreSyn
import CmdLineOpts ( FloatOutSwitches(..) ) import CmdLineOpts ( FloatOutSwitches(..) )
import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes ) import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes )
import CoreFVs -- all of it import CoreFVs -- all of it
import Subst ( Subst, SubstResult(..), emptySubst, extendInScope, extendIdSubst, import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst,
substAndCloneId, substAndCloneRecIds ) cloneIdBndr, cloneRecIdBndrs )
import Id ( Id, idType, mkSysLocalUnencoded, import Id ( Id, idType, mkSysLocalUnencoded,
isOneShotLambda, zapDemandIdInfo, isOneShotLambda, zapDemandIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo idSpecialisation, idWorkerInfo, setIdInfo
...@@ -682,7 +682,7 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs ...@@ -682,7 +682,7 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl
= (float_lams, = (float_lams,
extendVarEnv lvl_env case_bndr lvl, extendVarEnv lvl_env case_bndr lvl,
extendIdSubst subst case_bndr (DoneEx (Var scrut_var)), extendIdSubst subst case_bndr (Var scrut_var),
extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var)) extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
extendCaseBndrLvlEnv env scrut case_bndr lvl extendCaseBndrLvlEnv env scrut case_bndr lvl
...@@ -695,7 +695,7 @@ extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pai ...@@ -695,7 +695,7 @@ extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pai
foldl add_id id_env bndr_pairs) foldl add_id id_env bndr_pairs)
where where
add_lvl env (v,v') = extendVarEnv env v' dest_lvl add_lvl env (v,v') = extendVarEnv env v' dest_lvl
add_subst env (v,v') = extendIdSubst env v (DoneEx (mkVarApps (Var v') abs_vars)) add_subst env (v,v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs
...@@ -819,7 +819,7 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl ...@@ -819,7 +819,7 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
= ASSERT( isId v ) = ASSERT( isId v )
getUs `thenLvl` \ us -> getUs `thenLvl` \ us ->
let let
(subst', v1) = substAndCloneId subst us v (subst', v1) = cloneIdBndr subst us v
v2 = zap_demand ctxt_lvl dest_lvl v1 v2 = zap_demand ctxt_lvl dest_lvl v1
env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)] env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)]
in in
...@@ -832,7 +832,7 @@ cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl ...@@ -832,7 +832,7 @@ cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
= ASSERT( all isId vs ) = ASSERT( all isId vs )
getUs `thenLvl` \ us -> getUs `thenLvl` \ us ->
let let
(subst', vs1) = substAndCloneRecIds subst us vs (subst', vs1) = cloneRecIdBndrs subst us vs
vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1 vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1
env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2) env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2)
in in
......
...@@ -24,7 +24,7 @@ import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules ) ...@@ -24,7 +24,7 @@ import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr ) import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize ) import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr ) import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplBinders ) import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
import SimplMonad import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint ( endPass ) import CoreLint ( endPass )
...@@ -98,8 +98,8 @@ simplifyExpr dflags expr ...@@ -98,8 +98,8 @@ simplifyExpr dflags expr
; us <- mkSplitUniqSupply 's' ; us <- mkSplitUniqSupply 's'
; let env = emptySimplEnv SimplGently [] ; let (expr', _counts) = initSmpl dflags us $
(expr', _counts) = initSmpl dflags us (simplExprGently env expr) simplExprGently gentleSimplEnv expr
; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr') (pprCoreExpr expr')
...@@ -107,6 +107,11 @@ simplifyExpr dflags expr ...@@ -107,6 +107,11 @@ simplifyExpr dflags expr
; return expr' ; return expr'
} }
gentleSimplEnv :: SimplEnv
gentleSimplEnv = mkSimplEnv SimplGently
(panic "simplifyExpr: switches")
emptyRuleBase
doCorePasses :: HscEnv doCorePasses :: HscEnv
-> UniqSupply -- uniques -> UniqSupply -- uniques
-> SimplCount -- simplifier stats -> SimplCount -- simplifier stats
...@@ -216,7 +221,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) ...@@ -216,7 +221,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
; let -- Simplify the local rules; boringly, we need to make an in-scope set ; let -- Simplify the local rules; boringly, we need to make an in-scope set
-- from the local binders, to avoid warnings from Simplify.simplVar -- from the local binders, to avoid warnings from Simplify.simplVar
local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds)) local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
env = setInScopeSet (emptySimplEnv SimplGently []) local_ids env = setInScopeSet gentleSimplEnv local_ids
(better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
(orphan_rules, rules_for_locals) = partition isOrphanRule better_rules (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
...@@ -413,8 +418,7 @@ simplifyPgm mode switches hsc_env us rule_base guts ...@@ -413,8 +418,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
SimplGently -> "gentle" SimplGently -> "gentle"
SimplPhase n -> show n SimplPhase n -> show n
simpl_env = emptySimplEnv mode switches sw_chkr = isAmongSimpl switches
sw_chkr = getSwitchChecker simpl_env
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
do_iteration us rule_base iteration_no counts guts do_iteration us rule_base iteration_no counts guts
...@@ -455,8 +459,7 @@ simplifyPgm mode switches hsc_env us rule_base guts ...@@ -455,8 +459,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
-- miss the rules for Ids hidden inside imported inlinings -- miss the rules for Ids hidden inside imported inlinings
new_rules <- loadImportedRules hsc_env guts ; new_rules <- loadImportedRules hsc_env guts ;
let { rule_base' = extendRuleBaseList rule_base new_rules let { rule_base' = extendRuleBaseList rule_base new_rules
; in_scope = mkInScopeSet (ruleBaseIds rule_base') ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
; simpl_env' = setInScopeSet simpl_env in_scope } ;
-- The new rule base Ids are used to initialise -- The new rule base Ids are used to initialise
-- the in-scope set. That way, the simplifier will change any -- the in-scope set. That way, the simplifier will change any
-- occurrences of the imported id to the one in the imported_rule_ids -- occurrences of the imported id to the one in the imported_rule_ids
...@@ -473,7 +476,7 @@ simplifyPgm mode switches hsc_env us rule_base guts ...@@ -473,7 +476,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
-- 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 -- So the conditional didn't force counts', because the
-- selection got duplicated. Sigh! -- selection got duplicated. Sigh!
case initSmpl dflags us1 (simplTopBinds simpl_env' tagged_binds) of { case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
(binds', counts') -> do { (binds', counts') -> do {
let { guts' = guts { mg_binds = binds' } let { guts' = guts { mg_binds = binds' }
......
This diff is collapsed.
This diff is collapsed.
...@@ -5,9 +5,11 @@ ...@@ -5,9 +5,11 @@
\begin{code} \begin{code}
module SimplUtils ( module SimplUtils (
simplBinder, simplBinders, simplRecBndrs, mkLam, prepareAlts, mkCase,
simplLetBndr, simplLamBndrs,
newId, mkLam, prepareAlts, mkCase, -- Inlining,
preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
inlineMode,
-- The continuation type -- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..), SimplCont(..), DupFlag(..), LetRhsFlag(..),
...@@ -20,7 +22,9 @@ module SimplUtils ( ...@@ -20,7 +22,9 @@ module SimplUtils (
#include "HsVersions.h" #include "HsVersions.h"
import CmdLineOpts ( SimplifierSwitch(..), opt_UF_UpdateInPlace, import SimplEnv
import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), opt_UF_UpdateInPlace,
opt_SimplNoPreInlining, opt_RulesOff,
DynFlag(..), dopt ) DynFlag(..), dopt )
import CoreSyn import CoreSyn
import CoreFVs ( exprFreeVars ) import CoreFVs ( exprFreeVars )
...@@ -29,9 +33,9 @@ import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, ...@@ -29,9 +33,9 @@ import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
findDefault, exprOkForSpeculation, exprIsValue findDefault, exprOkForSpeculation, exprIsValue
) )
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr ) import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
import Id ( Id, idType, idInfo, isDataConWorkId, import Id ( Id, idType, idInfo, isDataConWorkId, idOccInfo,
mkSysLocal, isDeadBinder, idNewDemandInfo, mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
idUnfolding, idNewStrictness idUnfolding, idNewStrictness, idInlinePragma,
) )
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad import SimplMonad
...@@ -45,6 +49,8 @@ import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) ...@@ -45,6 +49,8 @@ import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon ) import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
import Var ( tyVarKind, mkTyVar ) import Var ( tyVarKind, mkTyVar )
import VarSet import VarSet
import BasicTypes ( TopLevelFlag(..), isTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
Activation, isAlwaysActive, isActive )
import Util ( lengthExceeds, mapAccumL ) import Util ( lengthExceeds, mapAccumL )
import Outputable import Outputable
\end{code} \end{code}
...@@ -421,66 +427,272 @@ canUpdateInPlace ty ...@@ -421,66 +427,272 @@ canUpdateInPlace ty
%************************************************************************ %************************************************************************
%* * %* *
\section{Dealing with a single binder} \subsection{Decisions about inlining}
%* * %* *
%************************************************************************ %************************************************************************
These functions are in the monad only so that they can be made strict via seq. Inlining is controlled partly by the SimplifierMode switch. This has two
settings:
SimplGently (a) Simplifying before specialiser/full laziness
(b) Simplifiying inside INLINE pragma
(c) Simplifying the LHS of a rule
(d) Simplifying a GHCi expression or Template
Haskell splice
SimplPhase n Used at all other times
The key thing about SimplGently is that it does no call-site inlining.
Before full laziness we must be careful not to inline wrappers,
because doing so inhibits floating
e.g. ...(case f x of ...)...
==> ...(case (case x of I# x# -> fw x#) of ...)...
==> ...(case x of I# x# -> case fw x# of ...)...
and now the redex (f x) isn't floatable any more.
The no-inling thing is also important for Template Haskell. You might be
compiling in one-shot mode with -O2; but when TH compiles a splice before
running it, we don't want to use -O2. Indeed, we don't want to inline
anything, because the byte-code interpreter might get confused about
unboxed tuples and suchlike.
INLINE pragmas
~~~~~~~~~~~~~~
SimplGently is also used as the mode to simplify inside an InlineMe note.
\begin{code} \begin{code}
simplBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) inlineMode :: SimplifierMode
simplBinders env bndrs inlineMode = SimplGently
= let \end{code}
(subst', bndrs') = Subst.simplBndrs (getSubst env) bndrs
in
seqBndrs bndrs' `seq`
returnSmpl (setSubst env subst', bndrs')
simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) It really is important to switch off inlinings inside such
simplBinder env bndr expressions. Consider the following example
= let
(subst', bndr') = Subst.simplBndr (getSubst env) bndr let f = \pq -> BIG
in in
seqBndr bndr' `seq` let g = \y -> f y y
returnSmpl (setSubst env subst', bndr') {-# INLINE g #-}
in ...g...g...g...g...g...
Now, if that's the ONLY occurrence of f, it will be inlined inside g,
and thence copied multiple times when g is inlined.
This function may be inlinined in other modules, so we
don't want to remove (by inlining) calls to functions that have
specialisations, or that may have transformation rules in an importing
scope.
E.g. {-# INLINE f #-}
f x = ...g...
and suppose that g is strict *and* has specialisations. If we inline
g's wrapper, we deny f the chance of getting the specialised version
of g when f is inlined at some call site (perhaps in some other
module).
It's also important not to inline a worker back into a wrapper.
A wrapper looks like
wraper = inline_me (\x -> ...worker... )
Normally, the inline_me prevents the worker getting inlined into
the wrapper (initially, the worker's only call site!). But,
if the wrapper is sure to be called, the strictness analyser will
mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
continuation. That's why the keep_inline predicate returns True for
ArgOf continuations. It shouldn't do any harm not to dissolve the
inline-me note under these circumstances.
Note that the result is that we do very little simplification
inside an InlineMe.
all xs = foldr (&&) True xs
any p = all . map p {-# INLINE any #-}
Problem: any won't get deforested, and so if it's exported and the
importer doesn't use the inlining, (eg passes it as an arg) then we
won't get deforestation at all. We havn't solved this problem yet!
preInlineUnconditionally
~~~~~~~~~~~~~~~~~~~~~~~~
@preInlineUnconditionally@ examines a bndr to see if it is used just
once in a completely safe way, so that it is safe to discard the
binding inline its RHS at the (unique) usage site, REGARDLESS of how
big the RHS might be. If this is the case we don't simplify the RHS
first, but just inline it un-simplified.
This is much better than first simplifying a perhaps-huge RHS and then
inlining and re-simplifying it. Indeed, it can be at least quadratically
better. Consider
x1 = e1
x2 = e2[x1]
x3 = e3[x2]
...etc...
xN = eN[xN-1]
We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
simplLetBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) NB: we don't even look at the RHS to see if it's trivial
simplLetBndr env id We might have
= let x = y
(subst', id') = Subst.simplLetId (getSubst env) id where x is used many times, but this is the unique occurrence of y.
in We should NOT inline x at all its uses, because then we'd do the same
seqBndr id' `seq` for y -- aargh! So we must base this pre-rhs-simplification decision
returnSmpl (setSubst env subst', id') solely on x's occurrences, not on its rhs.
simplLamBndrs, simplRecBndrs Evne RHSs labelled InlineMe aren't caught here, because there might be
:: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) no benefit from inlining at the call site.
simplRecBndrs = simplBndrs Subst.simplLetId
simplLamBndrs = simplBndrs Subst.simplLamBndr
simplBndrs simpl_bndr env bndrs [Sept 01] Don't unconditionally inline a top-level thing, because that
= let can simply make a static thing into something built dynamically. E.g.
(subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs x = (a,b)
in main = \s -> h x
seqBndrs bndrs' `seq`
returnSmpl (setSubst env subst', bndrs')
seqBndrs [] = () [Remember that we treat \s as a one-shot lambda.] No point in
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs inlining x unless there is something interesting about the call site.
seqBndr b | isTyVar b = b `seq` () But watch out: if you aren't careful, some useful foldr/build fusion
| otherwise = seqType (idType b) `seq` can be lost (most notably in spectral/hartel/parstof) because the
idInfo b `seq` foldr didn't see the build. Doing the dynamic allocation isn't a big
() deal, in fact, but losing the fusion can be. But the right thing here
\end{code} seems to be to do a callSiteInline based on the fact that there is
something interesting about the call site (it's strict). Hmm. That
seems a bit fragile.
Conclusion: inline top level things gaily until Phase 0 (the last
phase), at which point don't.
\begin{code} \begin{code}
newId :: EncodedFS -> Type -> SimplM Id preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
newId fs ty = getUniqueSmpl `thenSmpl` \ uniq -> preInlineUnconditionally env top_lvl bndr
returnSmpl (mkSysLocal fs uniq ty) | isTopLevel top_lvl, SimplPhase 0 <- phase = False
-- If we don't have this test, consider
-- x = length [1,2,3]
-- The full laziness pass carefully floats all the cons cells to
-- top level, and preInlineUnconditionally floats them all back in.
-- Result is (a) static allocation replaced by dynamic allocation
-- (b) many simplifier iterations because this tickles
-- a related problem; only one inlining per pass
--
-- On the other hand, I have seen cases where top-level fusion is
-- lost if we don't inline top level thing (e.g. string constants)
-- Hence the test for phase zero (which is the phase for all the final
-- simplifications). Until phase zero we take no special notice of
-- top level things, but then we become more leery about inlining
-- them.
| not active = False
| opt_SimplNoPreInlining = False
| otherwise = case idOccInfo bndr of
IAmDead -> True -- Happens in ((\x.1) v)
OneOcc in_lam once -> not in_lam && once
-- Not inside a lambda, one occurrence ==> safe!
other -> False
where
phase = getMode env
active = case phase of
SimplGently -> isAlwaysActive prag
SimplPhase n -> isActive n prag
prag = idInlinePragma bndr
\end{code} \end{code}
postInlineUnconditionally
~~~~~~~~~~~~~~~~~~~~~~~~~
@postInlineUnconditionally@ decides whether to unconditionally inline
a thing based on the form of its RHS; in particular if it has a
trivial RHS. If so, we can inline and discard the binding altogether.
NB: a loop breaker has must_keep_binding = True and non-loop-breakers
only have *forward* references Hence, it's safe to discard the binding
NOTE: This isn't our last opportunity to inline. We're at the binding
site right now, and we'll get another opportunity when we get to the
ocurrence(s)
Note that we do this unconditional inlining only for trival RHSs.
Don't inline even WHNFs inside lambdas; doing so may simply increase
allocation when the function is called. This isn't the last chance; see
NOTE above.
NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
Because we don't even want to inline them into the RHS of constructor
arguments. See NOTE above
NB: At one time even NOINLINE was ignored here: if the rhs is trivial
it's best to inline it anyway. We often get a=E; b=a from desugaring,
with both a and b marked NOINLINE. But that seems incompatible with
our new view that inlining is like a RULE, so I'm sticking to the 'active'
story for now.
\begin{code}
postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
postInlineUnconditionally env bndr occ_info rhs
= exprIsTrivial rhs
&& active
&& not (isLoopBreaker occ_info)
&& not (isExportedId bndr)
-- We used to have (isOneOcc occ_info) instead of
-- not (isLoopBreaker occ_info) && not (isExportedId bndr)
-- That was because a rather fragile use of rules got confused
-- if you inlined even a binding f=g e.g. We used to have
-- map = mapList
-- But now a more precise use of phases has eliminated this problem,
-- so the is_active test will do the job. I think.
--
-- OLD COMMENT: (delete soon)
-- Indeed, you might suppose that
-- there is nothing wrong with substituting for a trivial RHS, even
-- if it occurs many times. But consider
-- x = y
-- h = _inline_me_ (...x...)
-- Here we do *not* want to have x inlined, even though the RHS is
-- trivial, becuase the contract for an INLINE pragma is "no inlining".
-- This is important in the rules for the Prelude
where
active = case getMode env of
SimplGently -> isAlwaysActive prag
SimplPhase n -> isActive n prag
prag = idInlinePragma bndr
activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
activeInline env id occ
= case getMode env of
SimplGently -> isOneOcc occ && isAlwaysActive prag
-- No inlining at all when doing gentle stuff,
-- except for local things that occur once
-- The reason is that too little clean-up happens if you
-- don't inline use-once things. Also a bit of inlining is *good* for
-- full laziness; it can expose constant sub-expressions.
-- Example in spectral/mandel/Mandel.hs, where the mandelset
-- function gets a useful let-float if you inline windowToViewport
-- NB: we used to have a second exception, for data con wrappers.
-- On the grounds that we use gentle mode for rule LHSs, and
-- they match better when data con wrappers are inlined.
-- But that only really applies to the trivial wrappers (like (:)),
-- and they are now constructed as Compulsory unfoldings (in MkId)
-- so they'll happen anyway.
SimplPhase n -> isActive n prag
where
prag = idInlinePragma id
activeRule :: SimplEnv -> Maybe (Activation -> Bool)
-- Nothing => No rules at all
activeRule env
| opt_RulesOff = Nothing
| otherwise
= case getMode env of
SimplGently -> Just isAlwaysActive
-- Used to be Nothing (no rules in gentle mode)
-- Main motivation for changing is that I wanted
-- lift String ===> ...
-- to work in Template Haskell when simplifying
-- splices, so we get simpler code for literal strings
SimplPhase n -> Just (isActive n)
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
......
...@@ -12,12 +12,14 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), ...@@ -12,12 +12,14 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
SimplifierSwitch(..) SimplifierSwitch(..)
) )
import SimplMonad import SimplMonad
import SimplUtils ( mkCase, mkLam, newId, prepareAlts, import SimplEnv
simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr, import SimplUtils ( mkCase, mkLam, prepareAlts,
SimplCont(..), DupFlag(..), LetRhsFlag(..), SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, pushContArgs, mkRhsStop, mkBoringStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg, contResultType, countArgs, contIsDupable, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType getContArgs, interestingCallContext, interestingArg, isStrictType,
preInlineUnconditionally, postInlineUnconditionally,
inlineMode, activeInline, activeRule
) )
import Id ( Id, idType, idInfo, idArity, isDataConWorkId, import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder, setIdUnfolding, isDeadBinder,
...@@ -49,11 +51,9 @@ import Rules ( lookupRule ) ...@@ -49,11 +51,9 @@ import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict ) import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS ) import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy, import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, coreEqType, substTy, mkTyVarTys splitFunTy_maybe, splitFunTy, coreEqType, mkTyVarTys
) )
import VarEnv ( elemVarEnv ) import VarEnv ( elemVarEnv )