X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FCSE.lhs;h=2e8489a29526912b87e7675482951ad265a26d11;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=ee12ab927ce9e8834d4210aad2dde6981c9e4612;hpb=26caf834b8eba8eea0f68ab96d47997159a5ed7e;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index ee12ab9..2e8489a 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -10,22 +10,23 @@ module CSE ( #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_cse, opt_D_verbose_core2core ) -import Id ( Id, idType ) -import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig ) -import Const ( isBoxedDataCon ) -import Type ( splitTyConApp_maybe ) +import DynFlags ( DynFlag(..), DynFlags ) +import Id ( Id, idType, idWorkerInfo ) +import IdInfo ( workerExists ) +import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap ) +import DataCon ( isUnboxedTupleCon ) +import Type ( tyConAppArgs ) import CoreSyn import VarEnv -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import Outputable -import Util ( mapAccumL ) +import Util ( mapAccumL, lengthExceeds ) import UniqFM \end{code} Simple common sub-expression - + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we see x1 = C a b x2 = C x1 b @@ -37,26 +38,74 @@ When we then see y1 = C a b y2 = C y1 b we replace the C a b with x1. But then we *dont* want to -add x1 -> y to the mapping. Rather, we want the reverse, y -> x1 +add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 so that a subsequent binding - z = C y b + y2 = C y1 b will get transformed to C x1 b, and then to x2. -So we carry an extra var->var mapping which we apply before looking up in the +So we carry an extra var->var substitution which we apply *before* looking up in the reverse mapping. -IMPORTANT NOTE -~~~~~~~~~~~~~~ -This pass relies on the no-shadowing invariant, so it must run -immediately after the simplifier. - +[Note: SHADOWING] +~~~~~~~~~~~~~~~~~ +We have to be careful about shadowing. For example, consider f = \x -> let y = x+x in h = \x -> x+x in ... -Here we must *not* do CSE on the x+x! +Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no +shadowing, but it doesn't any more (it proved too hard), so we clone as we go. +We can simply add clones to the substitution already described. + +However, we do NOT clone type variables. It's just too hard, because then we need +to run the substitution over types and IdInfo. No no no. Instead, we just throw + +(In fact, I think the simplifier does guarantee no-shadowing for type variables.) + + +[Note: case binders 1] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f = \x -> case x of wild { + (a:as) -> case a of wild1 { + (p,q) -> ...(wild1:as)... + +Here, (wild1:as) is morally the same as (a:as) and hence equal to wild. +But that's not quite obvious. In general we want to keep it as (wild1:as), +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 + +[Note: case binders 2] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + case (h x) of y -> ...(h x)... + +We'd like to replace (h x) in the alternative, by y. But because of +the preceding [Note: case binders 1], we only want to add the mapping + scrutinee -> case binder +to the reverse CSE mapping if the scrutinee is a non-trivial expression. +(If the scrutinee is a simple variable we want to add the mapping + case binder -> scrutinee +to the substitution + +[Note: unboxed tuple case binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case f x of t { (# a,b #) -> + case ... of + True -> f x + False -> 0 } + +We must not replace (f x) by t, because t is an unboxed-tuple binder. +Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is + f x --> (# a,b #) +That is why the CSEMap has pairs of expressions. %************************************************************************ @@ -66,15 +115,13 @@ Here we must *not* do CSE on the x+x! %************************************************************************ \begin{code} -cseProgram :: [CoreBind] -> IO [CoreBind] +cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind] -cseProgram binds +cseProgram dflags binds = do { - beginPass "Common sub-expression"; + showPass dflags "Common sub-expression"; let { binds' = cseBinds emptyCSEnv binds }; - endPass "Common sub-expression" - (opt_D_dump_cse || opt_D_verbose_core2core) - binds' + endPass dflags "Common sub-expression" Opt_D_dump_cse binds' } cseBinds :: CSEnv -> [CoreBind] -> [CoreBind] @@ -85,60 +132,96 @@ cseBinds env (b:bs) = (b':bs') bs' = cseBinds env1 bs cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e) - in (env', NonRec b e') +cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e) + in (env', NonRec b' e') cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs in (env', Rec pairs') -do_one env (id, rhs) = case lookupCSEnv env rhs' of - Just other_id -> (extendSubst env id other_id, (id, Var other_id)) - Nothing -> (addCSEnvItem env id rhs', (id, rhs')) - where - rhs' = cseExpr env rhs +do_one env (id, rhs) + = case lookupCSEnv env rhs' of + Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id)) + Just other_expr -> (env', (id', other_expr)) + 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 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr tryForCSE env (Type t) = Type t tryForCSE env expr = case lookupCSEnv env expr' of - Just id -> Var id - Nothing -> expr' + Just smaller_expr -> smaller_expr + Nothing -> expr' where expr' = cseExpr env expr - cseExpr :: CSEnv -> CoreExpr -> CoreExpr +cseExpr env (Type t) = Type t +cseExpr env (Lit lit) = Lit lit cseExpr env (Var v) = Var (lookupSubst env v) -cseExpr env (App f (Type t)) = App (cseExpr env f) (Type t) cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) -cseExpr env expr@(Con con args) = case lookupCSEnv env expr of - Just id -> Var id - Nothing -> Con con [tryForCSE env arg | arg <- args] cseExpr env (Note n e) = Note n (cseExpr env e) -cseExpr env (Lam b e) = Lam b (cseExpr env e) -cseExpr env (Let bind e) = let (env1, bind') = cseBind env bind - in Let bind' (cseExpr env1 e) -cseExpr env (Type t) = Type t -cseExpr env (Case scrut bndr alts) = Case (tryForCSE env scrut) bndr (cseAlts env bndr alts) - +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) + where + scrut' = tryForCSE env scrut + (env', bndr') = addBinder env bndr + + +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)] + where + (env', args') = addBinders env args + new_env | exprIsCheap scrut' = env' + | otherwise = extendCSEnv env' scrut' tup_value + tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr)) -cseAlts env bndr alts +cseAlts env scrut' bndr bndr' alts = map cse_alt alts where - arg_tys = case splitTyConApp_maybe (idType bndr) of - Just (_, arg_tys) -> map Type arg_tys - other -> pprPanic "cseAlts" (ppr bndr) + (con_target, alt_env) + = case scrut' of + Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1] + -- map: bndr -> v' - cse_alt (con, args, rhs) - | null args || not (isBoxedDataCon con) = (con, args, cseExpr env rhs) + other -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2] + -- map: scrut' -> bndr' + + arg_tys = tyConAppArgs (idType bndr) + + cse_alt (DataAlt con, args, rhs) + | not (null args) -- Don't try CSE if there are no args; it just increases the number -- of live vars. E.g. -- case x of { True -> ....True.... } -- Don't replace True by x! -- Hence the 'null args', which also deal with literals and DEFAULT - -- And we can't CSE on unboxed tuples - | otherwise - = (con, args, cseExpr (extendCSEnv env bndr (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs) + = (DataAlt con, args', tryForCSE new_env rhs) + where + (env', args') = addBinders alt_env args + new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) + (Var con_target) + + cse_alt (con, args, rhs) + = (con, args', tryForCSE env' rhs) + where + (env', args') = addBinders alt_env args \end{code} @@ -149,37 +232,59 @@ cseAlts env bndr alts %************************************************************************ \begin{code} -data CSEnv = CS (UniqFM [(Id, CoreExpr)]) -- The expr in the range has already been CSE'd - (IdEnv Id) -- Simple substitution +data CSEnv = CS CSEMap InScopeSet (IdEnv Id) + -- Simple substitution + +type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping + -- It maps the hash-code of an expression e to list of (e,e') pairs + -- This means that it's good to replace e by e' + -- INVARIANT: The expr in the range has already been CSE'd -emptyCSEnv = CS emptyUFM emptyVarEnv +emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv -lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id -lookupCSEnv (CS cs _) expr +lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr +lookupCSEnv (CS cs _ _) expr = case lookupUFM cs (hashExpr expr) of Nothing -> Nothing Just pairs -> lookup_list pairs expr -lookup_list :: [(Id,CoreExpr)] -> CoreExpr -> Maybe Id +lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr lookup_list [] expr = Nothing -lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x - | otherwise = lookup_list es expr +lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e' + | otherwise = lookup_list es expr -addCSEnvItem env id expr | exprIsBig expr = env - | otherwise = extendCSEnv env id expr +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 (CS cs sub) id expr - = CS (addToUFM_C combine cs hash [(id, expr)]) sub +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( length result > 4, text "extendCSEnv: long list:" <+> ppr result ) + combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result ) result where result = new ++ old -lookupSubst (CS _ sub) x = case lookupVarEnv sub x of - Just y -> y - Nothing -> x +lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of + Just y -> y + Nothing -> x + +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 + | 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 ) + (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 + where + v' = uniqAway in_scope v -extendSubst (CS cs sub) x y = CS cs (extendVarEnv sub x y) +addBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) +addBinders env vs = mapAccumL addBinder env vs \end{code}