SimplSR(..), mkContEx, substId,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders,
+ simplBinder, simplBinders, addLetIdInfo,
substExpr, substTy,
-- Floats
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
= 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
| 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) ->
-> 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)
-- 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
-- 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
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))
projects / ghc-hetmet.git / commitdiff