#include "HsVersions.h"
-import Id ( Id, idType, idInlinePragma, zapIdOccInfo )
-import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
+import Id ( Id, idType, idInlineActivation, zapIdOccInfo )
+import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap )
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
import CoreSyn
reverse mapping.
-[Note: SHADOWING]
-~~~~~~~~~~~~~~~~~
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
We have to be careful about shadowing.
For example, consider
f = \x -> let y = x+x in
We are careful to do no CSE inside functions that the user has marked as
INLINE or NOINLINE. In terms of Core, that means
- a) we do not do CSE inside (Note InlineMe e)
+ a) we do not do CSE inside an InlineRule
b) we do not do CSE on the RHS of a binding b=e
unless b's InlinePragma is AlwaysActive
Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
where
(env', id') = addBinder env id
- rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
- | otherwise = rhs
+ rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs
+ | otherwise = rhs
-- See Note [CSE for INLINE and NOINLINE]
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
cseExpr _ (Lit lit) = Lit lit
cseExpr env (Var v) = Var (lookupSubst env v)
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
-cseExpr _ (Note InlineMe e) = Note InlineMe e -- See Note [CSE for INLINE and NOINLINE]
cseExpr env (Note n e) = Note n (cseExpr env e)
cseExpr env (Cast e co) = Cast (cseExpr env e) co
cseExpr env (Lam b e) = let (env', b') = addBinder env b
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]
+ -- a real value. See Note [Unboxed tuple case binders]
= [(DataAlt con, args'', tryForCSE new_env rhs)]
where
(env', args') = addBinders env args
emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
-lookupCSEnv (CS cs _ _) expr
+lookupCSEnv (CS cs in_scope _) expr
= case lookupUFM cs (hashExpr expr) of
Nothing -> Nothing
- Just pairs -> lookup_list pairs expr
-
-lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
-lookup_list [] _ = Nothing
-lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
- | otherwise = lookup_list es expr
+ Just pairs -> lookup_list pairs
+ where
+ -- In this lookup we use full expression equality
+ -- Reason: when expressions differ we generally find out quickly
+ -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y),
+ -- and this kind of thing happened in real programs
+ lookup_list :: [(CoreExpr,CoreExpr)] -> Maybe CoreExpr
+ lookup_list [] = Nothing
+ lookup_list ((e,e'):es) | eqExpr in_scope e expr = Just e'
+ | otherwise = lookup_list es
addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
addCSEnvItem env expr expr' | exprIsBig expr = env
addBinder :: CSEnv -> Id -> (CSEnv, Id)
addBinder (CS cs in_scope sub) v
| not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
- | isIdVar v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
+ | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
| otherwise = WARN( True, ppr v )
(CS emptyUFM in_scope sub, v)
-- This last case is the unusual situation where we have shadowing of
-- a type variable; we have to discard the CSE mapping
- -- See "IMPORTANT NOTE" at the top
+ -- See Note [Shadowing]
where
v' = uniqAway in_scope v