X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FCSE.lhs;fp=ghc%2Fcompiler%2FsimplCore%2FCSE.lhs;h=188cb48fec3f46726903416a92522d983fcd2c8d;hb=2059de7c3ccd9464b3fd339ff67b2f52f0afab0d;hp=0000000000000000000000000000000000000000;hpb=c34d93da2ef7e3e0139072a3014ddf081419612e;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs
new file mode 100644
index 0000000..188cb48
--- /dev/null
+++ b/ghc/compiler/simplCore/CSE.lhs
@@ -0,0 +1,184 @@
+%
+% (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}