SimplSR(..), mkContEx, substId,
- simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders,
- simplIdInfo, substExpr, substTy,
+ simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
+ simplBinder, simplBinders, addLetIdInfo,
+ substExpr, substTy,
-- Floats
FloatsWith, FloatsWithExpr,
import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
arityInfo, setArityInfo, workerInfo, setWorkerInfo,
- unfoldingInfo, setUnfoldingInfo,
+ unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
unknownArity, workerExists
)
import CoreSyn
+import Unify ( TypeRefinement )
import Rules ( RuleBase )
import CoreUtils ( needsCaseBinding )
import CostCentre ( CostCentreStack, subsumedCCS )
import Var
import VarEnv
-import VarSet ( isEmptyVarSet, elemVarSetByKey, mkVarSet )
+import VarSet ( isEmptyVarSet )
import OrdList
-import qualified CoreSubst ( Subst, mkSubst, substExpr, substRules, substWorker )
+import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
import qualified Type ( substTy, substTyVarBndr )
import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
isUnLiftedType, seqType, tyVarsOfType )
import BasicTypes ( OccInfo(..), isFragileOcc )
-import CmdLineOpts ( SimplifierMode(..) )
+import DynFlags ( SimplifierMode(..) )
+import Util ( mapAccumL )
import Outputable
\end{code}
-- 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'
refine the environment
\begin{code}
-refineSimplEnv :: SimplEnv -> TvSubstEnv -> [OutTyVar] -> SimplEnv
+refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
-- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
- refine_tv_subst tvs
+ (refine_tv_subst, all_bound_here)
= env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
seInScope = in_scope' }
where
in_scope'
- | all bound_here (varEnvKeys refine_tv_subst) = in_scope
+ | all_bound_here = in_scope
-- The tvs are the tyvars bound here. If only they
-- are refined, there's no need to do anything
| otherwise = mapInScopeSet refine_id in_scope
- bound_here uniq = elemVarSetByKey uniq tv_set
- tv_set = mkVarSet tvs
-
refine_id v -- Only refine its type; any rules will get
-- refined if they are used (I hope)
| isId v = setIdType v (Type.substTy refine_subst (idType 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)
; 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
-- the worker/wrapper pass that must be preserved, becuase they can't
(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
-- 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
= extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
| otherwise
= delVarEnv id_subst old_id
+\end{code}
-substLetId :: SimplEnv -> Id -> (SimplEnv, Id)
--- A variant for let-bound Ids
--- Clone Id if necessary
--- Substitute its type
+
+\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 -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplNonRecBndr 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 (env1, ids1) = mapAccumL substLetIdBndr env ids
+ ; seqIds ids1 `seq` return (env1, ids1) }
+
+---------------
+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
-substLetId 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
- 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 = setIdInfo id2 vanillaIdInfo
-- 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
-%* *
-%************************************************************************
+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}
-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
+addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
+addLetIdInfo env in_id out_id
+ = (modifyInScope env out_id out_id, final_id)
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}
-%* *
-%************************************************************************
+ 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
-\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
-- 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)
- `setSpecInfo` CoreSubst.substRules subst old_rules
+ `setSpecInfo` CoreSubst.substSpec subst old_rules
`setWorkerInfo` CoreSubst.substWorker subst old_wrkr
`setUnfoldingInfo` noUnfolding)
-- setSpecInfo does a seq
-- setWorkerInfo does a seq
where
- subst = mkCoreSubst env
nothing_to_do = keep_occ && keep_arity &&
- isEmptyCoreRules old_rules &&
+ isEmptySpecInfo old_rules &&
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
projects / ghc-hetmet.git / blobdiff