From 931a117d6236076788c560fb2e08c538be95bd45 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 1 Mar 2006 16:14:23 +0000 Subject: [PATCH] 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. --- ghc/compiler/simplCore/SimplEnv.lhs | 110 +++++++++++++++++++---------------- ghc/compiler/simplCore/Simplify.lhs | 20 ++++--- 2 files changed, 73 insertions(+), 57 deletions(-) diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 0f5d467..00f035e 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -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 diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 0c857c6..5ea0a91 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -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)) -- 1.7.10.4