[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

diff --git a/ghc/compiler/basicTypes/Const.lhs b/ghc/compiler/basicTypes/Const.lhs
index 2c2fbb4..dd0bda4 100644 (file)
--- 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 ea91fe4..bc6b376 100644 (file)
--- 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 188cb48..ee12ab9 100644 (file)
--- 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}