---------------------------------------
Fix a long-standing CSE bug with unboxed tuples
---------------------------------------
Merge to stable
Consider
case f x of
(# a,b #) -> if a>0
then f x -- CSE opportunity
else (# b,a #)
GHC 6.2's CSE pass wrongly optimised this to:
case f x of t
(# a,b #) -> if a>0 then
t -- WRONG
else (# b,a #)
(Wrong because we aren't allowed to mention a case binder for
an unboxed-tuple case.)
This commit fixes the problem.
import CmdLineOpts ( DynFlag(..), DynFlags )
import Id ( Id, idType, idWorkerInfo )
import IdInfo ( workerExists )
import CmdLineOpts ( DynFlag(..), DynFlags )
import Id ( Id, idType, idWorkerInfo )
import IdInfo ( workerExists )
-import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
+import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
-IMPORTANT NOTE
-~~~~~~~~~~~~~~
+[Note: SHADOWING]
+~~~~~~~~~~~~~~~~~
We have to be careful about shadowing.
For example, consider
f = \x -> let y = x+x in
We have to be careful about shadowing.
For example, consider
f = \x -> let y = x+x in
However, we do NOT clone type variables. It's just too hard, because then we need
to run the substitution over types and IdInfo. No no no. Instead, we just throw
However, we do NOT clone type variables. It's just too hard, because then we need
to run the substitution over types and IdInfo. No no no. Instead, we just throw
-away the entire reverse mapping if this unusual situation ever shows up.
(In fact, I think the simplifier does guarantee no-shadowing for type variables.)
(In fact, I think the simplifier does guarantee no-shadowing for type variables.)
-Another important wrinkle
-~~~~~~~~~~~~~~~~~~~~~~~~~
+[Note: case binders 1]
+~~~~~~~~~~~~~~~~~~~~~~
Consider
f = \x -> case x of wild {
Consider
f = \x -> case x of wild {
Notice this is exactly backwards to what the simplifier does, which is
to try to replaces uses of a with uses of wild1
Notice this is exactly backwards to what the simplifier does, which is
to try to replaces uses of a with uses of wild1
-Yet another wrinkle
-~~~~~~~~~~~~~~~~~~~
+[Note: case binders 2]
+~~~~~~~~~~~~~~~~~~~~~~
Consider
case (h x) of y -> ...(h x)...
We'd like to replace (h x) in the alternative, by y. But because of
Consider
case (h x) of y -> ...(h x)...
We'd like to replace (h x) in the alternative, by y. But because of
-the preceding "Another important wrinkle", we only want to add the mapping
+the preceding [Note: case binders 1], we only want to add the mapping
scrutinee -> case binder
to the reverse CSE mapping if the scrutinee is a non-trivial expression.
(If the scrutinee is a simple variable we want to add the mapping
case binder -> scrutinee
to the substitution
scrutinee -> case binder
to the reverse CSE mapping if the scrutinee is a non-trivial expression.
(If the scrutinee is a simple variable we want to add the mapping
case binder -> scrutinee
to the substitution
+[Note: unboxed tuple case binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ case f x of t { (# a,b #) ->
+ case ... of
+ True -> f x
+ False -> 0 }
+
+We must not replace (f x) by t, because t is an unboxed-tuple binder.
+Instead, we shoudl replace (f x) by (# a,b #). That is, the "reverse mapping" is
+ f x --> (# a,b #)
+That is why the CSEMap has pairs of expressions.
+
%************************************************************************
%* *
%************************************************************************
%* *
do_one env (id, rhs)
= case lookupCSEnv env rhs' of
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'))
+ Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id))
+ Just other_expr -> (env', (id', other_expr))
+ Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
where
(env', id') = addBinder env id
rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs
where
(env', id') = addBinder env id
rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
tryForCSE env (Type t) = Type t
tryForCSE env expr = case lookupCSEnv env expr' of
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
tryForCSE env (Type t) = Type t
tryForCSE env expr = case lookupCSEnv env expr' of
- Just id -> Var id
- Nothing -> expr'
+ Just smaller_expr -> smaller_expr
+ Nothing -> expr'
where
expr' = cseExpr env expr
where
expr' = cseExpr env expr
(env', bndr') = addBinder env bndr
(env', bndr') = addBinder env bndr
+cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
+ | isUnboxedTupleCon con
+ -- Unboxed tuples are special because the case binder isn't
+ -- a real values. See [Note: unboxed tuple case binders]
+ = [(DataAlt con, args', tryForCSE new_env rhs)]
+ where
+ (env', args') = addBinders env args
+ new_env | exprIsCheap scrut' = env'
+ | otherwise = extendCSEnv env' scrut' tup_value
+ tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
+
cseAlts env scrut' bndr bndr' alts
= map cse_alt alts
where
(con_target, alt_env)
= case scrut' of
cseAlts env scrut' bndr bndr' alts
= map cse_alt alts
where
(con_target, alt_env)
= case scrut' of
- Var v' -> (v', extendSubst env bndr v') -- See "another important wrinkle"
+ Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1]
- other -> (bndr', extendCSEnv env bndr' scrut') -- See "yet another wrinkle"
- -- map: scrut' -> bndr'
+ other -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2]
+ -- map: scrut' -> bndr'
arg_tys = tyConAppArgs (idType bndr)
cse_alt (DataAlt con, args, rhs)
arg_tys = tyConAppArgs (idType bndr)
cse_alt (DataAlt con, args, rhs)
- | not (null args || isUnboxedTupleCon con)
-- 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
-- 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
= (DataAlt con, args', tryForCSE new_env rhs)
where
(env', args') = addBinders alt_env args
= (DataAlt con, args', tryForCSE new_env rhs)
where
(env', args') = addBinders alt_env args
- new_env = extendCSEnv env' con_target (mkAltExpr (DataAlt con) args' arg_tys)
+ new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
+ (Var con_target)
cse_alt (con, args, rhs)
= (con, args', tryForCSE env' rhs)
cse_alt (con, args, rhs)
= (con, args', tryForCSE env' rhs)
data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
-- Simple substitution
data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
-- Simple substitution
-type CSEMap = UniqFM [(Id, CoreExpr)] -- This is the reverse mapping
- -- It maps the hash-code of an expression to list of (x,e) pairs
- -- This means that it's good to replace e by x
+type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping
+ -- It maps the hash-code of an expression e to list of (e,e') pairs
+ -- This means that it's good to replace e by e'
-- INVARIANT: The expr in the range has already been CSE'd
emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
-- INVARIANT: The expr in the range has already been CSE'd
emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
-lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
+lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
lookupCSEnv (CS cs _ _) expr
= case lookupUFM cs (hashExpr expr) of
Nothing -> Nothing
Just pairs -> lookup_list pairs expr
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 :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
lookup_list [] expr = Nothing
lookup_list [] expr = Nothing
-lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x
- | otherwise = lookup_list es expr
+lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
+ | otherwise = lookup_list es expr
-addCSEnvItem env id expr | exprIsBig expr = env
- | otherwise = extendCSEnv env id expr
+addCSEnvItem env expr expr' | exprIsBig expr = env
+ | otherwise = extendCSEnv env expr expr'
-- We don't try to CSE big expressions, because they are expensive to compare
-- (and are unlikely to be the same anyway)
-- We don't try to CSE big expressions, because they are expensive to compare
-- (and are unlikely to be the same anyway)
-extendCSEnv (CS cs in_scope sub) id expr
- = CS (addToUFM_C combine cs hash [(id, expr)]) in_scope sub
+extendCSEnv (CS cs in_scope sub) expr expr'
+ = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
where
hash = hashExpr expr
combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
where
hash = hashExpr expr
combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )