[commit: ghc] master: Fix egregious omission in CSE (Trac #5996) (0001d16)
git at git.haskell.org
git at git.haskell.org
Tue Nov 12 15:07:31 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/0001d161f7f6a6f7392eb2a3229f6204c3423450/ghc
>---------------------------------------------------------------
commit 0001d161f7f6a6f7392eb2a3229f6204c3423450
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Nov 12 12:59:15 2013 +0000
Fix egregious omission in CSE (Trac #5996)
This patch fixes a bad omission in CSE, thanks to 'michaelt' for spotting
it, and correctly identifying the fix (in cseRhs). The trouble was with
x1 = C a b
x2 = C x1 b
y1 = C a b
y2 = C y1 b
we were not commoning up y2=x2, because we failed to substitute y1:=x1,
so y2's RHS looked different to x2's
I also refactoring, so taht the cs_map in a CSEnv map is
cs_map :: CoreMap (OutExpr, Id)
instead of
cs_map :: CoreMap (OutExpr, OutExpr)
Much nicer!
This doesn't make much difference to allocation, but it gives a surprisingly
big benefit to binary size.
--------------------------------------------------------------------------------
Program Size Allocs Runtime Elapsed TotalMem
--------------------------------------------------------------------------------
ansi -1.7% -0.8% 0.00 0.00 +0.0%
bspt -1.6% -1.5% 0.01 0.01 +0.0%
cacheprof -1.8% -0.2% +1.6% +1.9% +2.7%
fft -1.4% -1.3% 0.06 0.06 +11.1%
ida -1.4% -1.0% 0.12 0.12 +0.0%
rfib -1.4% -0.1% 0.03 0.03 +0.0%
scs -1.6% -0.1% +1.5% +1.5% +0.0%
spectral-norm -1.3% -0.1% -0.2% -0.2% +0.0%
tak -1.4% -0.1% 0.02 0.02 +0.0%
veritas -1.4% -0.1% 0.00 0.00 +0.0%
--------------------------------------------------------------------------------
Min -2.5% -1.5% -11.8% -11.8% -8.0%
Max -1.0% +0.0% +2.7% +2.5% +11.1%
Geometric Mean -1.3% -0.1% -2.6% -2.6% +0.0%
>---------------------------------------------------------------
0001d161f7f6a6f7392eb2a3229f6204c3423450
compiler/simplCore/CSE.lhs | 42 +++++++++++++++++++++---------------------
1 file changed, 21 insertions(+), 21 deletions(-)
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 1d9ef45..691f883 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -186,8 +186,16 @@ cseBind env (Rec pairs)
cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)
cseRhs env (id',rhs)
= case lookupCSEnv env rhs' of
- Just other_expr -> (env, other_expr)
- Nothing -> (addCSEnvItem env rhs' (Var id'), rhs')
+ Nothing -> (extendCSEnv env rhs' id', rhs')
+ Just id -> (extendCSSubst env id' id, Var id)
+ -- In the Just case, we have
+ -- x = rhs
+ -- ...
+ -- x' = rhs
+ -- We are replacing the second binding with x'=x
+ -- and so must record that in the substitution so
+ -- that subsequent uses of x' are replaced with x,
+ -- See Trac #5996
where
rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs
| otherwise = rhs
@@ -196,7 +204,7 @@ cseRhs env (id',rhs)
tryForCSE :: CSEnv -> InExpr -> OutExpr
tryForCSE env expr
| exprIsTrivial expr' = expr' -- No point
- | Just smaller <- lookupCSEnv env expr' = smaller
+ | Just smaller <- lookupCSEnv env expr' = Var smaller
| otherwise = expr'
where
expr' = cseExpr env expr
@@ -231,11 +239,11 @@ cseAlts env scrut' bndr bndr' alts
where
(con_target, alt_env)
= case scrut' of
- Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1]
- -- map: bndr -> v'
+ Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1]
+ -- map: bndr -> v'
- _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2]
- -- map: scrut' -> bndr'
+ _ -> (bndr', extendCSEnv env scrut' bndr') -- See Note [Case binders 2]
+ -- map: scrut' -> bndr'
arg_tys = tyConAppArgs (idType bndr)
@@ -250,7 +258,7 @@ cseAlts env scrut' bndr bndr' alts
where
(env', args') = addBinders alt_env args
new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
- (Var con_target)
+ con_target
cse_alt (con, args, rhs)
= (con, args', tryForCSE env' rhs)
@@ -274,29 +282,21 @@ type OutExpr = CoreExpr -- Post-cloning
type OutBndr = CoreBndr
type OutAlt = CoreAlt
-data CSEnv = CS { cs_map :: CoreMap (OutExpr, OutExpr) -- Key, value
+data CSEnv = CS { cs_map :: CoreMap (OutExpr, Id) -- Key, value
, cs_subst :: Subst }
emptyCSEnv :: CSEnv
emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }
-lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
+lookupCSEnv :: CSEnv -> OutExpr -> Maybe Id
lookupCSEnv (CS { cs_map = csmap }) expr
= case lookupCoreMap csmap expr of
Just (_,e) -> Just e
Nothing -> Nothing
-addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv
-addCSEnvItem = extendCSEnv
- -- We used to avoid trying to CSE big expressions, on the grounds
- -- that they are expensive to compare. But now we have CoreMaps
- -- we can happily insert them and laziness will mean that the
- -- insertions only get fully done if we look up in that part
- -- of the trie. No need for a size test.
-
-extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
-extendCSEnv cse expr expr'
- = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,expr') }
+extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv
+extendCSEnv cse expr id
+ = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,id) }
csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst
More information about the ghc-commits
mailing list