SimplSR(..), mkContEx, substId,
- simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs,
+ simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
simplBinder, simplBinders,
- simplIdInfo, substExpr, substTy,
+ substExpr, substTy,
-- Floats
FloatsWith, FloatsWithExpr,
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}
-- 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'
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}
+
+
+\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
-- 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 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) &&
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
-- 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)
| 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) ->
| 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
-> 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.
-- 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
-- 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
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))
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
projects / ghc-hetmet.git / commitdiff