Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
-- ** Substituting into expressions and related types
- deShadowBinds,
- substTy, substExpr, substSpec, substWorker,
- lookupIdSubst, lookupTvSubst,
+ deShadowBinds, substSpec, substRulesForImportedIds,
+ substTy, substExpr, substBind, substUnfolding,
+ substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
-- ** Operations on substitutions
- emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst,
+ emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
extendSubst, extendSubstList, zapSubstEnv,
extendInScope, extendInScopeList, extendInScopeIds,
-- ** 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 )
+import OptCoercion ( optCoercion )
import VarSet
import VarEnv
import Id
+import Name ( Name )
import Var ( Var, TyVar, setVarUnique )
import IdInfo
import Unique
import UniqSupply
import Maybes
+import BasicTypes ( isAlwaysActive )
import Outputable
import PprCore () -- Instances
import FastString
-- 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'
lookupTvSubst :: Subst -> TyVar -> Type
lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+-- | Simultaneously substitute for a bunch of variables
+-- No left-right shadowing
+-- ie the substitution for (\x \y. e) a1 a2
+-- so neither x nor y scope over a1 a2
+mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
+mkOpenSubst in_scope pairs = Subst in_scope
+ (mkVarEnv [(id,e) | (id, e) <- pairs, isId id])
+ (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+
------------------------------
isInScope :: Var -> Subst -> Bool
isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
%************************************************************************
\begin{code}
--- | Apply a substititon to an entire 'CoreExpr'. Rememeber, you may only apply the substitution /once/: see "CoreSubst#apply_once"
+-- | 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
go (Lit lit) = Lit lit
go (App fun arg) = App (go fun) (go arg)
go (Note note e) = Note (go_note note) (go e)
- go (Cast e co) = Cast (go e) (substTy subst co)
+ go (Cast e co) = Cast (go e) (optCoercion (getTvSubst subst) co)
+ -- Optimise coercions as we go; this is good, for example
+ -- in the RHS of rules, which are only substituted in
+
go (Lam bndr body) = Lam bndr' (substExpr subst' body)
where
(subst', bndr') = substBndr subst bndr
--
-- (Actually, within a single /type/ there might still be shadowing, because
-- 'substTy' is a no-op for the empty substitution, but that's probably OK.)
+--
+-- [Aug 09] This function is not used in GHC at the moment, but seems so
+-- short and simple that I'm going to leave it here
deShadowBinds :: [CoreBind] -> [CoreBind]
deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
\end{code}
-- | See 'Type.substTy'
substTy :: Subst -> Type -> Type
-substTy (Subst in_scope _id_env tv_env) ty
- = Type.substTy (TvSubst in_scope tv_env) ty
+substTy subst ty = Type.substTy (getTvSubst subst) ty
+
+getTvSubst :: Subst -> TvSubst
+getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
\end{code}
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 (DFunUnfolding con args)
+ = DFunUnfolding con (map (substExpr subst) args)
+
+substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
+ -- Retain an InlineRule!
+ | not (isInlineRuleSource src) -- Always zap a CoreUnfolding, to save substitution work
+ = NoUnfolding
+ | otherwise -- But keep an InlineRule!
+ = seqExpr new_tmpl `seq`
+ new_src `seq`
+ unf { uf_tmpl = new_tmpl, uf_src = new_src }
+ where
+ new_tmpl = substExpr subst tmpl
+ new_src = substUnfoldingSource subst src
+
+substUnfolding _ unf = unf -- NoUnfolding, OtherCon
+
+-------------------
+substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
+substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
+ | Just wkr_expr <- lookupVarEnv ids wkr
+ = case wkr_expr of
+ Var w1 -> InlineWrapper w1
+ _other -> WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
+ <+> ifPprDebug (equals <+> ppr wkr_expr) )
+ -- Note [Worker inlining]
+ InlineRule -- It's not a wrapper any more, but still inline it!
+
+ | Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1
+ | otherwise = WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
+ -- This can legitimately happen. The worker has been inlined and
+ -- dropped as dead code, because we don't treat the UnfoldingSource
+ -- as an "occurrence".
+ -- Note [Worker inlining]
+ InlineRule
+
+substUnfoldingSource _ src = src
+
+------------------
+substIdOcc :: Subst -> Id -> Id
+-- These Ids should not be substituted to non-Ids
+substIdOcc subst v = case lookupIdSubst subst v of
+ Var v' -> v'
+ other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
------------------
-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
+substSpec subst new_id (SpecInfo rules rhs_fvs)
+ = seqSpecInfo new_spec `seq` new_spec
+ where
+ subst_ru_fn = const (idName new_id)
+ new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
+ (substVarSet subst rhs_fvs)
+
+------------------
+substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
+substRulesForImportedIds subst rules
+ = map (substRule subst (\name -> name)) rules
-substSpec subst new_fn spec@(SpecInfo rules rhs_fvs)
- | isEmptySubst subst
- = spec
- | otherwise
- = seqSpecInfo new_rules `seq` new_rules
+------------------
+substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
+
+-- The subst_ru_fn argument is applied to substitute the ru_fn field
+-- of the rule:
+-- - Rules for *imported* Ids never change ru_fn
+-- - Rules for *local* Ids are in the IdInfo for that Id,
+-- and the ru_fn field is simply replaced by the new name
+-- of the Id
+
+substRule _ _ rule@(BuiltinRule {}) = rule
+substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
+ , ru_fn = fn_name, ru_rhs = rhs })
+ = rule { ru_bndrs = bndrs',
+ ru_fn = subst_ru_fn fn_name,
+ ru_args = map (substExpr subst') args,
+ ru_rhs = substExpr subst' rhs }
where
- new_name = idName new_fn
- new_rules = SpecInfo (map do_subst rules) (substVarSet subst rhs_fvs)
-
- 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_args = map (substExpr subst') args,
- ru_rhs = substExpr subst' rhs }
- where
- (subst', bndrs') = substBndrs subst bndrs
+ (subst', bndrs') = substBndrs subst bndrs
------------------
substVarSet :: Subst -> VarSet -> VarSet
| isId fv = exprFreeVars (lookupIdSubst subst fv)
| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
\end{code}
+
+Note [Worker inlining]
+~~~~~~~~~~~~~~~~~~~~~~
+A worker can get sustituted away entirely.
+ - it might be trivial
+ - it might simply be very small
+We do not treat an InlWrapper as an 'occurrence' in the occurence
+analyser, so it's possible that the worker is not even in scope any more.
+
+In all all these cases we simply drop the special case, returning to
+InlVanilla. The WARN is just so I can see if it happens a lot.
+
+
+%************************************************************************
+%* *
+ The Very Simple Optimiser
+%* *
+%************************************************************************
+
+\begin{code}
+simpleOptExpr :: CoreExpr -> CoreExpr
+-- Do simple optimisation on an expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once,
+-- or where the RHS is trivial
+--
+-- The result is NOT guaranteed occurence-analysed, becuase
+-- in (let x = y in ....) we substitute for x; so y's occ-info
+-- may change radically
+
+simpleOptExpr expr
+ = go init_subst (occurAnalyseExpr expr)
+ where
+ init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
+ -- It's potentially important 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_let 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_let subst (Rec prs) body
+ = Let (Rec (reverse rev_prs')) (go subst'' body)
+ where
+ (subst', bndrs') = substRecBndrs subst (map fst prs)
+ (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
+ do_pr (subst, prs) ((b,r), b') = case go_bind subst b r of
+ Left subst' -> (subst', prs)
+ Right r' -> (subst, (b',r'):prs)
+
+ go_let subst (NonRec b r) body
+ = case go_bind subst b r of
+ Left subst' -> go subst' body
+ Right r' -> Let (NonRec b' r') (go subst' body)
+ where
+ (subst', b') = substBndr subst b
+
+
+ ----------------------
+ go_bind :: Subst -> Var -> CoreExpr -> Either Subst CoreExpr
+ -- (go_bind subst old_var old_rhs)
+ -- either extends subst with (old_var -> new_rhs)
+ -- or return new_rhs for a binding new_var = new_rhs
+ go_bind subst b r
+ | Type ty <- r
+ , isTyVar b -- let a::* = TYPE ty in <body>
+ = Left (extendTvSubst subst b (substTy subst ty))
+
+ | isId b -- let x = e in <body>
+ , safe_to_inline (idOccInfo b) || exprIsTrivial r'
+ , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt]
+ = Left (extendIdSubst subst b r')
+
+ | otherwise
+ = Right r'
+ where
+ r' = go subst r
+
+ ----------------------
+ -- 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}
+
+Note [Inline prag in simplOpt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If there's an INLINE/NOINLINE pragma that restricts the phase in
+which the binder can be inlined, we don't inline here; after all,
+we don't know what phase we're in. Here's an example
+
+ foo :: Int -> Int -> Int
+ {-# INLINE foo #-}
+ foo m n = inner m
+ where
+ {-# INLINE [1] inner #-}
+ inner m = m+n
+
+ bar :: Int -> Int
+ bar n = foo n 1
+
+When inlining 'foo' in 'bar' we want the let-binding for 'inner'
+to remain visible until Phase 1
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff