X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSubst.lhs;h=314ba63ab52d9880ae65007f01e71d51dcfc0bf1;hb=4f51ac1246f9a9b2bd172e2d6957d95942d12d23;hp=582ece2124a83a8861eade2817bfdb4b59974a5a;hpb=cb579c2b44b9e7aa6fdbda2b70a1361035ff2ef5;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 582ece2..314ba63 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -12,7 +12,7 @@ module CoreSubst ( -- ** Substituting into expressions and related types deShadowBinds, - substTy, substExpr, substSpec, substWorker, + substTy, substExpr, substSpec, substUnfolding, lookupIdSubst, lookupTvSubst, -- ** Operations on substitutions @@ -24,7 +24,10 @@ module CoreSubst ( -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, - cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs + cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + + -- ** Simple expression optimiser + simpleOptExpr ) where #include "HsVersions.h" @@ -32,6 +35,7 @@ module CoreSubst ( import CoreSyn import CoreFVs import CoreUtils +import OccurAnal( occurAnalyseExpr ) import qualified Type import Type ( Type, TvSubst(..), TvSubstEnv ) @@ -89,8 +93,8 @@ data Subst -- 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 @@ -118,6 +122,13 @@ In consequence: 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 @@ -129,8 +140,8 @@ Why do we make a different choice for the IdSubstEnv than the TvSubstEnv? * 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 @@ -204,7 +215,7 @@ lookupIdSubst (Subst in_scope ids _) v | 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' @@ -256,6 +267,9 @@ instance Outputable Subst where \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 @@ -464,40 +478,45 @@ substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo 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 @@ -506,7 +525,7 @@ substSpec subst new_fn spec@(SpecInfo rules 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_fn = new_name, -- Important: the function may have changed its name! ru_args = map (substExpr subst') args, ru_rhs = substExpr subst' rhs } where @@ -521,3 +540,85 @@ substVarSet subst fvs | 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 + go_nonrec subst b r' body + | isId b -- let x = e in + , 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}