CSE.hs 12.2 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
import Id               ( Id, idType, idInlineActivation, zapIdOccInfo, zapIdUsageInfo )
16
import CoreUtils        ( mkAltExpr
Peter Wortmann's avatar
Peter Wortmann committed
17
                        , exprIsTrivial
18
                        , stripTicksE, stripTicksT, stripTicksTopE, mkTick, mkTicks )
19
import Type             ( tyConAppArgs )
20 21
import CoreSyn
import Outputable
22
import BasicTypes       ( isAlwaysActive )
23
import TrieMap
24 25

import Data.List
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
Note [Case binders 1]
63
~~~~~~~~~~~~~~~~~~~~~~
64 65
Consider

66 67 68
        f = \x -> case x of wild {
                        (a:as) -> case a of wild1 {
                                    (p,q) -> ...(wild1:as)...
69 70 71 72 73 74

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),
but for CSE purpose that's a bad idea.

So we add the binding (wild1 -> a) to the extra var->var mapping.
75
Notice this is exactly backwards to what the simplifier does, which is
76
to try to replaces uses of 'a' with uses of 'wild1'
77

78
Note [Case binders 2]
79
~~~~~~~~~~~~~~~~~~~~~~
80
Consider
81
        case (h x) of y -> ...(h x)...
82 83

We'd like to replace (h x) in the alternative, by y.  But because of
84
the preceding [Note: case binders 1], we only want to add the mapping
85
        scrutinee -> case binder
86 87
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
88
        case binder -> scrutinee
89
to the substitution
90

91 92
Note [CSE for INLINE and NOINLINE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
93 94 95
There are some subtle interactions of CSE with functions that the user
has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
Consider
96

97
        yes :: Int  {-# NOINLINE yes #-}
98
        yes = undefined
99

100
        no :: Int   {-# NOINLINE no #-}
101
        no = undefined
102

103
        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}
104
        foo m n = n
105

106
        {-# RULES "foo/no" foo no = id #-}
107

108 109
        bar :: Int -> Int
        bar = foo yes
110

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

117
But we do need to take care.  Consider
118

119 120
        {-# NOINLINE bar #-}
        bar = <rhs>     -- Same rhs as foo
121

122 123
        foo = <rhs>

124
If CSE produces
125
        foo = bar
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
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.

141

142 143 144 145 146 147
Note [CSE for case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  case f x of y { pat -> ...let y = f x in ... }
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.
148

Austin Seipp's avatar
Austin Seipp committed
149 150
************************************************************************
*                                                                      *
151
\section{Common subexpression}
Austin Seipp's avatar
Austin Seipp committed
152 153 154
*                                                                      *
************************************************************************
-}
155

156
cseProgram :: CoreProgram -> CoreProgram
157
cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
158 159

cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
160
cseBind env (NonRec b e)
161
  = (env2, NonRec b'' e')
162 163
  where
    (env1, b') = addBinder env b
164
    (env2, (b'', e')) = cseRhs env1 (b',e)
165 166

cseBind env (Rec pairs)
167
  = (env2, Rec pairs')
168 169 170
  where
    (bs,es) = unzip pairs
    (env1, bs') = addRecBinders env bs
171
    (env2, pairs') = mapAccumL cseRhs env1 (bs' `zip` es)
172

173
cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, (OutBndr, OutExpr))
174
cseRhs env (id',rhs)
Peter Wortmann's avatar
Peter Wortmann committed
175
  = case lookupCSEnv env rhs'' of
176
        Nothing
177 178
          | always_active -> (extendCSEnv env rhs' id', (zapped_id, rhs'))
          | otherwise     -> (env,                      (id', rhs'))
179
        Just id
180 181 182 183
          | always_active -> (extendCSSubst env id' id_expr, (id', mkTicks ticks id_expr))
          | otherwise     -> (env,                           (id', mkTicks ticks id_expr))
          where
            id_expr = varToCoreExpr id  -- Could be a CoVar
184 185 186 187 188 189 190 191
          -- In the Just case, we have
          --        x = rhs
          --        ...
          --        x' = rhs
          -- We are replacing the second binding with x'=x
          -- and so must record that in the substitution so
          -- that subsequent uses of x' are replaced with x,
          -- See Trac #5996
192
  where
193 194 195 196 197 198 199 200 201 202 203
    zapped_id = zapIdUsageInfo id'
       -- Putting the Id into the environment makes it possible that
       -- it'll become shared more than it is now, which would
       -- invalidate (the usage part of) its demand info.  This caused
       -- Trac #100218.
       -- 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

204 205
    rhs' = cseExpr env rhs

206 207
    ticks = stripTicksT tickishFloatable rhs'
    rhs'' = stripTicksE tickishFloatable rhs'
Peter Wortmann's avatar
Peter Wortmann committed
208 209 210 211 212
    -- 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.

213 214
    always_active = isAlwaysActive (idInlineActivation id')
         -- See Note [CSE for INLINE and NOINLINE]
215

216
tryForCSE :: CSEnv -> InExpr -> OutExpr
217
tryForCSE env expr
Peter Wortmann's avatar
Peter Wortmann committed
218 219 220
  | exprIsTrivial expr'                    = expr'       -- No point
  | Just smaller <- lookupCSEnv env expr'' = foldr mkTick (Var smaller) ticks
  | otherwise                              = expr'
221 222
  where
    expr' = cseExpr env expr
223 224
    expr'' = stripTicksE tickishFloatable expr'
    ticks = stripTicksT tickishFloatable expr'
225

226
cseExpr :: CSEnv -> InExpr -> OutExpr
227 228
cseExpr env (Type t)               = Type (substTy (csEnvSubst env) t)
cseExpr env (Coercion c)           = Coercion (substCo (csEnvSubst env) c)
twanvl's avatar
twanvl committed
229
cseExpr _   (Lit lit)              = Lit lit
230 231
cseExpr env (Var v)                = lookupSubst env v
cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
232
cseExpr env (Tick t e)             = Tick t (cseExpr env e)
233
cseExpr env (Cast e co)            = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
234 235 236 237
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)
238
cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr''' ty alts'
239 240 241 242 243 244 245
                          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
246
                                (env2, (bndr''', scrut')) = cseRhs env1 (bndr'', scrut)
247
                                -- Note [CSE for case expressions]
248

249
cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]
twanvl's avatar
twanvl committed
250

251
cseAlts env scrut' bndr bndr' alts
252 253
  = map cse_alt alts
  where
Peter Wortmann's avatar
Peter Wortmann committed
254
    scrut'' = stripTicksTopE tickishFloatable scrut'
255
    (con_target, alt_env)
Peter Wortmann's avatar
Peter Wortmann committed
256
        = case scrut'' of
257 258
            Var v' -> (v', extendCSSubst env bndr scrut'') -- See Note [Case binders 1]
                                                           -- map: bndr -> v'
259

260
            _      -> (bndr', extendCSEnv env scrut' bndr') -- See Note [Case binders 2]
261
                                                             -- map: scrut' -> bndr'
262

263
    arg_tys = tyConAppArgs (idType bndr)
264

265
    cse_alt (DataAlt con, args, rhs)
266 267 268 269 270 271 272 273 274
        | 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
275 276
          new_env       = extendCSEnv env' con_expr con_target
          con_expr      = mkAltExpr (DataAlt con) args' arg_tys
277 278

    cse_alt (con, args, rhs)
279 280 281
        = (con, args', tryForCSE env' rhs)
        where
          (env', args') = addBinders alt_env args
282

Austin Seipp's avatar
Austin Seipp committed
283 284 285
{-
************************************************************************
*                                                                      *
286
\section{The CSE envt}
Austin Seipp's avatar
Austin Seipp committed
287 288 289
*                                                                      *
************************************************************************
-}
290

291
type InExpr  = CoreExpr         -- Pre-cloning
292 293 294
type InBndr  = CoreBndr
type InAlt   = CoreAlt

295
type OutExpr  = CoreExpr        -- Post-cloning
296 297
type OutBndr  = CoreBndr
type OutAlt   = CoreAlt
298

299
data CSEnv  = CS { cs_map    :: CoreMap (OutExpr, Id)   -- Key, value
300 301 302 303 304
                 , cs_subst  :: Subst }

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

305
lookupCSEnv :: CSEnv -> OutExpr -> Maybe Id
306
lookupCSEnv (CS { cs_map = csmap }) expr
307 308 309 310
  = case lookupCoreMap csmap expr of
      Just (_,e) -> Just e
      Nothing    -> Nothing

311 312
extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv
extendCSEnv cse expr id
Peter Wortmann's avatar
Peter Wortmann committed
313
  = cse { cs_map = extendCoreMap (cs_map cse) sexpr (sexpr,id) }
314
  where sexpr = stripTicksE tickishFloatable expr
315 316 317 318

csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst

319
lookupSubst :: CSEnv -> Id -> OutExpr
320
lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
321

322 323
extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv
extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
324 325

addBinder :: CSEnv -> Var -> (CSEnv, Var)
326
addBinder cse v = (cse { cs_subst = sub' }, v')
327 328
                where
                  (sub', v') = substBndr (cs_subst cse) v
329 330

addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
331
addBinders cse vs = (cse { cs_subst = sub' }, vs')
332 333
                where
                  (sub', vs') = substBndrs (cs_subst cse) vs
334

335
addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
336
addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
337 338
                where
                  (sub', vs') = substRecBndrs (cs_subst cse) vs