\section{Common subexpression}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module CSE (
cseProgram
) where
#include "HsVersions.h"
-import DynFlags ( DynFlag(..), DynFlags )
-import Id ( Id, idType, idInlinePragma )
-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
import VarEnv
-import CoreLint ( showPass, endPass )
import Outputable
import StaticFlags ( opt_PprStyle_Debug )
import BasicTypes ( isAlwaysActive )
import Util ( lengthExceeds )
import UniqFM
+import FastString
import Data.List
\end{code}
reverse mapping.
-[Note: SHADOWING]
-~~~~~~~~~~~~~~~~~
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
We have to be careful about shadowing.
For example, consider
f = \x -> let y = x+x in
(In fact, I think the simplifier does guarantee no-shadowing for type variables.)
-[Note: case binders 1]
+Note [Case binders 1]
~~~~~~~~~~~~~~~~~~~~~~
Consider
So we add the binding (wild1 -> a) to the extra var->var mapping.
Notice this is exactly backwards to what the simplifier does, which is
-to try to replaces uses of a with uses of wild1
+to try to replaces uses of 'a' with uses of 'wild1'
-[Note: case binders 2]
+Note [Case binders 2]
~~~~~~~~~~~~~~~~~~~~~~
Consider
case (h x) of y -> ...(h x)...
case binder -> scrutinee
to the substitution
-[Note: unboxed tuple case binders]
+Note [Unboxed tuple case binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
case f x of t { (# a,b #) ->
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
- 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
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).
%************************************************************************
\begin{code}
-cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
-cseProgram dflags binds
- = do {
- showPass dflags "Common sub-expression";
- let { binds' = cseBinds emptyCSEnv binds };
- endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
- }
+cseProgram :: [CoreBind] -> [CoreBind]
+cseProgram binds = cseBinds emptyCSEnv binds
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))
Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
where
(env', id') = addBinder env id
- rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
- | otherwise = rhs
- -- See Note [INLINE and NOINLINE]
+ rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs
+ | otherwise = rhs
+ -- See Note [CSE for INLINE and NOINLINE]
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
-tryForCSE env (Type t) = Type t
+tryForCSE _ (Type t) = Type t
+tryForCSE _ (Coercion c) = Coercion c
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 _ (Coercion co) = Coercion co
+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 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
in Let bind' (cseExpr env' e)
-cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
+cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts)
where
scrut' = tryForCSE env scrut
(env', bndr') = addBinder env bndr
+ bndr'' = zapIdOccInfo bndr'
+ -- The swizzling from Note [Case binders 2] may
+ -- cause a dead case binder to be alive, so we
+ -- play safe here and bring them all to life
+cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
-cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
+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)]
+ -- a real value. See Note [Unboxed tuple case binders]
+ = [(DataAlt con, args'', tryForCSE new_env rhs)]
where
(env', args') = addBinders env args
+ args'' = map zapIdOccInfo args' -- They should all be ids
+ -- Same motivation for zapping as [Case binders 2] only this time
+ -- it's Note [Unboxed tuple case binders]
new_env | exprIsCheap scrut' = env'
| otherwise = extendCSEnv env' scrut' tup_value
- tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
+ 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
- Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1]
+ Var v' -> (v', extendSubst env bndr v') -- See Note [Case binders 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 binders 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
-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 [] expr = 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
| 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
= 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)
+ 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')
| 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
projects / ghc-hetmet.git / blobdiff