X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCSE.lhs;h=38c1f58ee56d7ae67034dadf9c2d395debe2e315;hp=e7dd2175235cf3e5adeea63940bd039d4af7cba2;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hpb=1ee8a6f6cf3c06e3651438720333612a70348091 diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index e7dd217..38c1f58 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -19,9 +19,13 @@ 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} @@ -107,8 +111,8 @@ 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 @@ -161,7 +165,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). @@ -184,7 +188,7 @@ cseProgram dflags binds } cseBinds :: CSEnv -> [CoreBind] -> [CoreBind] -cseBinds env [] = [] +cseBinds _ [] = [] cseBinds env (b:bs) = (b':bs') where (env1, b') = cseBind env b @@ -197,6 +201,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)) @@ -206,10 +211,10 @@ do_one env (id, rhs) (env', id') = addBinder env id rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs | otherwise = rhs - -- See Note [INLINE and NOINLINE] + -- 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' @@ -217,11 +222,11 @@ 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 evn (Note InlineMe e) = Note InlineMe e -- See Note [INLINE and NOINLINE] +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 @@ -234,7 +239,9 @@ cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut (env', bndr') = addBinder env bndr -cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)] +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] @@ -253,7 +260,7 @@ cseAlts env scrut' bndr bndr' alts Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 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 binder 2] -- map: scrut' -> bndr' arg_tys = tyConAppArgs (idType bndr) @@ -293,6 +300,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 @@ -302,35 +310,42 @@ 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