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 )
import Name ( Name, isExternalName )
import CoreSyn
import PprCore ( pprIdRules, pprCoreExpr )
import Subst ( SubstResult(..), substExpr, mkSubst, extendIdSubstList )
import CoreSubst ( substExpr, mkSubst )
import DsMonad
import DsExpr ( dsLExpr )
import DsBinds ( dsHsBinds, AutoScc(..) )
......@@ -282,10 +282,11 @@ ds_lhs all_vars lhs
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
let
subst = extendIdSubstList (mkSubst all_vars) pairs
pairs = [(id, ContEx subst rhs) | (id,rhs) <- dict_binds']
subst = mkSubst all_vars emptyVarEnv (mkVarEnv id_pairs)
id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds']
-- Note recursion here... substitution won't terminate
-- if there is genuine recursion... which there isn't
body'' = substExpr subst body'
in
......
......@@ -58,8 +58,8 @@ import CoreSyn
import CmdLineOpts ( FloatOutSwitches(..) )
import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes )
import CoreFVs -- all of it
import Subst ( Subst, SubstResult(..), emptySubst, extendInScope, extendIdSubst,
substAndCloneId, substAndCloneRecIds )
import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst,
cloneIdBndr, cloneRecIdBndrs )
import Id ( Id, idType, mkSysLocalUnencoded,
isOneShotLambda, zapDemandIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
......@@ -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
= (float_lams,
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))
extendCaseBndrLvlEnv env scrut case_bndr lvl
......@@ -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)
where
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)
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
= ASSERT( isId v )
getUs `thenLvl` \ us ->
let
(subst', v1) = substAndCloneId subst us v
(subst', v1) = cloneIdBndr subst us v
v2 = zap_demand ctxt_lvl dest_lvl v1
env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)]
in
......@@ -832,7 +832,7 @@ cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
= ASSERT( all isId vs )
getUs `thenLvl` \ us ->
let
(subst', vs1) = substAndCloneRecIds subst us vs
(subst', vs1) = cloneRecIdBndrs subst us vs
vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1
env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2)
in
......
......@@ -24,7 +24,7 @@ import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplBinders )
import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint ( endPass )
......@@ -98,8 +98,8 @@ simplifyExpr dflags expr
; us <- mkSplitUniqSupply 's'
; let env = emptySimplEnv SimplGently []
(expr', _counts) = initSmpl dflags us (simplExprGently env expr)
; let (expr', _counts) = initSmpl dflags us $
simplExprGently gentleSimplEnv expr
; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
......@@ -107,6 +107,11 @@ simplifyExpr dflags expr
; return expr'
}
gentleSimplEnv :: SimplEnv
gentleSimplEnv = mkSimplEnv SimplGently
(panic "simplifyExpr: switches")
emptyRuleBase
doCorePasses :: HscEnv
-> UniqSupply -- uniques
-> SimplCount -- simplifier stats
......@@ -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
-- from the local binders, to avoid warnings from Simplify.simplVar
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)
(orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
......@@ -413,8 +418,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
SimplGently -> "gentle"
SimplPhase n -> show n
simpl_env = emptySimplEnv mode switches
sw_chkr = getSwitchChecker simpl_env
sw_chkr = isAmongSimpl switches
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
do_iteration us rule_base iteration_no counts guts
......@@ -455,8 +459,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
-- miss the rules for Ids hidden inside imported inlinings
new_rules <- loadImportedRules hsc_env guts ;
let { rule_base' = extendRuleBaseList rule_base new_rules
; in_scope = mkInScopeSet (ruleBaseIds rule_base')
; simpl_env' = setInScopeSet simpl_env in_scope } ;
; 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
......@@ -473,7 +476,7 @@ simplifyPgm mode switches hsc_env us rule_base guts
-- 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 (simplTopBinds simpl_env' tagged_binds) of {
case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
(binds', counts') -> do {
let { guts' = guts { mg_binds = binds' }
......
This diff is collapsed.
This diff is collapsed.
......@@ -5,9 +5,11 @@
\begin{code}
module SimplUtils (
simplBinder, simplBinders, simplRecBndrs,
simplLetBndr, simplLamBndrs,
newId, mkLam, prepareAlts, mkCase,
mkLam, prepareAlts, mkCase,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
inlineMode,
-- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..),
......@@ -20,7 +22,9 @@ module SimplUtils (
#include "HsVersions.h"
import CmdLineOpts ( SimplifierSwitch(..), opt_UF_UpdateInPlace,
import SimplEnv
import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), opt_UF_UpdateInPlace,
opt_SimplNoPreInlining, opt_RulesOff,
DynFlag(..), dopt )
import CoreSyn
import CoreFVs ( exprFreeVars )
......@@ -29,9 +33,9 @@ import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
import Id ( Id, idType, idInfo, isDataConWorkId,
mkSysLocal, isDeadBinder, idNewDemandInfo,
idUnfolding, idNewStrictness
import Id ( Id, idType, idInfo, isDataConWorkId, idOccInfo,
mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
idUnfolding, idNewStrictness, idInlinePragma,
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
......@@ -45,6 +49,8 @@ import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
import Var ( tyVarKind, mkTyVar )
import VarSet
import BasicTypes ( TopLevelFlag(..), isTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
Activation, isAlwaysActive, isActive )
import Util ( lengthExceeds, mapAccumL )
import Outputable
\end{code}
......@@ -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}
simplBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
simplBinders env bndrs
= let
(subst', bndrs') = Subst.simplBndrs (getSubst env) bndrs
in
seqBndrs bndrs' `seq`
returnSmpl (setSubst env subst', bndrs')
inlineMode :: SimplifierMode
inlineMode = SimplGently
\end{code}
simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
simplBinder env bndr
= let
(subst', bndr') = Subst.simplBndr (getSubst env) bndr
in
seqBndr bndr' `seq`
returnSmpl (setSubst env subst', bndr')
It really is important to switch off inlinings inside such
expressions. Consider the following example
let f = \pq -> BIG
in
let g = \y -> f y y
{-# 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)
simplLetBndr env id
= let
(subst', id') = Subst.simplLetId (getSubst env) id
in
seqBndr id' `seq`
returnSmpl (setSubst env subst', id')
NB: we don't even look at the RHS to see if it's trivial
We might have
x = y
where x is used many times, but this is the unique occurrence of y.
We should NOT inline x at all its uses, because then we'd do the same
for y -- aargh! So we must base this pre-rhs-simplification decision
solely on x's occurrences, not on its rhs.
simplLamBndrs, simplRecBndrs
:: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
simplRecBndrs = simplBndrs Subst.simplLetId
simplLamBndrs = simplBndrs Subst.simplLamBndr
Evne RHSs labelled InlineMe aren't caught here, because there might be
no benefit from inlining at the call site.
simplBndrs simpl_bndr env bndrs
= let
(subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
in
seqBndrs bndrs' `seq`
returnSmpl (setSubst env subst', bndrs')
[Sept 01] Don't unconditionally inline a top-level thing, because that
can simply make a static thing into something built dynamically. E.g.
x = (a,b)
main = \s -> h x
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
[Remember that we treat \s as a one-shot lambda.] No point in
inlining x unless there is something interesting about the call site.
seqBndr b | isTyVar b = b `seq` ()
| otherwise = seqType (idType b) `seq`
idInfo b `seq`
()
\end{code}
But watch out: if you aren't careful, some useful foldr/build fusion
can be lost (most notably in spectral/hartel/parstof) because the
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
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}
newId :: EncodedFS -> Type -> SimplM Id
newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
returnSmpl (mkSysLocal fs uniq ty)
preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
preInlineUnconditionally env top_lvl bndr
| 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}
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),
SimplifierSwitch(..)
)
import SimplMonad
import SimplUtils ( mkCase, mkLam, newId, prepareAlts,
simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
import SimplEnv
import SimplUtils ( mkCase, mkLam, prepareAlts,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType
getContArgs, interestingCallContext, interestingArg, isStrictType,
preInlineUnconditionally, postInlineUnconditionally,
inlineMode, activeInline, activeRule
)
import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
......@@ -49,11 +51,9 @@ import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, coreEqType, substTy, mkTyVarTys
splitFunTy_maybe, splitFunTy, coreEqType, mkTyVarTys
)
import VarEnv ( elemVarEnv )
import Subst ( SubstResult(..), emptySubst, substExpr,
substId, simplIdInfo )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
......@@ -234,7 +234,7 @@ simplTopBinds env binds
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simplLetBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
......@@ -301,7 +301,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally env NotTopLevel bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
thing_inside (extendIdSubst env bndr (ContEx (getSubst rhs_se) rhs))
thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs))
| isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
......@@ -314,7 +314,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
let
-- simplLetBndr doesn't deal with the IdInfo, so we must
-- do so here (c.f. simplLazyBind)
bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
env2 = modifyInScope env1 bndr2 bndr2
in
completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
......@@ -361,7 +361,7 @@ simplNonRecX env bndr new_rhs thing_inside
-- Similarly, single occurrences can be inlined vigourously
-- e.g. case (f x, g y) of (a,b) -> ....
-- If a,b occur once we can avoid constructing the let binding for them.
= thing_inside (extendIdSubst env bndr (ContEx emptySubst new_rhs))
= thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
| otherwise
= simplBinder env bndr `thenSmpl` \ (env, bndr') ->
......@@ -423,7 +423,7 @@ simplRecOrTopPair :: SimplEnv
simplRecOrTopPair env top_lvl bndr bndr' rhs
| preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
returnSmpl (emptyFloats env, extendIdSubst env bndr (ContEx (getSubst env) rhs))
returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs))
| otherwise
= simplLazyBind env top_lvl Recursive bndr bndr' rhs env
......@@ -486,7 +486,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
-- NB 4: does no harm for non-recursive bindings
bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
env1 = modifyInScope env bndr2 bndr2
rhs_env = setInScope rhs_se env1
is_top_level = isTopLevel top_lvl
......@@ -704,7 +704,7 @@ might do the same again.
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
where
expr_ty' = substTy (getTvSubst env) (exprType expr)
expr_ty' = substTy env (exprType expr)
-- The type in the Stop continuation, expr_ty', is usually not used
-- It's only needed when discarding continuations after finding
-- a function that returns bottom.
......@@ -743,10 +743,10 @@ simplExprF env (Case scrut bndr case_ty alts) cont
rebuild env case_expr' cont
where
case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
case_ty' = substTy (getTvSubst env) case_ty -- c.f. defn of simplExpr
case_ty' = substTy env case_ty -- c.f. defn of simplExpr
simplExprF env (Let (Rec pairs) body) cont
= simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
= simplLetBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
......@@ -766,7 +766,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType
simplType env ty
= seqType new_ty `seq` returnSmpl new_ty
where
new_ty = substTy (getTvSubst env) ty
new_ty = substTy env ty
\end{code}
......@@ -864,8 +864,8 @@ simplNote env (Coerce to from) body cont
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
new_arg = mkCoerce2 s1 t1 (substExpr subst arg)
subst = getSubst (setInScope arg_se env)
new_arg = mkCoerce2 s1 t1 (substExpr arg_env arg)
arg_env = setInScope arg_se env
in
ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
......@@ -911,10 +911,10 @@ simplNote env (CoreNote s) e cont
\begin{code}
simplVar env var cont
= case substId (getSubst env) var of
DoneEx e -> simplExprF (zapSubstEnv env) e cont
ContEx se e -> simplExprF (setSubstEnv env se) e cont
DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont
= case substId env var of
DoneEx e -> simplExprF (zapSubstEnv env) e cont
ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
......@@ -966,9 +966,10 @@ completeCall env var occ_info cont
let