X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCSE.lhs;h=5bec8f0c3d7705dbaf78cce28f9886013004477d;hp=f8259c77f836e6086519628256c7aaae085c591e;hb=7b5b3b0cab463e108a0132435a28ef19d17cb32b;hpb=4550f26cb03baa3b1cb5eb81f5980a8ce0b300b9 diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index f8259c7..5bec8f0 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -10,18 +10,20 @@ 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 ( mapAccumL, lengthExceeds ) +import Util ( lengthExceeds ) import UniqFM +import FastString + +import Data.List \end{code} @@ -47,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 @@ -65,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 @@ -79,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)... @@ -94,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 #) -> @@ -107,12 +109,12 @@ Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" i f x --> (# a,b #) That is why the CSEMap has pairs of expressions. -Note [INLINE and NOINLINE] -~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 @@ -161,7 +163,7 @@ Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider a worker/wrapper, in which the worker has turned into a single variable: $wf = h f = \x -> ...$wf... -Now CSE may transoform to +Now CSE may transform to f = \x -> ...h... But the WorkerInfo for f still says $wf, which is now dead! This won't happen now that we don't look inside INLINEs (which wrappers are). @@ -174,17 +176,11 @@ 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 env [] = [] +cseBinds _ [] = [] cseBinds env (b:bs) = (b':bs') where (env1, b') = cseBind env b @@ -197,6 +193,7 @@ cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs in (env', Rec pairs') +do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr)) do_one env (id, rhs) = case lookupCSEnv env rhs' of Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id)) @@ -204,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 - -- See Note [INLINE and NOINLINE] + rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs + | otherwise = rhs + -- See Note [CSE for INLINE and NOINLINE] tryForCSE :: CSEnv -> CoreExpr -> CoreExpr -tryForCSE env (Type t) = Type t +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' @@ -217,43 +215,51 @@ tryForCSE env expr = case lookupCSEnv env expr' of expr' = cseExpr env expr cseExpr :: CSEnv -> CoreExpr -> CoreExpr -cseExpr env (Type t) = Type t -cseExpr env (Lit lit) = Lit lit +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 evn (Note InlineMe e) = Note InlineMe e -- See Note [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)] +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' - other -> (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) @@ -293,50 +299,60 @@ type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping -- This means that it's good to replace e by e' -- INVARIANT: The expr in the range has already been CSE'd +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 [] expr = 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 | otherwise = extendCSEnv env expr expr' -- We don't try to CSE big expressions, because they are expensive to compare -- (and are unlikely to be the same anyway) +extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv extendCSEnv (CS cs in_scope sub) expr expr' = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub where - hash = hashExpr expr - combine old new = WARN( result `lengthExceeds` 4, ((text "extendCSEnv: long list (length" <+> int (length result) <> comma - <+> text "hash code" <+> text (show hash) <> char ')') - $$ nest 4 (ppr result)) ) - result - where - result = new ++ old + hash = hashExpr expr + combine old new + = 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) + long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result + | otherwise = empty +lookupSubst :: CSEnv -> Id -> Id lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of Just y -> y Nothing -> x +extendSubst :: CSEnv -> Id -> Id -> CSEnv extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y) addBinder :: CSEnv -> Id -> (CSEnv, Id) -addBinder env@(CS cs in_scope sub) v +addBinder (CS cs in_scope sub) v | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v) | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v') - | not (isId v) = WARN( True, ppr v ) + | otherwise = WARN( True, ppr 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