Commit 2059de7c by simonpj

### [project @ 1999-06-22 16:30:53 by simonpj]

Add common sub-expression
parent c34d93da
 % % (c) The AQUA Project, Glasgow University, 1993-1998 % \section{Common subexpression} \begin{code} module CSE ( cseProgram ) where #include "HsVersions.h" import CmdLineOpts ( opt_D_dump_cse, opt_D_verbose_core2core ) import Id ( Id, idType ) import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig ) import Const ( Con(..) ) import DataCon ( isUnboxedTupleCon ) import Type ( splitTyConApp_maybe ) import CoreSyn import VarEnv import CoreLint ( beginPass, endPass ) import Outputable import Util ( mapAccumL ) import UniqFM \end{code} Simple common sub-expression When we see x1 = C a b x2 = C x1 b we build up a reverse mapping: C a b -> x1 C x1 b -> x2 and apply that to the rest of the program. 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 so that a subsequent binding z = C y 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 reverse mapping. IMPORTANT NOTE ~~~~~~~~~~~~~~ This pass relies on the no-shadowing invariant, so it must run immediately after the simplifier. 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! %************************************************************************ %* * \section{Common subexpression} %* * %************************************************************************ \begin{code} cseProgram :: [CoreBind] -> IO [CoreBind] cseProgram binds = do { beginPass "Common sub-expression"; let { binds' = cseBinds emptyCSEnv binds }; endPass "Common sub-expression" (opt_D_dump_cse || opt_D_verbose_core2core) binds' } cseBinds :: CSEnv -> [CoreBind] -> [CoreBind] cseBinds env [] = [] cseBinds env (b:bs) = (b':bs') where (env1, b') = cseBind env b 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 (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 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr tryForCSE env (Type t) = Type t tryForCSE env expr = case lookupCSEnv env expr' of Just id -> Var id Nothing -> expr' where expr' = cseExpr env expr cseExpr :: CSEnv -> CoreExpr -> CoreExpr 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) cseAlts env 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) cse_alt (con, args, rhs) | ok_for_cse con = (con, args, cseExpr (extendCSEnv env bndr (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs) | otherwise = (con, args, cseExpr env rhs) ok_for_cse DEFAULT = False ok_for_cse (Literal l) = True ok_for_cse (DataCon dc) = not (isUnboxedTupleCon dc) -- Unboxed tuples aren't shared \end{code} %************************************************************************ %* * \section{The CSE envt} %* * %************************************************************************ \begin{code} data CSEnv = CS (UniqFM [(Id, CoreExpr)]) -- The expr in the range has already been CSE'd (IdEnv Id) -- Simple substitution emptyCSEnv = CS emptyUFM emptyVarEnv lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id 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 [] expr = Nothing lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x | otherwise = lookup_list es expr addCSEnvItem env id expr | exprIsBig expr = env | otherwise = extendCSEnv env id expr extendCSEnv (CS cs sub) id expr = CS (addToUFM_C combine cs hash [(id, expr)]) sub where hash = hashExpr expr combine old new = WARN( length result > 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 extendSubst (CS cs sub) x y = CS cs (extendVarEnv sub x y) \end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!