compiler/simplCore/CSE.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section{Common subexpression}
   5
   6 \begin{code}
   7 module CSE (
   8         cseProgram
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import Id               ( Id, idType, idInlineActivation, zapIdOccInfo )
  14 import CoreUtils        ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap )
  15 import DataCon          ( isUnboxedTupleCon )
  16 import Type             ( tyConAppArgs )
  17 import CoreSyn
  18 import VarEnv
  19 import Outputable
  20 import StaticFlags      ( opt_PprStyle_Debug )
  21 import BasicTypes       ( isAlwaysActive )
  22 import Util             ( lengthExceeds )
  23 import UniqFM
  24 import FastString
  25
  26 import Data.List
  27 \end{code}
  28
  29
  30                         Simple common sub-expression
  31                         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  32 When we see
  33         x1 = C a b
  34         x2 = C x1 b
  35 we build up a reverse mapping:   C a b  -> x1
  36                                  C x1 b -> x2
  37 and apply that to the rest of the program.
  38
  39 When we then see
  40         y1 = C a b
  41         y2 = C y1 b
  42 we replace the C a b with x1.  But then we *dont* want to
  43 add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
  44 so that a subsequent binding
  45         y2 = C y1 b
  46 will get transformed to C x1 b, and then to x2.
  47
  48 So we carry an extra var->var substitution which we apply *before* looking up in the
  49 reverse mapping.
  50
  51
  52 Note [Shadowing]
  53 ~~~~~~~~~~~~~~~~
  54 We have to be careful about shadowing.
  55 For example, consider
  56         f = \x -> let y = x+x in
  57                       h = \x -> x+x
  58                   in ...
  59
  60 Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
  61 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
  62 We can simply add clones to the substitution already described.
  63
  64 However, we do NOT clone type variables.  It's just too hard, because then we need
  65 to run the substitution over types and IdInfo.  No no no.  Instead, we just throw
  66
  67 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
  68
  69
  70 Note [Case binders 1]
  71 ~~~~~~~~~~~~~~~~~~~~~~
  72 Consider
  73
  74         f = \x -> case x of wild {
  75                         (a:as) -> case a of wild1 {
  76                                     (p,q) -> ...(wild1:as)...
  77
  78 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
  79 But that's not quite obvious.  In general we want to keep it as (wild1:as),
  80 but for CSE purpose that's a bad idea.
  81
  82 So we add the binding (wild1 -> a) to the extra var->var mapping.
  83 Notice this is exactly backwards to what the simplifier does, which is
  84 to try to replaces uses of 'a' with uses of 'wild1'
  85
  86 Note [Case binders 2]
  87 ~~~~~~~~~~~~~~~~~~~~~~
  88 Consider
  89         case (h x) of y -> ...(h x)...
  90
  91 We'd like to replace (h x) in the alternative, by y.  But because of
  92 the preceding [Note: case binders 1], we only want to add the mapping
  93         scrutinee -> case binder
  94 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
  95 (If the scrutinee is a simple variable we want to add the mapping
  96         case binder -> scrutinee
  97 to the substitution
  98
  99 Note [Unboxed tuple case binders]
 100 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 101 Consider
 102         case f x of t { (# a,b #) ->
 103         case ... of
 104           True -> f x
 105           False -> 0 }
 106
 107 We must not replace (f x) by t, because t is an unboxed-tuple binder.
 108 Instead, we shoudl replace (f x) by (# a,b #).  That is, the "reverse mapping" is
 109         f x --> (# a,b #)
 110 That is why the CSEMap has pairs of expressions.
 111
 112 Note [CSE for INLINE and NOINLINE]
 113 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 114 We are careful to do no CSE inside functions that the user has marked as
 115 INLINE or NOINLINE.  In terms of Core, that means
 116
 117         a) we do not do CSE inside an InlineRule
 118
 119         b) we do not do CSE on the RHS of a binding b=e
 120            unless b's InlinePragma is AlwaysActive
 121
 122 Here's why (examples from Roman Leshchinskiy).  Consider
 123
 124         yes :: Int
 125         {-# NOINLINE yes #-}
 126         yes = undefined
 127
 128         no :: Int
 129         {-# NOINLINE no #-}
 130         no = undefined
 131
 132         foo :: Int -> Int -> Int
 133         {-# NOINLINE foo #-}
 134         foo m n = n
 135
 136         {-# RULES "foo/no" foo no = id #-}
 137
 138         bar :: Int -> Int
 139         bar = foo yes
 140
 141 We do not expect the rule to fire.  But if we do CSE, then we get
 142 yes=no, and the rule does fire.  Worse, whether we get yes=no or
 143 no=yes depends on the order of the definitions.
 144
 145 In general, CSE should probably never touch things with INLINE pragmas
 146 as this could lead to surprising results.  Consider
 147
 148         {-# INLINE foo #-}
 149         foo = <rhs>
 150
 151         {-# NOINLINE bar #-}
 152         bar = <rhs>     -- Same rhs as foo
 153
 154 If CSE produces
 155         foo = bar
 156 then foo will never be inlined (when it should be); but if it produces
 157         bar = foo
 158 bar will be inlined (when it should not be). Even if we remove INLINE foo,
 159 we'd still like foo to be inlined if rhs is small. This won't happen
 160 with foo = bar.
 161
 162 Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider
 163 a worker/wrapper, in which the worker has turned into a single variable:
 164         $wf = h
 165         f = \x -> ...$wf...
 166 Now CSE may transform to
 167         f = \x -> ...h...
 168 But the WorkerInfo for f still says $wf, which is now dead!  This won't
 169 happen now that we don't look inside INLINEs (which wrappers are).
 170
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \section{Common subexpression}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 \begin{code}
 179 cseProgram :: [CoreBind] -> [CoreBind]
 180 cseProgram binds = cseBinds emptyCSEnv binds
 181
 182 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
 183 cseBinds _   []     = []
 184 cseBinds env (b:bs) = (b':bs')
 185                     where
 186                       (env1, b') = cseBind  env  b
 187                       bs'        = cseBinds env1 bs
 188
 189 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
 190 cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e)
 191                            in (env', NonRec b' e')
 192 cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env pairs
 193                            in (env', Rec pairs')
 194
 195
 196 do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr))
 197 do_one env (id, rhs)
 198   = case lookupCSEnv env rhs' of
 199         Just (Var other_id) -> (extendSubst env' id other_id,     (id', Var other_id))
 200         Just other_expr     -> (env',                             (id', other_expr))
 201         Nothing             -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
 202   where
 203     (env', id') = addBinder env id
 204     rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs
 205          | otherwise                              = rhs
 206                 -- See Note [CSE for INLINE and NOINLINE]
 207
 208 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 209 tryForCSE _   (Type t) = Type t
 210 tryForCSE _   (Coercion c) = Coercion c
 211 tryForCSE env expr     = case lookupCSEnv env expr' of
 212                             Just smaller_expr -> smaller_expr
 213                             Nothing           -> expr'
 214                        where
 215                          expr' = cseExpr env expr
 216
 217 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 218 cseExpr _   (Type t)               = Type t
 219 cseExpr _   (Coercion co)          = Coercion co
 220 cseExpr _   (Lit lit)              = Lit lit
 221 cseExpr env (Var v)                = Var (lookupSubst env v)
 222 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
 223 cseExpr env (Note n e)             = Note n (cseExpr env e)
 224 cseExpr env (Cast e co)            = Cast (cseExpr env e) co
 225 cseExpr env (Lam b e)              = let (env', b') = addBinder env b
 226                                      in Lam b' (cseExpr env' e)
 227 cseExpr env (Let bind e)           = let (env', bind') = cseBind env bind
 228                                      in Let bind' (cseExpr env' e)
 229 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts)
 230                                    where
 231                                      scrut' = tryForCSE env scrut
 232                                      (env', bndr') = addBinder env bndr
 233                                      bndr'' = zapIdOccInfo bndr'
 234                                         -- The swizzling from Note [Case binders 2] may
 235                                         -- cause a dead case binder to be alive, so we
 236                                         -- play safe here and bring them all to life
 237
 238 cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
 239
 240 cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
 241   | isUnboxedTupleCon con
 242         -- Unboxed tuples are special because the case binder isn't
 243         -- a real value.  See Note [Unboxed tuple case binders]
 244   = [(DataAlt con, args'', tryForCSE new_env rhs)]
 245   where
 246     (env', args') = addBinders env args
 247     args'' = map zapIdOccInfo args'     -- They should all be ids
 248         -- Same motivation for zapping as [Case binders 2] only this time
 249         -- it's Note [Unboxed tuple case binders]
 250     new_env | exprIsCheap scrut' = env'
 251             | otherwise          = extendCSEnv env' scrut' tup_value
 252     tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))
 253
 254 cseAlts env scrut' bndr bndr' alts
 255   = map cse_alt alts
 256   where
 257     (con_target, alt_env)
 258         = case scrut' of
 259                 Var v' -> (v',     extendSubst env bndr v')     -- See Note [Case binders 1]
 260                                                                 -- map: bndr -> v'
 261
 262                 _      ->  (bndr', extendCSEnv env scrut' (Var  bndr')) -- See Note [Case binders 2]
 263                                                                         -- map: scrut' -> bndr'
 264
 265     arg_tys = tyConAppArgs (idType bndr)
 266
 267     cse_alt (DataAlt con, args, rhs)
 268         | not (null args)
 269                 -- Don't try CSE if there are no args; it just increases the number
 270                 -- of live vars.  E.g.
 271                 --      case x of { True -> ....True.... }
 272                 -- Don't replace True by x!
 273                 -- Hence the 'null args', which also deal with literals and DEFAULT
 274         = (DataAlt con, args', tryForCSE new_env rhs)
 275         where
 276           (env', args') = addBinders alt_env args
 277           new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
 278                                            (Var con_target)
 279
 280     cse_alt (con, args, rhs)
 281         = (con, args', tryForCSE env' rhs)
 282         where
 283           (env', args') = addBinders alt_env args
 284 \end{code}
 285
 286
 287 %************************************************************************
 288 %*                                                                      *
 289 \section{The CSE envt}
 290 %*                                                                      *
 291 %************************************************************************
 292
 293 \begin{code}
 294 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
 295                         -- Simple substitution
 296
 297 type CSEMap = UniqFM [(CoreExpr, CoreExpr)]     -- This is the reverse mapping
 298         -- It maps the hash-code of an expression e to list of (e,e') pairs
 299         -- This means that it's good to replace e by e'
 300         -- INVARIANT: The expr in the range has already been CSE'd
 301
 302 emptyCSEnv :: CSEnv
 303 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 304
 305 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
 306 lookupCSEnv (CS cs in_scope _) expr
 307   = case lookupUFM cs (hashExpr expr) of
 308         Nothing -> Nothing
 309         Just pairs -> lookup_list pairs
 310   where
 311   -- In this lookup we use full expression equality
 312   -- Reason: when expressions differ we generally find out quickly
 313   --         but I found that cheapEqExpr was saying (\x.x) /= (\y.y),
 314   --         and this kind of thing happened in real programs
 315     lookup_list :: [(CoreExpr,CoreExpr)] -> Maybe CoreExpr
 316     lookup_list []                                   = Nothing
 317     lookup_list ((e,e'):es) | eqExpr in_scope e expr = Just e'
 318                             | otherwise              = lookup_list es
 319
 320 addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
 321 addCSEnvItem env expr expr' | exprIsBig expr = env
 322                             | otherwise      = extendCSEnv env expr expr'
 323    -- We don't try to CSE big expressions, because they are expensive to compare
 324    -- (and are unlikely to be the same anyway)
 325
 326 extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv
 327 extendCSEnv (CS cs in_scope sub) expr expr'
 328   = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
 329   where
 330     hash = hashExpr expr
 331     combine old new
 332         = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
 333         where
 334           result = new ++ old
 335           short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
 336           long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
 337                    | otherwise          = empty
 338
 339 lookupSubst :: CSEnv -> Id -> Id
 340 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
 341                                Just y  -> y
 342                                Nothing -> x
 343
 344 extendSubst :: CSEnv -> Id  -> Id -> CSEnv
 345 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
 346
 347 addBinder :: CSEnv -> Id -> (CSEnv, Id)
 348 addBinder (CS cs in_scope sub) v
 349   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                     v)
 350   | isId v                            = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
 351   | otherwise                         = WARN( True, ppr v )
 352                                         (CS emptyUFM in_scope                 sub,                     v)
 353         -- This last case is the unusual situation where we have shadowing of
 354         -- a type variable; we have to discard the CSE mapping
 355         -- See Note [Shadowing]
 356   where
 357     v' = uniqAway in_scope v
 358
 359 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
 360 addBinders env vs = mapAccumL addBinder env vs
 361 \end{code}