From 26caf834b8eba8eea0f68ab96d47997159a5ed7e Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 28 Jun 1999 16:27:30 +0000
Subject: [PATCH] [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
---
ghc/compiler/basicTypes/Const.lhs | 9 +++++--
ghc/compiler/coreSyn/CoreUtils.lhs | 38 ++++++++++++++++++++----------
ghc/compiler/simplCore/CSE.lhs | 19 ++++++++-------
3 files changed, 42 insertions(+), 24 deletions(-)
diff --git a/ghc/compiler/basicTypes/Const.lhs b/ghc/compiler/basicTypes/Const.lhs
index 2c2fbb4ee45f..dd0bda49589a 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 ea91fe4a31f4..bc6b37611be5 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 188cb48fec3f..ee12ab927ce9 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}
--
GitLab