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