Commit 2059de7c authored by simonpj's avatar 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}
module CSE (
) 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
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.
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}
%* *
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)
cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
cseBinds env [] = []
cseBinds env (b:bs) = (b':bs')
(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'))
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'
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
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
%* *
\section{The CSE envt}
%* *
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
hash = hashExpr expr
combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment