From be7bf80fec1f471ceccbbe06885c265411baf25e Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 30 Oct 2007 11:38:57 +0000 Subject: [PATCH] FIX BUILD: a glitch in the new rules and inlining stuff Don't re-add the worker info to a binder until completeBind. It's not needed in its own RHS, and it may be replaced, via the substitution following postInlineUnconditionally. (Fixes build of the stage2 compiler which fell over when Coercion.lhs was being compiled.) --- compiler/basicTypes/IdInfo.lhs | 10 +- compiler/simplCore/SimplEnv.lhs | 226 ++++++++++++++------------------------- compiler/simplCore/Simplify.lhs | 17 +-- 3 files changed, 95 insertions(+), 158 deletions(-) diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 6b43c68..e64e255 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -724,9 +724,13 @@ zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) \begin{code} zapFragileInfo :: IdInfo -> Maybe IdInfo -- Zap info that depends on free variables -zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo - `setWorkerInfo` NoWorker - `setUnfoldingInfo` NoUnfolding) +zapFragileInfo info + = Just (info `setSpecInfo` emptySpecInfo + `setWorkerInfo` NoWorker + `setUnfoldingInfo` NoUnfolding + `setOccInfo` if isFragileOcc occ then NoOccInfo else occ) + where + occ = occInfo info \end{code} %************************************************************************ diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index d1fd65f..1b05737 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -35,8 +35,8 @@ module SimplEnv ( SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, - simplBinder, simplBinders, addLetIdInfo, - substExpr, substTy, + simplBinder, simplBinders, addBndrRules, + substExpr, substWorker, substTy, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -528,106 +528,51 @@ simplLamBndr env bndr (env', id1) = substIdBndr env bndr id2 = id1 `setIdUnfolding` substUnfolding env old_unf --------------- -substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform - -> (SimplEnv, Id) -- Transformed pair - --- Returns with: --- * Unique changed if necessary --- * Type substituted --- * Unfolding zapped --- * Rules, worker, lbvar info all substituted --- * Fragile occurrence info zapped --- * The in-scope set extended with the returned Id --- * The substitution extended with a DoneId if unique changed --- In this case, the var in the DoneId is the same as the --- var returned --- --- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs - -substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) - old_id - = (env { seInScope = in_scope `extendInScopeSet` new_id, - seIdSubst = new_subst }, new_id) - where - -- id1 is cloned if necessary - id1 = uniqAway in_scope old_id - - -- id2 has its type zapped - id2 = substIdType env id1 - - -- new_id has the final IdInfo - subst = mkCoreSubst env - new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2 - - -- Extend the substitution if the unique has changed - -- See the notes with substTyVarBndr for the delSubstEnv - -- Also see Note [Extending the Subst] in CoreSubst - new_subst | new_id /= old_id - = extendVarEnv id_subst old_id (DoneId new_id) - | otherwise - = delVarEnv id_subst old_id -\end{code} - -\begin{code} ------------------------------------- -seqTyVar :: TyVar -> () -seqTyVar b = b `seq` () - -seqId :: Id -> () -seqId id = seqType (idType id) `seq` - idInfo id `seq` - () - -seqIds :: [Id] -> () -seqIds [] = () -seqIds (id:ids) = seqId id `seq` seqIds ids -\end{code} - -%************************************************************************ -%* * - Let bindings -%* * -%************************************************************************ - -Simplifying let binders -~~~~~~~~~~~~~~~~~~~~~~~ -Rename the binders if necessary, - -\begin{code} +--------------- simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- A non-recursive let binder simplNonRecBndr env id - = do { let (env1, id1) = substLetIdBndr env id + = do { let (env1, id1) = substIdBndr env id ; seqId id1 `seq` return (env1, id1) } --------------- simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv +-- Recursive let binders simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids - = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids + = do { let (env1, ids1) = mapAccumL substIdBndr env ids ; seqIds ids1 `seq` return env1 } --------------- -substLetIdBndr :: SimplEnv - -> InBndr -- Env and binder to transform - -> (SimplEnv, OutBndr) --- C.f. substIdBndr above +substIdBndr :: SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) -- Clone Id if necessary, substitute its type -- Return an Id with its --- UnfoldingInfo zapped --- Rules, etc, substitutd with rec_subst --- Robust info, retained especially arity and demand info, +-- * Type substituted +-- * UnfoldingInfo, Rules, WorkerInfo zapped +-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] +-- * Robust info, retained especially arity and demand info, -- so that they are available to occurrences that occur in an -- earlier binding of a letrec --- Augment the subtitution if the unique changed +-- +-- For the robust info, see Note [Arity robustness] +-- +-- Augment the substitution if the unique changed +-- Extend the in-scope set with the new Id +-- +-- Similar to CoreSubst.substIdBndr, except that +-- the type of id_subst differs +-- all fragile info is zapped -substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) +substIdBndr 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 = zapFragileIdInfo id2 + new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo -- Extend the substitution if the unique has changed, -- or there's some useful occurrence information @@ -638,24 +583,27 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) = delVarEnv id_subst old_id \end{code} -Note [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: ARITY. We *do* transfer the arity. This is important, so that -the arity of an Id is visible in its own RHS. For example: +\begin{code} +------------------------------------ +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () + +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids +\end{code} + + +Note [Arity robustness] +~~~~~~~~~~~~~~~~~~~~~~~ +We *do* transfer the arity from from the in_id of a let binding to the +out_id. This is important, so that the arity of an Id is visible in +its own RHS. For example: f = \x. ....g (\y. f y).... We can eta-reduce the arg to g, becuase f is a value. But that needs to be visible. @@ -679,60 +627,36 @@ I'm not worried about it. Another idea is to ensure that f's arity never decreases; its arity started as 1, and we should never eta-reduce below that. -NB 3: OccInfo. 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 +Note [Robust OccInfo] +~~~~~~~~~~~~~~~~~~~~~ +It's important that we *do* retain the loop-breaker OccInfo, because +that's what stops the Id getting inlined infinitely, in the body of +the letrec. + + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. 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. + +See Note [Loop breaking and RULES] in OccAnal. -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 -> InBndr -> OutBndr -> (SimplEnv, OutBndr) -addLetIdInfo env in_id out_id - = case substIdInfo subst (idInfo in_id) of - Nothing -> (env, out_id) - Just new_info -> (modifyInScope env out_id final_id, final_id) - where - final_id = out_id `setIdInfo` new_info - where - subst = mkCoreSubst env - -substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo --- Substitute the --- rules --- worker info --- Zap the unfolding --- Keep only 'robust' OccInfo --- arity --- --- Seq'ing on the returned IdInfo is enough to cause all the --- substitutions to happen completely - -substIdInfo subst info - | nothing_to_do = Nothing - | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo) - `setSpecInfo` CoreSubst.substSpec subst old_rules - `setWorkerInfo` CoreSubst.substWorker subst old_wrkr - `setUnfoldingInfo` noUnfolding) - -- setSpecInfo does a seq - -- setWorkerInfo does a seq +addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr) +-- Rules are added back in to to hte bin +addBndrRules env in_id out_id + | isEmptySpecInfo old_rules = (env, out_id) + | otherwise = (modifyInScope env out_id final_id, final_id) where - nothing_to_do = keep_occ && - isEmptySpecInfo old_rules && - not (workerExists old_wrkr) && - not (hasUnfolding (unfoldingInfo info)) - - keep_occ = not (isFragileOcc old_occ) - old_occ = occInfo info - old_rules = specInfo info - old_wrkr = workerInfo info + subst = mkCoreSubst env + old_rules = idSpecialisation in_id + new_rules = CoreSubst.substSpec subst old_rules + final_id = out_id `setIdSpecialisation` new_rules ------------------ substIdType :: SimplEnv -> Id -> Id @@ -746,10 +670,16 @@ substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id old_ty = idType id ------------------ +substUnfolding :: SimplEnv -> Unfolding -> Unfolding substUnfolding env NoUnfolding = NoUnfolding substUnfolding env (OtherCon cons) = OtherCon cons substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs) substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g + +------------------ +substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo +substWorker env NoWorker = NoWorker +substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index b728092..89c5fb1 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -238,7 +238,7 @@ simplTopBinds env binds simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r where - (env', b') = addLetIdInfo env b (lookupRecBndr env b) + (env', b') = addBndrRules env b (lookupRecBndr env b) \end{code} @@ -256,17 +256,17 @@ simplRecBind :: SimplEnv -> TopLevelFlag -> [(InId, InExpr)] -> SimplM SimplEnv simplRecBind env top_lvl pairs - = do { let (env_with_info, triples) = mapAccumL add_info env pairs + = do { let (env_with_info, triples) = mapAccumL add_rules env pairs ; env' <- go (zapFloats env_with_info) triples ; return (env `addRecFloats` env') } -- addFloats adds the floats from env', -- *and* updates env with the in-scope set from env' where - add_info :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr)) - -- Substitute in IdInfo, agument envt - add_info env (bndr, rhs) = (env, (bndr, bndr', rhs)) + add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) = (env, (bndr, bndr', rhs)) where - (env', bndr') = addLetIdInfo env bndr (lookupRecBndr env bndr) + (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr) go env [] = return env @@ -586,6 +586,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- (for example) be no longer strictly demanded. -- The solution here is a bit ad hoc... info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding + `setWorkerInfo` worker_info + final_info | loop_breaker = new_bndr_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf | otherwise = info_w_unf @@ -599,6 +601,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs return (addNonRec env final_id new_rhs) where unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs + worker_info = substWorker env (workerInfo old_info) loop_breaker = isNonRuleLoopBreaker occ_info old_info = idInfo old_bndr occ_info = occInfo old_info @@ -905,7 +908,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont | otherwise = do { (env1, bndr1) <- simplNonRecBndr env bndr - ; let (env2, bndr2) = addLetIdInfo env1 bndr bndr1 + ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se ; simplLam env3 bndrs body cont } \end{code} -- 1.7.10.4