Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
-- ** Substituting into expressions and related types
- deShadowBinds,
- substTy, substExpr, substSpec, substUnfolding,
- 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,
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
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
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}
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 })
+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_mb_wkr `seq`
- unf { uf_tmpl = new_tmpl, uf_worker = new_mb_wkr }
+ new_src `seq`
+ unf { uf_tmpl = new_tmpl, uf_src = new_src }
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)
+ 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
-substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard
- -- Always zap a CoreUnfolding, to save substitution work
-
-substUnfolding _ unf = unf -- Otherwise no substitution to do
+------------------
+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_fn (SpecInfo rules rhs_fvs)
- = seqSpecInfo new_rules `seq` new_rules
+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
+
+------------------
+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
| 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
--- Return an occur-analysed and slightly optimised expression
+-- 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 to make a proper in-scope set
+ -- 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
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 (Let bind body) = go_let subst bind body
go subst (Lam bndr body) = Lam bndr' (go subst' body)
where
(subst', bndr') = substBndr subst bndr
(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_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 (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)
+ 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
- (subst', b') = substBndr subst b
+ r' = go subst r
----------------------
-- Unconditionally safe to inline
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