diff options
Diffstat (limited to 'compiler/simplCore/CSE.lhs')
| -rw-r--r-- | compiler/simplCore/CSE.lhs | 285 |
1 files changed, 103 insertions, 182 deletions
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 8bd15864c7..1d9ef45f7f 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -4,67 +4,42 @@ \section{Common subexpression} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CSE ( - cseProgram - ) where +module CSE (cseProgram) where #include "HsVersions.h" --- Note [Keep old CSEnv rep] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- Temporarily retain code for the old representation for CSEnv --- Keeping it only so that we can switch back if a bug shows up --- or we want to do some performance comparisions --- --- NB: when you remove this, also delete hashExpr from CoreUtils -#ifdef OLD_CSENV_REP -import CoreUtils ( exprIsBig, hashExpr, eqExpr ) -import StaticFlags ( opt_PprStyle_Debug ) -import Util ( lengthExceeds ) -import UniqFM -import FastString -#else -import TrieMap -#endif - import CoreSubst -import Var ( Var ) -import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) -import CoreUtils ( mkAltExpr +import Var ( Var ) +import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) +import CoreUtils ( mkAltExpr , exprIsTrivial) -import Type ( tyConAppArgs ) +import Type ( tyConAppArgs ) import CoreSyn import Outputable -import BasicTypes ( isAlwaysActive ) +import BasicTypes ( isAlwaysActive ) +import TrieMap import Data.List \end{code} - Simple common sub-expression - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Simple common sub-expression + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we see - x1 = C a b - x2 = C x1 b + x1 = C a b + x2 = C x1 b we build up a reverse mapping: C a b -> x1 - C x1 b -> x2 + C x1 b -> x2 and apply that to the rest of the program. When we then see - y1 = C a b - y2 = C y1 b + y1 = C a b + y2 = C y1 b we replace the C a b with x1. But then we *dont* want to add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 so that a subsequent binding - y2 = C y1 b -will get transformed to C x1 b, and then to x2. + y2 = C y1 b +will get transformed to C x1 b, and then to x2. So we carry an extra var->var substitution which we apply *before* looking up in the reverse mapping. @@ -74,9 +49,9 @@ Note [Shadowing] ~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider - f = \x -> let y = x+x in - h = \x -> x+x - in ... + f = \x -> let y = x+x in + h = \x -> x+x + in ... Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no shadowing, but it doesn't any more (it proved too hard), so we clone as we go. @@ -86,9 +61,9 @@ Note [Case binders 1] ~~~~~~~~~~~~~~~~~~~~~~ Consider - f = \x -> case x of wild { - (a:as) -> case a of wild1 { - (p,q) -> ...(wild1:as)... + f = \x -> case x of wild { + (a:as) -> case a of wild1 { + (p,q) -> ...(wild1:as)... Here, (wild1:as) is morally the same as (a:as) and hence equal to wild. But that's not quite obvious. In general we want to keep it as (wild1:as), @@ -101,44 +76,44 @@ to try to replaces uses of 'a' with uses of 'wild1' Note [Case binders 2] ~~~~~~~~~~~~~~~~~~~~~~ Consider - case (h x) of y -> ...(h x)... + case (h x) of y -> ...(h x)... We'd like to replace (h x) in the alternative, by y. But because of the preceding [Note: case binders 1], we only want to add the mapping - scrutinee -> case binder + 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 + case binder -> scrutinee to the substitution 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 +INLINE or NOINLINE. In terms of Core, that means - a) we do not do CSE inside an InlineRule + 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 + b) we do not do CSE on the RHS of a binding b=e + unless b's InlinePragma is AlwaysActive Here's why (examples from Roman Leshchinskiy). Consider - yes :: Int - {-# NOINLINE yes #-} - yes = undefined + yes :: Int + {-# NOINLINE yes #-} + yes = undefined - no :: Int - {-# NOINLINE no #-} - no = undefined + no :: Int + {-# NOINLINE no #-} + no = undefined - foo :: Int -> Int -> Int - {-# NOINLINE foo #-} - foo m n = n + foo :: Int -> Int -> Int + {-# NOINLINE foo #-} + foo m n = n - {-# RULES "foo/no" foo no = id #-} + {-# RULES "foo/no" foo no = id #-} - bar :: Int -> Int - bar = foo yes + bar :: Int -> Int + bar = foo yes We do not expect the rule to fire. But if we do CSE, then we get yes=no, and the rule does fire. Worse, whether we get yes=no or @@ -147,26 +122,26 @@ no=yes depends on the order of the definitions. In general, CSE should probably never touch things with INLINE pragmas as this could lead to surprising results. Consider - {-# INLINE foo #-} - foo = <rhs> + {-# INLINE foo #-} + foo = <rhs> - {-# NOINLINE bar #-} - bar = <rhs> -- Same rhs as foo + {-# NOINLINE bar #-} + bar = <rhs> -- Same rhs as foo If CSE produces - foo = bar + foo = bar then foo will never be inlined (when it should be); but if it produces - bar = foo + bar = foo bar will be inlined (when it should not be). Even if we remove INLINE foo, we'd still like foo to be inlined if rhs is small. This won't happen with foo = bar. 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... + $wf = h + f = \x -> ...$wf... Now CSE may transform to - f = \x -> ...h... + 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). @@ -178,9 +153,9 @@ Then we can CSE the inner (f x) to y. In fact 'case' is like a strict let-binding, and we can use cseRhs for dealing with the scrutinee. %************************************************************************ -%* * +%* * \section{Common subexpression} -%* * +%* * %************************************************************************ \begin{code} @@ -190,12 +165,12 @@ cseProgram binds = cseBinds emptyCSEnv binds cseBinds :: CSEnv -> [CoreBind] -> [CoreBind] cseBinds _ [] = [] cseBinds env (b:bs) = (b':bs') - where - (env1, b') = cseBind env b - bs' = cseBinds env1 bs + where + (env1, b') = cseBind env b + bs' = cseBinds env1 bs cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind env (NonRec b e) +cseBind env (NonRec b e) = (env2, NonRec b' e') where (env1, b') = addBinder env b @@ -211,16 +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') + Just other_expr -> (env, other_expr) + Nothing -> (addCSEnvItem env rhs' (Var id'), rhs') where rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs - | otherwise = rhs - -- See Note [CSE for INLINE and NOINLINE] + | otherwise = rhs + -- See Note [CSE for INLINE and NOINLINE] tryForCSE :: CSEnv -> InExpr -> OutExpr tryForCSE env expr - | exprIsTrivial expr' = expr' -- No point + | exprIsTrivial expr' = expr' -- No point | Just smaller <- lookupCSEnv env expr' = smaller | otherwise = expr' where @@ -230,24 +205,24 @@ cseExpr :: CSEnv -> InExpr -> OutExpr cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) cseExpr _ (Lit lit) = Lit lit -cseExpr env (Var v) = lookupSubst env v -cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) +cseExpr env (Var v) = lookupSubst env v +cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) cseExpr env (Tick t e) = Tick t (cseExpr env e) cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) 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 (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 alts' - where - alts' = cseAlts env2 scrut' bndr bndr'' alts - (env1, 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 - (env2, scrut') = cseRhs env1 (bndr'', scrut) - -- Note [CSE for case expressions] + where + alts' = cseAlts env2 scrut' bndr bndr'' alts + (env1, 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 + (env2, scrut') = cseRhs env1 (bndr'', scrut) + -- Note [CSE for case expressions] cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt] @@ -255,103 +230,50 @@ cseAlts env scrut' bndr bndr' alts = map cse_alt alts where (con_target, alt_env) - = case scrut' of - Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1] - -- map: bndr -> v' + = case scrut' of + 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' (Var bndr')) -- See Note [Case binders 2] + -- map: scrut' -> bndr' arg_tys = tyConAppArgs (idType bndr) cse_alt (DataAlt con, args, rhs) - | not (null args) - -- 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 - = (DataAlt con, args', tryForCSE new_env rhs) - where - (env', args') = addBinders alt_env args - new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) - (Var con_target) + | not (null args) + -- 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 + = (DataAlt con, args', tryForCSE new_env rhs) + where + (env', args') = addBinders alt_env args + new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) + (Var con_target) cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) - where - (env', args') = addBinders alt_env args + = (con, args', tryForCSE env' rhs) + where + (env', args') = addBinders alt_env args \end{code} %************************************************************************ -%* * +%* * \section{The CSE envt} -%* * +%* * %************************************************************************ \begin{code} -type InExpr = CoreExpr -- Pre-cloning +type InExpr = CoreExpr -- Pre-cloning type InBndr = CoreBndr type InAlt = CoreAlt -type OutExpr = CoreExpr -- Post-cloning +type OutExpr = CoreExpr -- Post-cloning type OutBndr = CoreBndr type OutAlt = CoreAlt --- See Note [Keep old CsEnv rep] -#ifdef OLD_CSENV_REP -data CSEnv = CS { cs_map :: CSEMap - , cs_subst :: Subst } - -type CSEMap = UniqFM [(OutExpr, OutExpr)] -- 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 :: CSEnv -emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst } - -lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr - = case lookupUFM oldmap (hashExpr expr) of - Nothing -> Nothing - Just pairs -> lookup_list pairs - where - in_scope = substInScope sub - - -- 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 :: [(OutExpr,OutExpr)] -> Maybe OutExpr - lookup_list ((e,e'):es) - | eqExpr in_scope e expr = Just e' - | otherwise = lookup_list es - lookup_list [] = Nothing - -addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> 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 -> OutExpr -> OutExpr -> CSEnv -extendCSEnv cse@(CS { cs_map = oldmap }) expr expr' - = cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] } - where - 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 - -#else ------------- NEW ---------------- - data CSEnv = CS { cs_map :: CoreMap (OutExpr, OutExpr) -- Key, value , cs_subst :: Subst } @@ -359,7 +281,7 @@ emptyCSEnv :: CSEnv emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst } lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = csmap }) expr +lookupCSEnv (CS { cs_map = csmap }) expr = case lookupCoreMap csmap expr of Just (_,e) -> Just e Nothing -> Nothing @@ -375,7 +297,6 @@ addCSEnvItem = extendCSEnv extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv extendCSEnv cse expr expr' = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,expr') } -#endif csEnvSubst :: CSEnv -> Subst csEnvSubst = cs_subst @@ -387,17 +308,17 @@ extendCSSubst :: CSEnv -> Id -> Id -> CSEnv extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) } addBinder :: CSEnv -> Var -> (CSEnv, Var) -addBinder cse v = (cse { cs_subst = sub' }, v') +addBinder cse v = (cse { cs_subst = sub' }, v') where (sub', v') = substBndr (cs_subst cse) v addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) -addBinders cse vs = (cse { cs_subst = sub' }, vs') +addBinders cse vs = (cse { cs_subst = sub' }, vs') where (sub', vs') = substBndrs (cs_subst cse) vs addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders cse vs = (cse { cs_subst = sub' }, vs') +addRecBinders cse vs = (cse { cs_subst = sub' }, vs') where (sub', vs') = substRecBndrs (cs_subst cse) vs \end{code} |