[project @ 1999-06-28 16:27:27 by simonpj]

Improve common sub-expression stuff
	- better hash function
	- add Const.isBoxedDataCon, and use it in CSE
	- don't CSE for nullary constructors

3 files changed, 42 insertions, 24 deletions

diff --git a/ghc/compiler/basicTypes/Const.lhs b/ghc/compiler/basicTypes/Const.lhs
index 2c2fbb4ee4..dd0bda4958 100644
--- a/ghc/compiler/basicTypes/Const.lhs
+++ b/ghc/compiler/basicTypes/Const.lhs
@@ -7,7 +7,7 @@
 module Const (
 	Con(..),
 	conType, conPrimRep,
-	conOkForApp, conOkForAlt, isWHNFCon, isDataCon,
+	conOkForApp, conOkForAlt, isWHNFCon, isDataCon, isBoxedDataCon,
 	conIsTrivial, conIsCheap, conIsDupable, conStrictness, 
 	conOkForSpeculation, hashCon,
 
@@ -31,7 +31,9 @@ import Name		( hashName )
 import PrimOp		( PrimOp, primOpType, primOpIsDupable, primOpTag,
 			  primOpIsCheap, primOpStrictness, primOpOkForSpeculation )
 import PrimRep		( PrimRep(..) )
-import DataCon		( DataCon, dataConName, dataConType, dataConTyCon, isNullaryDataCon, dataConRepStrictness )
+import DataCon		( DataCon, dataConName, dataConType, dataConTyCon, 
+			  isNullaryDataCon, dataConRepStrictness, isUnboxedTupleCon
+			)
 import TyCon		( isNewTyCon )
 import Type		( Type, typePrimRep )
 import PprType		( pprParendType )
@@ -113,6 +115,9 @@ isWHNFCon (PrimOp _)   = False
 isDataCon (DataCon dc) = True
 isDataCon other	       = False
 
+isBoxedDataCon (DataCon dc) = not (isUnboxedTupleCon dc)
+isBoxedDataCon other	    = False
+
 -- conIsTrivial is true for constants we are unconditionally happy to duplicate
 -- cf CoreUtils.exprIsTrivial
 conIsTrivial (Literal lit) = not (isNoRepLit lit)
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index ea91fe4a31..bc6b37611b 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -18,6 +18,8 @@ module CoreUtils (
 
 import {-# SOURCE #-} CoreUnfold	( isEvaldUnfolding )
 
+import GlaExts		-- For `xori` 
+
 import CoreSyn
 import PprCore		( pprCoreExpr )
 import Var		( IdOrTyVar, isId, isTyVar )
@@ -400,19 +402,29 @@ eqExpr e1 e2
 
 \begin{code}
 hashExpr :: CoreExpr -> Int
-hashExpr (Note _ e)   		 = hashExpr e
-hashExpr (Let (NonRec b r) e)    = hashId b
-hashExpr (Let (Rec ((b,r):_)) e) = hashId b
-hashExpr (Case _ b _)		 = hashId b
-hashExpr (App f e)   		 = hashExpr f
-hashExpr (Var v)     		 = hashId v
-hashExpr (Con con args)   	 = hashArgs args (hashCon con)
-hashExpr (Lam b _)	         = hashId b
-hashExpr (Type t)	         = trace "hashExpr: type" 0		-- Shouldn't happen
-
-hashArgs []		 con = con
-hashArgs (Type t : args) con = hashArgs args con
-hashArgs (arg    : args) con = hashExpr arg
+hashExpr e = abs (hash_expr e)
+	-- Negative numbers kill UniqFM
+
+hash_expr (Note _ e)   		  = hash_expr e
+hash_expr (Let (NonRec b r) e)    = hashId b
+hash_expr (Let (Rec ((b,r):_)) e) = hashId b
+hash_expr (Case _ b _)		  = hashId b
+hash_expr (App f e)   		  = hash_expr f + fast_hash_expr e
+hash_expr (Var v)     		  = hashId v
+hash_expr (Con con args)   	  = foldr ((+) . fast_hash_expr) (hashCon con) args
+hash_expr (Lam b _)	          = hashId b
+hash_expr (Type t)	          = trace "hash_expr: type" 0		-- Shouldn't happen
+
+fast_hash_expr (Var v)     	= hashId v
+fast_hash_expr (Con con args) 	= fast_hash_args args con
+fast_hash_expr (App f (Type _)) = fast_hash_expr f
+fast_hash_expr (App f a)        = fast_hash_expr a
+fast_hash_expr (Lam b _)        = hashId b
+fast_hash_expr other	        = 0
+
+fast_hash_args []	       con = hashCon con
+fast_hash_args (Type t : args) con = fast_hash_args args con
+fast_hash_args (arg    : args) con = fast_hash_expr arg
 
 hashId :: Id -> Int
 hashId id = hashName (idName id)
diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs
index 188cb48fec..ee12ab927c 100644
--- a/ghc/compiler/simplCore/CSE.lhs
+++ b/ghc/compiler/simplCore/CSE.lhs
@@ -13,8 +13,7 @@ module CSE (
 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 Const		( isBoxedDataCon )
 import Type		( splitTyConApp_maybe )
 import CoreSyn
 import VarEnv	
@@ -131,13 +130,15 @@ cseAlts env bndr alts
 		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
+	| null args || not (isBoxedDataCon con) = (con, args, cseExpr env rhs)
+		-- Don't try CSE if there are no args; it just increases the number
+		-- of live vars.  E.g.
+		--	case x of { True -> ....True.... }
+		-- Don't replace True by x!  
+		-- Hence the 'null args', which also deal with literals and DEFAULT
+		-- And we can't CSE on unboxed tuples
+	| otherwise
+	= (con, args, cseExpr (extendCSEnv env bndr (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs)
 \end{code}