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