X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FCSE.lhs;h=93b0b8dd6044245808996d66d7bed9c7646b1a69;hb=ac4a2563ee5b8d6bb9d0a366fe0ff3ed3fde4bb2;hp=de5763b9fdb2a6716e9cada4c80e3eed94cbd8ef;hpb=bb394e57361d9910b05f1145cbc894d33759d2a6;p=ghc-hetmet.git diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index de5763b..93b0b8d 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -19,9 +19,12 @@ 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 Data.List \end{code} @@ -107,8 +110,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 @@ -157,11 +160,11 @@ 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 INLLINE also solves an annoying bug in CSE. Consider +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 +187,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 +200,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 +210,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 +221,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 +238,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 +259,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 +299,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 +309,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