import VarEnv
import CoreLint ( showPass, endPass )
import Outputable
+import StaticFlags ( opt_PprStyle_Debug )
import BasicTypes ( isAlwaysActive )
-import Util ( mapAccumL, lengthExceeds )
+import Util ( lengthExceeds )
import UniqFM
+import FastString
+
+import Data.List
\end{code}
f x --> (# a,b #)
That is why the CSEMap has pairs of expressions.
-Note [INLINE and NOINLINE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [CSE for INLINE and NOINLINE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are careful to do no CSE inside functions that the user has marked as
INLINE or NOINLINE. In terms of Core, that means
we'd still like foo to be inlined if rhs is small. This won't happen
with foo = bar.
-Not CSE-ing inside INLLINE also solves an annoying bug in CSE. Consider
+Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
a worker/wrapper, in which the worker has turned into a single variable:
$wf = h
f = \x -> ...$wf...
-Now CSE may transoform to
+Now CSE may transform to
f = \x -> ...h...
But the WorkerInfo for f still says $wf, which is now dead! This won't
happen now that we don't look inside INLINEs (which wrappers are).
}
cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
-cseBinds env [] = []
+cseBinds _ [] = []
cseBinds env (b:bs) = (b':bs')
where
(env1, b') = cseBind env b
in (env', Rec pairs')
+do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr))
do_one env (id, rhs)
= case lookupCSEnv env rhs' of
Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id))
(env', id') = addBinder env id
rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
| otherwise = rhs
- -- See Note [INLINE and NOINLINE]
+ -- See Note [CSE for INLINE and NOINLINE]
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
-tryForCSE env (Type t) = Type t
+tryForCSE _ (Type t) = Type t
tryForCSE env expr = case lookupCSEnv env expr' of
Just smaller_expr -> smaller_expr
Nothing -> expr'
expr' = cseExpr env expr
cseExpr :: CSEnv -> CoreExpr -> CoreExpr
-cseExpr env (Type t) = Type t
-cseExpr env (Lit lit) = Lit lit
+cseExpr _ (Type t) = Type t
+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 evn (Note InlineMe e) = Note InlineMe e -- See Note [INLINE and NOINLINE]
+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
in Lam b' (cseExpr env' e)
cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
(env', bndr') = addBinder env bndr
-cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
+cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
+
+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]
Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1]
-- map: bndr -> v'
- other -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2]
+ _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2]
-- map: scrut' -> bndr'
arg_tys = tyConAppArgs (idType bndr)
-- This means that it's good to replace e by e'
-- INVARIANT: The expr in the range has already been CSE'd
+emptyCSEnv :: CSEnv
emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
Just pairs -> lookup_list pairs expr
lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
-lookup_list [] expr = Nothing
+lookup_list [] _ = Nothing
lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
| otherwise = lookup_list es expr
+addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
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)
+extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
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 )
- result
- where
- result = new ++ old
+ hash = hashExpr expr
+ combine old new
+ = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
+ where
+ result = new ++ old
+ short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result)
+ long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
+ | otherwise = empty
+lookupSubst :: CSEnv -> Id -> Id
lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
Just y -> y
Nothing -> x
+extendSubst :: CSEnv -> Id -> Id -> CSEnv
extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
addBinder :: CSEnv -> Id -> (CSEnv, Id)
-addBinder env@(CS cs in_scope sub) v
+addBinder (CS cs in_scope sub) v
| not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
| isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
- | not (isId v) = WARN( True, ppr 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
projects / ghc-hetmet.git / blobdiff