Commit 2317c27b authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Simplify the IdInfo before any RHSs

	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Simplfy (i.e. substitute) the IdInfo of a recursive group of Ids
before looking at the RHSs of *any* of them.  That way, the rules
are available throughout the letrec, which means we don't have to
be careful about function to put first.

Before, we just simplified the IdInfo of f before looking at f's RHS,
but that's not so good when f and g both have RULES, and both rules
mention the other.

This change makes things simpler, but shouldn't change performance.
parent badd5d76
......@@ -254,7 +254,7 @@ substIdBndr rec_subst subst@(Subst in_scope env tvs) old_id
new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2
-- Extend the substitution if the unique has changed
-- See the notes with substTyVarBndr for the delSubstEnv
-- See the notes with substTyVarBndr for the delVarEnv
new_env | new_id /= old_id = extendVarEnv env old_id (Var new_id)
| otherwise = delVarEnv env old_id
\end{code}
......
......@@ -22,11 +22,10 @@ import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial, isDefaultAlt )
import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
idOccInfo, setIdOccInfo, isLocalId,
isExportedId, idArity, idSpecialisation,
isExportedId, idArity,
idType, idUnique, Id
)
import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
import IdInfo ( isEmptySpecInfo )
import VarSet
import VarEnv
......@@ -320,9 +319,14 @@ reOrderRec env (CyclicSCC (bind : binds))
| inlineCandidate bndr rhs = 2 -- Likely to be inlined
| not (isEmptySpecInfo (idSpecialisation bndr)) = 1
-- Avoid things with specialisations; we'd like
-- to take advantage of them in the subsequent bindings
-- NOT NEEDED ANY MORE [Feb06]
-- We make all rules available in all bindings, by substituting
-- the IdInfo before looking at any RHSs. I'm just leaving this
-- snippet in as a commment so we can find it again if necessary.
--
-- | not (isEmptySpecInfo (idSpecialisation bndr)) = 1
-- -- Avoid things with specialisations; we'd like
-- -- to take advantage of them in the subsequent bindings
| otherwise = 0
......
......@@ -25,9 +25,9 @@ module SimplEnv (
SimplSR(..), mkContEx, substId,
simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
simplBinder, simplBinders,
simplIdInfo, substExpr, substTy,
substExpr, substTy,
-- Floats
FloatsWith, FloatsWithExpr,
......@@ -61,7 +61,8 @@ import qualified Type ( substTy, substTyVarBndr )
import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
isUnLiftedType, seqType, tyVarsOfType )
import BasicTypes ( OccInfo(..), isFragileOcc )
import DynFlags ( SimplifierMode(..) )
import DynFlags ( SimplifierMode(..) )
import Util ( mapAccumL )
import Outputable
\end{code}
......@@ -278,7 +279,12 @@ addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
-- The new Ids are guaranteed to be freshly allocated
addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
= env { seInScope = in_scope `extendInScopeSetList` vs,
seIdSubst = id_subst `delVarEnvList` vs } -- Why delete?
seIdSubst = id_subst `delVarEnvList` vs }
-- Why delete? Consider
-- let x = a*b in (x, \x -> x+3)
-- We add [x |-> a*b] to the substitution, but we must
-- *delete* it from the substitution when going inside
-- the (\x -> ...)!
modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
......@@ -374,11 +380,10 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
These functions are in the monad only so that they can be made strict via seq.
\begin{code}
simplBinders, simplLamBndrs, simplLetBndrs
simplBinders, simplLamBndrs
:: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
simplLetBndrs env bndrs = mapAccumLSmpl simplLetBndr env bndrs
-------------
simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
......@@ -393,11 +398,6 @@ simplBinder env bndr
| otherwise = do { let (env', id) = substIdBndr env bndr
; seqId id `seq` return (env', id) }
-------------
simplLetBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
simplLetBndr env id = do { let (env', id') = substLetId env id
; seqId id' `seq` return (env', id') }
-------------
simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
-- Used for lambda binders. These sometimes have unfoldings added by
......@@ -414,17 +414,7 @@ simplLamBndr env bndr
(env', id1) = substIdBndr env bndr
id2 = id1 `setIdUnfolding` substUnfolding env old_unf
-------------
seqTyVar :: TyVar -> ()
seqTyVar b = b `seq` ()
seqId :: Id -> ()
seqId id = seqType (idType id) `seq`
idInfo id `seq`
()
\end{code}
\begin{code}
--------------
substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
-> (SimplEnv, Id) -- Transformed pair
......@@ -450,10 +440,9 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
-- id2 has its type zapped
id2 = substIdType env id1
-- new_id has the right IdInfo
-- The lazy-set is because we're in a loop here, with
-- rec_env, when dealing with a mutually-recursive group
new_id = maybeModifyIdInfo (substIdInfo env) id2
-- new_id has the final IdInfo
subst = mkCoreSubst env
new_id = maybeModifyIdInfo (substIdInfo subst) id2
-- Extend the substitution if the unique has changed
-- See the notes with substTyVarBndr for the delSubstEnv
......@@ -461,94 +450,116 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
= extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_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
%* *
%************************************************************************
substLetId :: SimplEnv -> Id -> (SimplEnv, Id)
-- A variant for let-bound Ids
-- Clone Id if necessary
-- Substitute its type
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
\begin{code}
simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
simplNonRecBndr env id
= do { let subst = mkCoreSubst env
(env1, id1) = substLetIdBndr subst 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
; seqIds ids1 `seq` return (env1, ids1) }
---------------
substLetIdBndr :: CoreSubst.Subst -- Substitution to use for the IdInfo (knot-tied)
-> 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]
-- 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)
substLetId env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
substLetIdBndr rec_subst env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
= (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
where
old_info = idInfo old_id
id1 = uniqAway in_scope old_id
id2 = substIdType env id1
new_id = setIdInfo id2 vanillaIdInfo
id1 = uniqAway in_scope old_id
id2 = substIdType env id1
new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
-- See the notes with substTyVarBndr for the delSubstEnv
occ_info = occInfo old_info
occ_info = occInfo (idInfo old_id)
new_subst | new_id /= old_id || isFragileOcc occ_info
= extendVarEnv id_subst old_id (DoneId new_id occ_info)
| otherwise
= delVarEnv id_subst old_id
\end{code}
%************************************************************************
%* *
Impedence matching to type substitution
%* *
%************************************************************************
\begin{code}
substTy :: SimplEnv -> Type -> Type
substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
= Type.substTy (TvSubst in_scope tv_env) ty
substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
= case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
(TvSubst in_scope' tv_env', tv')
-> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
-- When substituting in rules etc we can get CoreSubst to do the work
-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
-- here. I think the this will not usually result in a lot of work;
-- the substitutions are typically small, and laziness will avoid work in many cases.
mkCoreSubst :: SimplEnv -> CoreSubst.Subst
mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
= mk_subst tv_env id_env
where
mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
fiddle (DoneEx e) = e
fiddle (DoneId v occ) = Var v
fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
substExpr :: SimplEnv -> CoreExpr -> CoreExpr
substExpr env expr
| isEmptySimplSubst env = expr
| otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
\end{code}
%************************************************************************
%* *
\section{IdInfo substitution}
%* *
%************************************************************************
\begin{code}
simplIdInfo :: SimplEnv -> IdInfo -> IdInfo
-- Used by the simplifier to compute new IdInfo for a let(rec) binder,
-- subsequent to simplLetId having zapped its IdInfo
simplIdInfo env old_info
= case substIdInfo env old_info of
Just new_info -> new_info
Nothing -> old_info
substIdInfo :: SimplEnv
-> IdInfo
-> Maybe IdInfo
substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
-- Substitute the
-- rules
-- worker info
......@@ -559,7 +570,7 @@ substIdInfo :: SimplEnv
-- Seq'ing on the returned IdInfo is enough to cause all the
-- substitutions to happen completely
substIdInfo env info
substIdInfo subst info
| nothing_to_do = Nothing
| otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
`setArityInfo` (if keep_arity then old_arity else unknownArity)
......@@ -569,7 +580,6 @@ substIdInfo env info
-- setSpecInfo does a seq
-- setWorkerInfo does a seq
where
subst = mkCoreSubst env
nothing_to_do = keep_occ && keep_arity &&
isEmptySpecInfo old_rules &&
not (workerExists old_wrkr) &&
......@@ -601,6 +611,45 @@ substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rh
\end{code}
%************************************************************************
%* *
Impedence matching to type substitution
%* *
%************************************************************************
\begin{code}
substTy :: SimplEnv -> Type -> Type
substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
= Type.substTy (TvSubst in_scope tv_env) ty
substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
= case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
(TvSubst in_scope' tv_env', tv')
-> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
-- When substituting in rules etc we can get CoreSubst to do the work
-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
-- here. I think the this will not usually result in a lot of work;
-- the substitutions are typically small, and laziness will avoid work in many cases.
mkCoreSubst :: SimplEnv -> CoreSubst.Subst
mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
= mk_subst tv_env id_env
where
mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
fiddle (DoneEx e) = e
fiddle (DoneId v occ) = Var v
fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
substExpr :: SimplEnv -> CoreExpr -> CoreExpr
substExpr env expr
| isEmptySimplSubst env = expr
| otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
\end{code}
%************************************************************************
%* *
\subsection{Floats}
......
......@@ -233,7 +233,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.
simplLetBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
......@@ -308,16 +308,10 @@ 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
simplLetBndr env bndr `thenSmpl` \ (env, bndr1) ->
simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 ->
simplNonRecBndr env bndr `thenSmpl` \ (env, bndr2) ->
simplStrictArg AnRhs env rhs rhs_se (idType bndr2) cont_ty $ \ env2 rhs1 ->
-- Now complete the binding and simplify the body
let
-- simplLetBndr doesn't deal with the IdInfo, so we must
-- do so here (c.f. simplLazyBind)
bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
env2 = modifyInScope env1 bndr2 bndr2
in
if needsCaseBinding bndr_ty rhs1
then
thing_inside env2 `thenSmpl` \ (floats, body) ->
......@@ -329,7 +323,7 @@ simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence info in the substitution
simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
simplNonRecBndr env bndr `thenSmpl` \ (env, bndr') ->
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
......@@ -465,43 +459,12 @@ simplLazyBind :: SimplEnv
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM (FloatsWith SimplEnv)
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= let -- Transfer the IdInfo of the original binder to the new binder
-- This is crucial: we must 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
bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
env1 = modifyInScope env bndr2 bndr2
rhs_env = setInScope rhs_se env1
simplLazyBind env top_lvl is_rec bndr bndr2 rhs rhs_se
= let
rhs_env = setInScope rhs_se env
is_top_level = isTopLevel top_lvl
ok_float_unlifted = not is_top_level && isNonRec is_rec
rhs_cont = mkRhsStop (idType bndr1)
rhs_cont = mkRhsStop (idType bndr2)
in
-- Simplify the RHS; note the mkRhsStop, which tells
-- the simplifier that this is the RHS of a let.
......@@ -510,7 +473,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 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 env1 top_lvl bndr bndr2
completeLazyBind env top_lvl bndr bndr2
(wrapFloats floats rhs1)
else
......@@ -521,7 +484,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 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 env1 top_lvl bndr bndr2 rhs2
completeLazyBind env top_lvl bndr bndr2 rhs2
else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then
-- WARNING: long dodgy argument coming up
......@@ -562,12 +525,12 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
ppr (filter demanded_float (floatBinds floats)) )
tick LetFloatFromLet `thenSmpl_` (
addFloats env1 floats $ \ env2 ->
addFloats env floats $ \ env2 ->
addAtomicBinds env2 (fromOL aux_binds) $ \ env3 ->
completeLazyBind env3 top_lvl bndr bndr2 rhs2)
else
completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1)
completeLazyBind env top_lvl bndr bndr2 (wrapFloats floats rhs1)
#ifdef DEBUG
demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
......@@ -756,7 +719,7 @@ simplExprF env (Case scrut bndr case_ty alts) cont
case_ty' = substTy env case_ty -- c.f. defn of simplExpr
simplExprF env (Let (Rec pairs) body) cont
= simplLetBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
= simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
......
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