-- ** Substituting into expressions and related types
deShadowBinds,
- substTy, substExpr, substSpec, substWorker,
+ substTy, substExpr, substSpec, substUnfolding,
lookupIdSubst, lookupTvSubst,
-- ** Operations on substitutions
-- ** Substituting and cloning binders
substBndr, substBndrs, substRecBndrs,
- cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
+ cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
+
+ -- ** Simple expression optimiser
+ simpleOptExpr
) where
#include "HsVersions.h"
import CoreSyn
import CoreFVs
import CoreUtils
+import OccurAnal( occurAnalyseExpr )
import qualified Type
import Type ( Type, TvSubst(..), TvSubstEnv )
-- Types.TvSubstEnv
--
-- INVARIANT 3: See Note [Extending the Subst]
+\end{code}
-{-
Note [Extending the Subst]
~~~~~~~~~~~~~~~~~~~~~~~~~~
For a core Subst, which binds Ids as well, we make a different choice for Ids
so we only extend the in-scope set. Then we must look up in the in-scope
set when we find the occurrence of x.
+* The requirement to look up the Id in the in-scope set means that we
+ must NOT take no-op short cut in the case the substitution is empty.
+ We must still look up every Id in the in-scope set.
+
+* (However, we don't need to do so for expressions found in the IdSubst
+ itself, whose range is assumed to be correct wrt the in-scope set.)
+
Why do we make a different choice for the IdSubstEnv than the TvSubstEnv?
* For Ids, we change the IdInfo all the time (e.g. deleting the
* For TyVars, only coercion variables can possibly change, and they are
easy to spot
--}
+\begin{code}
-- | An environment for substituting for 'Id's
type IdSubstEnv = IdEnv CoreExpr
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- Vital! See Note [Extending the Subst]
- | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v )
+ | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope )
Var v
-- | Find the substitution for a 'TyVar' in the 'Subst'
\begin{code}
-- | Apply a substititon to an entire 'CoreExpr'. Rememeber, you may only
-- apply the substitution /once/: see "CoreSubst#apply_once"
+--
+-- Do *not* attempt to short-cut in the case of an empty substitution!
+-- See Note [Extending the Subst]
substExpr :: Subst -> CoreExpr -> CoreExpr
substExpr subst expr
= go expr
substIdInfo subst new_id info
| nothing_to_do = Nothing
| otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules
- `setWorkerInfo` substWorker subst old_wrkr
- `setUnfoldingInfo` noUnfolding)
+ `setUnfoldingInfo` substUnfolding subst old_unf)
where
old_rules = specInfo info
- old_wrkr = workerInfo info
- nothing_to_do = isEmptySpecInfo old_rules &&
- not (workerExists old_wrkr) &&
- not (hasUnfolding (unfoldingInfo info))
+ old_unf = unfoldingInfo info
+ nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
------------------
--- | Substitutes for the 'Id's within the 'WorkerInfo'
-substWorker :: Subst -> WorkerInfo -> WorkerInfo
- -- Seq'ing on the returned WorkerInfo is enough to cause all the
- -- substitutions to happen completely
-
-substWorker _ NoWorker
- = NoWorker
-substWorker subst (HasWorker w a)
- = case lookupIdSubst subst w of
- Var w1 -> HasWorker w1 a
- other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w )
- NoWorker -- Worker has got substituted away altogether
- -- (This can happen if it's trivial,
- -- via postInlineUnconditionally, hence warning)
+-- | Substitutes for the 'Id's within an unfolding
+substUnfolding :: Subst -> Unfolding -> Unfolding
+ -- Seq'ing on the returned Unfolding is enough to cause
+ -- all the substitutions to happen completely
+substUnfolding subst unf@(InlineRule { uf_tmpl = tmpl, uf_worker = mb_wkr })
+ -- Retain an InlineRule!
+ = seqExpr new_tmpl `seq`
+ new_mb_wkr `seq`
+ unf { uf_tmpl = new_tmpl, uf_worker = new_mb_wkr }
+ where
+ new_tmpl = substExpr subst tmpl
+ new_mb_wkr = case mb_wkr of
+ Nothing -> Nothing
+ Just w -> subst_wkr w
+
+ subst_wkr w = case lookupIdSubst subst w of
+ Var w1 -> Just w1
+ other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w )
+ Nothing -- Worker has got substituted away altogether
+ -- (This can happen if it's trivial,
+ -- via postInlineUnconditionally, hence warning)
+
+substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard
+ -- Always zap a CoreUnfolding, to save substitution work
+
+substUnfolding _ unf = unf -- Otherwise no substitution to do
------------------
-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
-
-substSpec subst new_fn spec@(SpecInfo rules rhs_fvs)
- | isEmptySubst subst
- = spec
- | otherwise
+substSpec subst new_fn (SpecInfo rules rhs_fvs)
= seqSpecInfo new_rules `seq` new_rules
where
new_name = idName new_fn
do_subst rule@(BuiltinRule {}) = rule
do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
= rule { ru_bndrs = bndrs',
- ru_fn = new_name, -- Important: the function may have changed its name!
+ ru_fn = new_name, -- Important: the function may have changed its name!
ru_args = map (substExpr subst') args,
ru_rhs = substExpr subst' rhs }
where
| isId fv = exprFreeVars (lookupIdSubst subst fv)
| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
\end{code}
+
+%************************************************************************
+%* *
+ The Very Simple Optimiser
+%* *
+%************************************************************************
+
+\begin{code}
+simpleOptExpr :: CoreExpr -> CoreExpr
+-- Return an occur-analysed and slightly optimised expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once,
+-- or where the RHS is trivial
+
+simpleOptExpr expr
+ = go init_subst (occurAnalyseExpr expr)
+ where
+ init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
+ -- It's potentially to make a proper in-scope set
+ -- Consider let x = ..y.. in \y. ...x...
+ -- Then we should remember to clone y before substituting
+ -- for x. It's very unlikely to occur, because we probably
+ -- won't *be* substituting for x if it occurs inside a
+ -- lambda.
+ --
+ -- It's a bit painful to call exprFreeVars, because it makes
+ -- three passes instead of two (occ-anal, and go)
+
+ go subst (Var v) = lookupIdSubst subst v
+ go subst (App e1 e2) = App (go subst e1) (go subst e2)
+ go subst (Type ty) = Type (substTy subst ty)
+ go _ (Lit lit) = Lit lit
+ go subst (Note note e) = Note note (go subst e)
+ go subst (Cast e co) = Cast (go subst e) (substTy subst co)
+ go subst (Let bind body) = go_bind subst bind body
+ go subst (Lam bndr body) = Lam bndr' (go subst' body)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go subst (Case e b ty as) = Case (go subst e) b'
+ (substTy subst ty)
+ (map (go_alt subst') as)
+ where
+ (subst', b') = substBndr subst b
+
+
+ ----------------------
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
+ where
+ (subst', bndrs') = substBndrs subst bndrs
+
+ ----------------------
+ go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
+ (go subst' body)
+ where
+ (bndrs, rhss) = unzip prs
+ (subst', bndrs') = substRecBndrs subst bndrs
+ rhss' = map (go subst') rhss
+
+ go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
+
+ ----------------------
+ go_nonrec subst b (Type ty') body
+ | isTyVar b = go (extendTvSubst subst b ty') body
+ -- let a::* = TYPE ty in <body>
+ go_nonrec subst b r' body
+ | isId b -- let x = e in <body>
+ , exprIsTrivial r' || safe_to_inline (idOccInfo b)
+ = go (extendIdSubst subst b r') body
+ go_nonrec subst b r' body
+ = Let (NonRec b' r') (go subst' body)
+ where
+ (subst', b') = substBndr subst b
+
+ ----------------------
+ -- Unconditionally safe to inline
+ safe_to_inline :: OccInfo -> Bool
+ safe_to_inline IAmDead = True
+ safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
+ safe_to_inline (IAmALoopBreaker {}) = False
+ safe_to_inline NoOccInfo = False
+\end{code}
projects / ghc-hetmet.git / blobdiff