CSE.hs 15.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The AQUA Project, Glasgow University, 1993-1998

4
\section{Common subexpression}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7 8
{-# LANGUAGE CPP #-}

9
module CSE (cseProgram) where
10 11 12

#include "HsVersions.h"

13
import CoreSubst
14
import Var              ( Var )
15 16
import Id               ( Id, idType, idUnfolding, idInlineActivation
                        , zapIdOccInfo, zapIdUsageInfo )
17
import CoreUtils        ( mkAltExpr
18
                        , stripTicksE, stripTicksT, mkTicks )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
19 20
import Literal          ( litIsTrivial )
import Type             ( tyConAppArgs )
21 22
import CoreSyn
import Outputable
23
import BasicTypes       ( isAlwaysActive )
24
import TrieMap
Simon Peyton Jones's avatar
Simon Peyton Jones committed
25
import Data.List        ( mapAccumL )
26

Austin Seipp's avatar
Austin Seipp committed
27
{-
28 29
                        Simple common sub-expression
                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
30
When we see
31 32
        x1 = C a b
        x2 = C x1 b
33
we build up a reverse mapping:   C a b  -> x1
34
                                 C x1 b -> x2
35 36 37
and apply that to the rest of the program.

When we then see
38 39
        y1 = C a b
        y2 = C y1 b
40
we replace the C a b with x1.  But then we *dont* want to
41
add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
42
so that a subsequent binding
43 44
        y2 = C y1 b
will get transformed to C x1 b, and then to x2.
45

46
So we carry an extra var->var substitution which we apply *before* looking up in the
47 48 49
reverse mapping.


simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
50 51
Note [Shadowing]
~~~~~~~~~~~~~~~~
52
We have to be careful about shadowing.
53
For example, consider
54 55 56
        f = \x -> let y = x+x in
                      h = \x -> x+x
                  in ...
57

58 59 60 61
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.
We can simply add clones to the substitution already described.

62

63 64
Note [CSE for bindings]
~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
65 66 67
Let-bindings have two cases, implemented by addBinding.

* SUBSTITUTE: applies when the RHS is a variable or literal
68 69 70 71 72 73 74 75

     let x = y in ...(h x)....

  Here we want to extend the /substitution/ with x -> y, so that the
  (h x) in the body might CSE with an enclosing (let v = h y in ...).
  NB: the substitution maps InIds, so we extend the substitution with
      a biding for the original InId 'x'

Simon Peyton Jones's avatar
Simon Peyton Jones committed
76
  How can we have a variable on the RHS? Doesn't the simplifier inline them?
77 78 79 80 81 82 83 84 85 86 87 88 89

    - First, the original RHS might have been (g z) which has CSE'd
      with an enclosing (let y = g z in ...).  This is super-important.
      See Trac #5996:
         x1 = C a b
         x2 = C x1 b
         y1 = C a b
         y2 = C y1 b
      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
      the substitution so that we can CSE the binding for y2.

    - Second, we use cseRHS for case expression scrutinees too;
      see Note [CSE for case expressions]
90

Simon Peyton Jones's avatar
Simon Peyton Jones committed
91 92
* EXTEND THE REVERSE MAPPING: applies in all other cases

93
     let x = h y in ...(h y)...
94

95 96
  Here we want to extend the /reverse mapping (cs_map)/ so that
  we CSE the (h y) call to x.
97

Simon Peyton Jones's avatar
Simon Peyton Jones committed
98 99 100 101 102 103 104 105 106 107 108
  Note that we use EXTEND even for a trivial expression, provided it
  is not a variable or literal. In particular this /includes/ type
  applications. This can be important (Trac #13156); e.g.
     case f @ Int of { r1 ->
     case f @ Int of { r2 -> ...
  Here we want to common-up the two uses of (f @ Int) so we can
  remove one of the case expressions.

  See also Note [Corner case for case expressions] for another
  reason not to use SUBSTITUTE for all trivial expressions.

109
Notice that
Simon Peyton Jones's avatar
Simon Peyton Jones committed
110 111
  - The SUBSTITUTE situation extends the substitution (cs_subst)
  - The EXTEND situation extends the reverse mapping (cs_map)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
112

Simon Peyton Jones's avatar
Simon Peyton Jones committed
113
Notice also that in the SUBSTITUTE case we leave behind a binding
Simon Peyton Jones's avatar
Simon Peyton Jones committed
114 115 116 117 118 119 120 121
  x = y
even though we /also/ carry a substitution x -> y.  Can we just drop
the binding instead?  Well, not at top level! See SimplUtils
Note [Top level and postInlineUnconditionally]; and in any case CSE
applies only to the /bindings/ of the program, and we leave it to the
simplifier to propate effects to the RULES.  Finally, it doesn't seem
worth the effort to discard the nested bindings because the simplifier
will do it next.
122 123 124

Note [CSE for case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
125
Consider
126 127 128
  case scrut_expr of x { ...alts... }
This is very like a strict let-binding
  let !x = scrut_expr in ...
Simon Peyton Jones's avatar
Simon Peyton Jones committed
129
So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a
130 131 132 133 134 135 136 137
result all the stuff under Note [CSE for bindings] applies directly.

For example:

* Trivial scrutinee
     f = \x -> case x of wild {
                 (a:as) -> case a of wild1 {
                             (p,q) -> ...(wild1:as)...
138

139 140 141 142 143
  Here, (wild1:as) is morally the same as (a:as) and hence equal to
  wild. But that's not quite obvious.  In the rest of the compiler we
  want to keep it as (wild1:as), but for CSE purpose that's a bad
  idea.

Simon Peyton Jones's avatar
Simon Peyton Jones committed
144
  By using addBinding we add the binding (wild1 -> a) to the substitution,
145 146 147 148 149 150 151 152 153 154
  which does exactly the right thing.

  (Notice this is exactly backwards to what the simplifier does, which
  is to try to replaces uses of 'a' with uses of 'wild1'.)

  This is the main reason that cseRHs is called with a trivial rhs.

* Non-trivial scrutinee
     case (f x) of y { pat -> ...let y = f x in ... }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
155
  By using addBinding we'll add (f x :-> y) to the cs_map, and
156
  thereby CSE the inner (f x) to y.
157

158 159
Note [CSE for INLINE and NOINLINE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
160 161 162
There are some subtle interactions of CSE with functions that the user
has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
Consider
163

164
        yes :: Int  {-# NOINLINE yes #-}
165
        yes = undefined
166

167
        no :: Int   {-# NOINLINE no #-}
168
        no = undefined
169

170
        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}
171
        foo m n = n
172

173
        {-# RULES "foo/no" foo no = id #-}
174

175 176
        bar :: Int -> Int
        bar = foo yes
177

178
We do not expect the rule to fire.  But if we do CSE, then we risk
Gabor Greif's avatar
Gabor Greif committed
179
getting yes=no, and the rule does fire.  Actually, it won't because
180
NOINLINE means that 'yes' will never be inlined, not even if we have
Gabor Greif's avatar
Gabor Greif committed
181
yes=no.  So that's fine (now; perhaps in the olden days, yes=no would
Simon Peyton Jones's avatar
Simon Peyton Jones committed
182
have substituted even if 'yes' was NOINLINE).
183

184
But we do need to take care.  Consider
185

186 187
        {-# NOINLINE bar #-}
        bar = <rhs>     -- Same rhs as foo
188

189 190
        foo = <rhs>

191
If CSE produces
192
        foo = bar
193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
then foo will never be inlined to <rhs> (when it should be, if <rhs>
is small).  The conclusion here is this:

   We should not add
       <rhs> :-> bar
  to the CSEnv if 'bar' has any constraints on when it can inline;
  that is, if its 'activation' not always active.  Otherwise we
  might replace <rhs> by 'bar', and then later be unable to see that it
  really was <rhs>.

Note that we do not (currently) do CSE on the unfolding stored inside
an Id, even if is a 'stable' unfolding.  That means that when an
unfolding happens, it is always faithful to what the stable unfolding
originally was.

208 209
Note [CSE for stable unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
210
Consider
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232
   {-# Unf = Stable (\pq. build blah) #-}
   foo = x

Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
(Turns out that this actually happens for the enumFromTo method of
the Integer instance of Enum in GHC.Enum.)  Then we obviously do NOT
want to extend the substitution with (foo->x)!   See similar
SimplUtils Note [Stable unfoldings and postInlineUnconditionally].

Nor do we want to change the reverse mapping. Suppose we have

   {-# Unf = Stable (\pq. build blah) #-}
   foo = <expr>
   bar = <expr>

There could conceivably be merit in rewriting the RHS of bar:
   bar = foo
but now bar's inlining behaviour will change, and importing
modules might see that.  So it seems dodgy and we don't do it.

Note [Corner case for case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
233 234
Here is another reason that we do not use SUBSTITUTE for
all trivial expressions. Consider
235 236
   case x |> co of (y::Array# Int) { ... }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
237 238 239
We do not want to extend the substitution with (y -> x |> co); since y
is of unlifted type, this would desroy the let/app invariant if (x |>
co) was not ok-for-speculation.
240

Simon Peyton Jones's avatar
Simon Peyton Jones committed
241 242 243 244
But surely (x |> co) is ok-for-speculation, becasue it's a trivial
expression, and x's type is also unlifted, presumably.  Well, maybe
not if you are using unsafe casts.  I actually found a case where we
had
245 246
   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)

247

Austin Seipp's avatar
Austin Seipp committed
248 249
************************************************************************
*                                                                      *
250
\section{Common subexpression}
Austin Seipp's avatar
Austin Seipp committed
251 252 253
*                                                                      *
************************************************************************
-}
254

255
cseProgram :: CoreProgram -> CoreProgram
256
cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
257 258

cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
259
cseBind env (NonRec b e)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
260
  = (env2, NonRec b2 e1)
261
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
262 263 264
    e1         = tryForCSE env e
    (env1, b1) = addBinder env b
    (env2, b2) = addBinding env1 b b1 e1
265 266

cseBind env (Rec pairs)
267
  = (env2, Rec pairs')
268
  where
269 270 271 272
    (bndrs, rhss)  = unzip pairs
    (env1, bndrs1) = addRecBinders env bndrs
    rhss1          = map (tryForCSE env1) rhss
                     -- Process rhss in extended env1
Simon Peyton Jones's avatar
Simon Peyton Jones committed
273 274 275 276 277
    (env2, pairs') = foldl do_one (env1, []) (zip3 bndrs bndrs1 rhss1)
    do_one (env, pairs) (b, b1, e1)
         = (env1, (b2, e1) : pairs)
       where
         (env1, b2) = addBinding env b b1 e1
278 279 280 281

addBinding :: CSEnv                      -- Includes InId->OutId cloning
           -> InId
           -> OutId -> OutExpr           -- Processed binding
Simon Peyton Jones's avatar
Simon Peyton Jones committed
282
           -> (CSEnv, OutId)             -- Final env, final bndr
283 284 285
-- Extend the CSE env with a mapping [rhs -> out-id]
-- unless we can instead just substitute [in-id -> rhs]
addBinding env in_id out_id rhs'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
286 287 288
  | no_cse    = (env,                              out_id)
  | use_subst = (extendCSSubst env in_id rhs',     out_id)
  | otherwise = (extendCSEnv env rhs' id_expr', zapped_id)
289
  where
290 291 292
    id_expr'  = varToCoreExpr out_id
    zapped_id = zapIdUsageInfo out_id
       -- Putting the Id into the cs_map makes it possible that
293
       -- it'll become shared more than it is now, which would
294 295
       -- invalidate (the usage part of) its demand info.
       --    This caused Trac #100218.
296 297 298 299 300 301
       -- Easiest thing is to zap the usage info; subsequently
       -- performing late demand-analysis will restore it.  Don't zap
       -- the strictness info; it's not necessary to do so, and losing
       -- it is bad for performance if you don't do late demand
       -- analysis

302 303 304 305
    no_cse = not (isAlwaysActive (idInlineActivation out_id))
             -- See Note [CSE for INLINE and NOINLINE]
          || isStableUnfolding (idUnfolding out_id)
             -- See Note [CSE for stable unfoldings]
Peter Wortmann's avatar
Peter Wortmann committed
306

Simon Peyton Jones's avatar
Simon Peyton Jones committed
307
    -- Should we use SUBSTITUTE or EXTEND?
308
    -- See Note [CSE for bindings]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
309 310 311 312
    use_subst = case rhs' of
                   Var {} -> True
                   Lit l  -> litIsTrivial l
                   _      -> False
313

314
tryForCSE :: CSEnv -> InExpr -> OutExpr
315
tryForCSE env expr
316 317 318 319 320 321
  | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
  | otherwise                        = expr'
    -- The varToCoreExpr is needed if we have
    --   case e of xco { ...case e of yco { ... } ... }
    -- Then CSE will substitute yco -> xco;
    -- but these are /coercion/ variables
322
  where
323
    expr'  = cseExpr env expr
324
    expr'' = stripTicksE tickishFloatable expr'
325 326 327 328 329
    ticks  = stripTicksT tickishFloatable expr'
    -- We don't want to lose the source notes when a common sub
    -- expression gets eliminated. Hence we push all (!) of them on
    -- top of the replaced sub-expression. This is probably not too
    -- useful in practice, but upholds our semantics.
330

331
cseExpr :: CSEnv -> InExpr -> OutExpr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
332 333 334 335 336 337 338 339 340 341 342 343
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 (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 (Case e bndr ty alts) = cseCase env e bndr ty alts
344 345 346

cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
cseCase env scrut bndr ty alts
Simon Peyton Jones's avatar
Simon Peyton Jones committed
347
  = Case scrut1 bndr3 ty (map cse_alt alts)
348
  where
349 350
    scrut1 = tryForCSE env scrut

351 352 353 354
    bndr1 = zapIdOccInfo bndr
      -- Zapping the OccInfo is needed because the extendCSEnv
      -- in cse_alt may mean that a dead case binder
      -- becomes alive, and Lint rejects that
Simon Peyton Jones's avatar
Simon Peyton Jones committed
355 356
    (env1, bndr2)    = addBinder env bndr1
    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1
357
         -- addBinding: see Note [CSE for case expressions]
358

359 360
    con_target :: OutExpr
    con_target = lookupSubst alt_env bndr
361

362 363
    arg_tys :: [OutType]
    arg_tys = tyConAppArgs (idType bndr3)
364

365
    cse_alt (DataAlt con, args, rhs)
366 367 368 369 370 371 372 373 374
        | 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
375 376
          new_env       = extendCSEnv env' con_expr con_target
          con_expr      = mkAltExpr (DataAlt con) args' arg_tys
377 378

    cse_alt (con, args, rhs)
379 380 381
        = (con, args', tryForCSE env' rhs)
        where
          (env', args') = addBinders alt_env args
382

Austin Seipp's avatar
Austin Seipp committed
383 384 385
{-
************************************************************************
*                                                                      *
386
\section{The CSE envt}
Austin Seipp's avatar
Austin Seipp committed
387 388 389
*                                                                      *
************************************************************************
-}
390

391 392 393 394
data CSEnv
  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs
            -- The substitution variables to
            -- /trivial/ OutExprs, not arbitrary expressions
395

396 397 398 399
       , cs_map   :: CoreMap OutExpr   -- The reverse mapping
            -- Maps a OutExpr to a /trivial/ OutExpr
            -- The key of cs_map is stripped of all Ticks
       }
400 401 402 403

emptyCSEnv :: CSEnv
emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst }

404
lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
405
lookupCSEnv (CS { cs_map = csmap }) expr
406 407 408 409 410 411 412
  = lookupCoreMap csmap expr

extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
extendCSEnv cse expr triv_expr
  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
  where
    sexpr = stripTicksE tickishFloatable expr
413 414 415 416

csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst

417
lookupSubst :: CSEnv -> Id -> OutExpr
418
lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
419

420 421
extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv
extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
422 423

addBinder :: CSEnv -> Var -> (CSEnv, Var)
424
addBinder cse v = (cse { cs_subst = sub' }, v')
425 426
                where
                  (sub', v') = substBndr (cs_subst cse) v
427 428

addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
429
addBinders cse vs = (cse { cs_subst = sub' }, vs')
430 431
                where
                  (sub', vs') = substBndrs (cs_subst cse) vs
432

433
addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
434
addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
435 436
                where
                  (sub', vs') = substRecBndrs (cs_subst cse) vs