X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCSE.lhs;h=8c386614c6e6f05a6da186a92a48e96b0040376d;hp=2e8489a29526912b87e7675482951ad265a26d11;hb=72462499b891d5779c19f3bda03f96e24f9554ae;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 2e8489a..8c38661 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, idWorkerInfo ) -import IdInfo ( workerExists ) +import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap ) import DataCon ( isUnboxedTupleCon ) import Type ( tyConAppArgs ) import CoreSyn import VarEnv -import CoreLint ( showPass, endPass ) import Outputable -import Util ( mapAccumL, lengthExceeds ) +import StaticFlags ( opt_PprStyle_Debug ) +import BasicTypes ( isAlwaysActive ) +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,6 +109,65 @@ 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 [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 an InlineRule + + b) we do not do CSE on the RHS of a binding b=e + unless b's InlinePragma is AlwaysActive + +Here's why (examples from Roman Leshchinskiy). Consider + + yes :: Int + {-# NOINLINE yes #-} + yes = undefined + + no :: Int + {-# NOINLINE no #-} + no = undefined + + foo :: Int -> Int -> Int + {-# NOINLINE foo #-} + foo m n = n + + {-# RULES "foo/no" foo no = id #-} + + bar :: Int -> Int + bar = foo yes + +We do not expect the rule to fire. But if we do CSE, then we get +yes=no, and the rule does fire. Worse, whether we get yes=no or +no=yes depends on the order of the definitions. + +In general, CSE should probably never touch things with INLINE pragmas +as this could lead to surprising results. Consider + + {-# INLINE foo #-} + foo = + + {-# NOINLINE bar #-} + bar = -- Same rhs as foo + +If CSE produces + foo = bar +then foo will never be inlined (when it should be); but if it produces + bar = foo +bar will be inlined (when it should not be). Even if we remove INLINE foo, +we'd still like foo to be inlined if rhs is small. This won't happen +with foo = bar. + +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 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). + %************************************************************************ %* * @@ -115,17 +176,11 @@ That is why the CSEMap has pairs of expressions. %************************************************************************ \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 @@ -138,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)) @@ -145,20 +201,12 @@ do_one env (id, rhs) Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs')) where (env', id') = addBinder env id - rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs - - -- Hack alert: don't do CSE on wrapper RHSs. - -- Otherwise we find: - -- $wf = h - -- f = \x -> ...$wf... - -- ===> - -- f = \x -> ...h... - -- But the WorkerInfo for f still says $wf, which is now dead! - | otherwise = rhs - + 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 env expr = case lookupCSEnv env expr' of Just smaller_expr -> smaller_expr Nothing -> expr' @@ -166,41 +214,50 @@ 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 _ (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 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) @@ -240,6 +297,7 @@ 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 @@ -249,39 +307,46 @@ lookupCSEnv (CS cs _ _) expr Just pairs -> lookup_list pairs expr lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr -lookup_list [] expr = Nothing +lookup_list [] _ = Nothing lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e' | otherwise = lookup_list es expr +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:" <+> 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