X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCSE.lhs;h=5bec8f0c3d7705dbaf78cce28f9886013004477d;hp=93b0b8dd6044245808996d66d7bed9c7646b1a69;hb=c0687066474aa4ce4912f31a5c09c1bcd673fb06;hpb=ac4a2563ee5b8d6bb9d0a366fe0ff3ed3fde4bb2 diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 93b0b8d..5bec8f0 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -10,19 +10,18 @@ module CSE ( #include "HsVersions.h" -import DynFlags ( DynFlag(..), DynFlags ) -import Id ( Id, idType, idInlinePragma ) -import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap ) +import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) +import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap ) import DataCon ( isUnboxedTupleCon ) import Type ( tyConAppArgs ) import CoreSyn import VarEnv -import CoreLint ( showPass, endPass ) import Outputable import StaticFlags ( opt_PprStyle_Debug ) import BasicTypes ( isAlwaysActive ) import Util ( lengthExceeds ) import UniqFM +import FastString import Data.List \end{code} @@ -50,8 +49,8 @@ So we carry an extra var->var substitution which we apply *before* looking up in reverse mapping. -[Note: SHADOWING] -~~~~~~~~~~~~~~~~~ +Note [Shadowing] +~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider f = \x -> let y = x+x in @@ -68,7 +67,7 @@ to run the substitution over types and IdInfo. No no no. Instead, we just thro (In fact, I think the simplifier does guarantee no-shadowing for type variables.) -[Note: case binders 1] +Note [Case binders 1] ~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -82,9 +81,9 @@ but for CSE purpose that's a bad idea. So we add the binding (wild1 -> a) to the extra var->var mapping. Notice this is exactly backwards to what the simplifier does, which is -to try to replaces uses of a with uses of wild1 +to try to replaces uses of 'a' with uses of 'wild1' -[Note: case binders 2] +Note [Case binders 2] ~~~~~~~~~~~~~~~~~~~~~~ Consider case (h x) of y -> ...(h x)... @@ -97,7 +96,7 @@ to the reverse CSE mapping if the scrutinee is a non-trivial expression. case binder -> scrutinee to the substitution -[Note: unboxed tuple case binders] +Note [Unboxed tuple case binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider case f x of t { (# a,b #) -> @@ -115,7 +114,7 @@ Note [CSE for INLINE and NOINLINE] We are careful to do no CSE inside functions that the user has marked as INLINE or NOINLINE. In terms of Core, that means - a) we do not do CSE inside (Note InlineMe e) + a) we do not do CSE inside an InlineRule b) we do not do CSE on the RHS of a binding b=e unless b's InlinePragma is AlwaysActive @@ -177,14 +176,8 @@ happen now that we don't look inside INLINEs (which wrappers are). %************************************************************************ \begin{code} -cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind] - -cseProgram dflags binds - = do { - showPass dflags "Common sub-expression"; - let { binds' = cseBinds emptyCSEnv binds }; - endPass dflags "Common sub-expression" Opt_D_dump_cse binds' - } +cseProgram :: [CoreBind] -> [CoreBind] +cseProgram binds = cseBinds emptyCSEnv binds cseBinds :: CSEnv -> [CoreBind] -> [CoreBind] cseBinds _ [] = [] @@ -208,12 +201,13 @@ do_one env (id, rhs) Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs')) where (env', id') = addBinder env id - rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs - | otherwise = rhs + rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs + | otherwise = rhs -- See Note [CSE for INLINE and NOINLINE] tryForCSE :: CSEnv -> CoreExpr -> CoreExpr tryForCSE _ (Type t) = Type t +tryForCSE _ (Coercion c) = Coercion c tryForCSE env expr = case lookupCSEnv env expr' of Just smaller_expr -> smaller_expr Nothing -> expr' @@ -222,44 +216,50 @@ tryForCSE env expr = case lookupCSEnv env expr' of cseExpr :: CSEnv -> CoreExpr -> CoreExpr cseExpr _ (Type t) = Type t +cseExpr _ (Coercion co) = Coercion co cseExpr _ (Lit lit) = Lit lit cseExpr env (Var v) = Var (lookupSubst env v) cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) -cseExpr _ (Note InlineMe e) = Note InlineMe e -- See Note [CSE for INLINE and NOINLINE] cseExpr env (Note n e) = Note n (cseExpr env e) cseExpr env (Cast e co) = Cast (cseExpr env e) co cseExpr env (Lam b e) = let (env', b') = addBinder env b in Lam b' (cseExpr env' e) cseExpr env (Let bind e) = let (env', bind') = cseBind env bind in Let bind' (cseExpr env' e) -cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts) +cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts) where scrut' = tryForCSE env scrut (env', bndr') = addBinder env bndr - + bndr'' = zapIdOccInfo bndr' + -- The swizzling from Note [Case binders 2] may + -- cause a dead case binder to be alive, so we + -- play safe here and bring them all to life cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt] cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)] | isUnboxedTupleCon con -- Unboxed tuples are special because the case binder isn't - -- a real values. See [Note: unboxed tuple case binders] - = [(DataAlt con, args', tryForCSE new_env rhs)] + -- a real value. See Note [Unboxed tuple case binders] + = [(DataAlt con, args'', tryForCSE new_env rhs)] where (env', args') = addBinders env args + args'' = map zapIdOccInfo args' -- They should all be ids + -- Same motivation for zapping as [Case binders 2] only this time + -- it's Note [Unboxed tuple case binders] new_env | exprIsCheap scrut' = env' | otherwise = extendCSEnv env' scrut' tup_value - tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr)) + tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr)) cseAlts env scrut' bndr bndr' alts = map cse_alt alts where (con_target, alt_env) = case scrut' of - Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1] + Var v' -> (v', extendSubst env bndr v') -- See Note [Case binders 1] -- map: bndr -> v' - _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2] + _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] -- map: scrut' -> bndr' arg_tys = tyConAppArgs (idType bndr) @@ -303,15 +303,19 @@ emptyCSEnv :: CSEnv emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr -lookupCSEnv (CS cs _ _) expr +lookupCSEnv (CS cs in_scope _) expr = case lookupUFM cs (hashExpr expr) of Nothing -> Nothing - Just pairs -> lookup_list pairs expr - -lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr -lookup_list [] _ = Nothing -lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e' - | otherwise = lookup_list es expr + Just pairs -> lookup_list pairs + where + -- In this lookup we use full expression equality + -- Reason: when expressions differ we generally find out quickly + -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y), + -- and this kind of thing happened in real programs + lookup_list :: [(CoreExpr,CoreExpr)] -> Maybe CoreExpr + lookup_list [] = Nothing + lookup_list ((e,e'):es) | eqExpr in_scope e expr = Just e' + | otherwise = lookup_list es addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv addCSEnvItem env expr expr' | exprIsBig expr = env @@ -328,7 +332,7 @@ extendCSEnv (CS cs in_scope sub) expr expr' = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result where result = new ++ old - short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result) + short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result) long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result | otherwise = empty @@ -348,7 +352,7 @@ addBinder (CS cs in_scope sub) v (CS emptyUFM in_scope sub, v) -- This last case is the unusual situation where we have shadowing of -- a type variable; we have to discard the CSE mapping - -- See "IMPORTANT NOTE" at the top + -- See Note [Shadowing] where v' = uniqAway in_scope v