Commit 931a117d authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Undo patch Simplify-the-IdInfo-before-any-RHSs

Sadly the above patch wasn't right, because it fouls
up pre/postInlineUnconditionally.  This patch puts
things back as they were functionally, but with slightly
tidied-up code.
parent 18519c93
......@@ -26,7 +26,7 @@ module SimplEnv (
SimplSR(..), mkContEx, substId,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
simplBinder, simplBinders,
simplBinder, simplBinders, addLetIdInfo,
substExpr, substTy,
-- Floats
......@@ -476,79 +476,38 @@ seqIds (id:ids) = seqId id `seq` seqIds ids
Simplifying let binders
~~~~~~~~~~~~~~~~~~~~~~~
Rename the binders if necessary, and substitute their IdInfo,
and re-attach it. The resulting binders therefore have all
their RULES, which is important in a mutually recursive group
We must transfer the IdInfo of the original binder to the new binder.
This is crucial, to preserve
strictness
rules
worker info
etc. To do this we must apply the current substitution,
which incorporates earlier substitutions in this very letrec group.
NB 1. We do this *before* processing the RHS of the binder, so that
its substituted rules are visible in its own RHS.
This is important. Manuel found cases where he really, really
wanted a RULE for a recursive function to apply in that function's
own right-hand side.
NB 2: We do not transfer the arity (see Subst.substIdInfo)
The arity of an Id should not be visible
in its own RHS, else we eta-reduce
f = \x -> f x
to
f = f
which isn't sound. And it makes the arity in f's IdInfo greater than
the manifest arity, which isn't good.
The arity will get added later.
NB 3: It's important that we *do* transer the loop-breaker OccInfo,
because that's what stops the Id getting inlined infinitely, in the body
of the letrec.
NB 4: does no harm for non-recursive bindings
Rename the binders if necessary,
\begin{code}
simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
simplNonRecBndr env id
= do { let subst = mkCoreSubst env
(env1, id1) = substLetIdBndr subst env id
= do { let (env1, id1) = substLetIdBndr env id
; seqId id1 `seq` return (env1, id1) }
---------------
simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
= do { let -- Notice the knot here; we need the result to make
-- a substitution for the IdInfo. c.f. CoreSubst.substIdBndr
(env1, ids1) = mapAccumL (substLetIdBndr subst) env ids
subst = mkCoreSubst env1
= do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
; seqIds ids1 `seq` return (env1, ids1) }
---------------
substLetIdBndr :: CoreSubst.Subst -- Substitution to use for the IdInfo (knot-tied)
-> SimplEnv -> InBinder -- Env and binder to transform
substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform
-> (SimplEnv, OutBinder)
-- C.f. CoreSubst.substIdBndr
-- Clone Id if necessary, substitute its type
-- Return an Id with completely zapped IdInfo
-- [A subsequent substIdInfo will restore its IdInfo]
-- [addLetIdInfo, below, will restore its IdInfo]
-- Augment the subtitution
-- if the unique changed, *or*
-- if there's interesting occurrence info
--
-- The difference between SimplEnv.substIdBndr above is
-- a) the rec_subst
-- b) the hackish "interesting occ info" part (due to vanish)
substLetIdBndr rec_subst env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
= (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
where
id1 = uniqAway in_scope old_id
id2 = substIdType env id1
new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2
new_id = setIdInfo id2 vanillaIdInfo
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
......@@ -558,6 +517,59 @@ substLetIdBndr rec_subst env@(SimplEnv { seInScope = in_scope, seIdSubst = id_su
= extendVarEnv id_subst old_id (DoneId new_id occ_info)
| otherwise
= delVarEnv id_subst old_id
\end{code}
Add IdInfo back onto a let-bound Id
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must transfer the IdInfo of the original binder to the new binder.
This is crucial, to preserve
strictness
rules
worker info
etc. To do this we must apply the current substitution,
which incorporates earlier substitutions in this very letrec group.
NB 1. We do this *before* processing the RHS of the binder, so that
its substituted rules are visible in its own RHS.
This is important. Manuel found cases where he really, really
wanted a RULE for a recursive function to apply in that function's
own right-hand side.
NB 2: We do not transfer the arity (see Subst.substIdInfo)
The arity of an Id should not be visible
in its own RHS, else we eta-reduce
f = \x -> f x
to
f = f
which isn't sound. And it makes the arity in f's IdInfo greater than
the manifest arity, which isn't good.
The arity will get added later.
NB 3: It's important that we *do* transer the loop-breaker OccInfo,
because that's what stops the Id getting inlined infinitely, in the body
of the letrec.
NB 4: does no harm for non-recursive bindings
NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
rec { f = g
h = ...
RULE h Int = f
}
Here, we'll do postInlineUnconditionally on f, and we must "see" that
when substituting in h's RULE.
\begin{code}
addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
addLetIdInfo env in_id out_id
= (modifyInScope env out_id out_id, final_id)
where
final_id = out_id `setIdInfo` new_info
subst = mkCoreSubst env
old_info = idInfo in_id
new_info = case substIdInfo subst old_info of
Nothing -> old_info
Just new_info -> new_info
substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
-- Substitute the
......
......@@ -308,10 +308,13 @@ simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside
| isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty -- A strict let
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence info in the substitution
simplNonRecBndr env bndr `thenSmpl` \ (env, bndr2) ->
simplStrictArg AnRhs env rhs rhs_se (idType bndr2) cont_ty $ \ env2 rhs1 ->
simplNonRecBndr env bndr `thenSmpl` \ (env, bndr1) ->
simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 ->
-- Now complete the binding and simplify the body
let
(env2,bndr2) = addLetIdInfo env1 bndr bndr1
in
if needsCaseBinding bndr_ty rhs1
then
thing_inside env2 `thenSmpl` \ (floats, body) ->
......@@ -459,9 +462,10 @@ simplLazyBind :: SimplEnv
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM (FloatsWith SimplEnv)
simplLazyBind env top_lvl is_rec bndr bndr2 rhs rhs_se
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= let
rhs_env = setInScope rhs_se env
(env1,bndr2) = addLetIdInfo env bndr bndr1
rhs_env = setInScope rhs_se env1
is_top_level = isTopLevel top_lvl
ok_float_unlifted = not is_top_level && isNonRec is_rec
rhs_cont = mkRhsStop (idType bndr2)
......@@ -473,7 +477,7 @@ simplLazyBind env top_lvl is_rec bndr bndr2 rhs rhs_se
-- If any of the floats can't be floated, give up now
-- (The allLifted predicate says True for empty floats.)
if (not ok_float_unlifted && not (allLifted floats)) then
completeLazyBind env top_lvl bndr bndr2
completeLazyBind env1 top_lvl bndr bndr2
(wrapFloats floats rhs1)
else
......@@ -484,7 +488,7 @@ simplLazyBind env top_lvl is_rec bndr bndr2 rhs rhs_se
-- If the result is a PAP, float the floats out, else wrap them
-- By this time it's already been ANF-ised (if necessary)
if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
completeLazyBind env top_lvl bndr bndr2 rhs2
completeLazyBind env1 top_lvl bndr bndr2 rhs2
else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then
-- WARNING: long dodgy argument coming up
......@@ -525,12 +529,12 @@ simplLazyBind env top_lvl is_rec bndr bndr2 rhs rhs_se
ppr (filter demanded_float (floatBinds floats)) )
tick LetFloatFromLet `thenSmpl_` (
addFloats env floats $ \ env2 ->
addFloats env1 floats $ \ env2 ->
addAtomicBinds env2 (fromOL aux_binds) $ \ env3 ->
completeLazyBind env3 top_lvl bndr bndr2 rhs2)
else
completeLazyBind env top_lvl bndr bndr2 (wrapFloats floats rhs1)
completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1)
#ifdef DEBUG
demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment