CSE.hs 11.5 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 15 16
import Var              ( Var )
import Id               ( Id, idType, idInlineActivation, zapIdOccInfo )
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
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 162 163 164 165 166 167 168 169 170 171 172 173 174
  = (env2, NonRec b' e')
  where
    (env1, b') = addBinder env b
    (env2, e') = cseRhs env1 (b',e)

cseBind env (Rec pairs)
  = (env2, Rec (bs' `zip` es'))
  where
    (bs,es) = unzip pairs
    (env1, bs') = addRecBinders env bs
    (env2, es') = mapAccumL cseRhs env1 (bs' `zip` es)

cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)
cseRhs env (id',rhs)
Peter Wortmann's avatar
Peter Wortmann committed
175
  = case lookupCSEnv env rhs'' of
176 177 178 179
        Nothing
          | always_active -> (extendCSEnv env rhs' id', rhs')
          | otherwise     -> (env,                      rhs')
        Just id
Peter Wortmann's avatar
Peter Wortmann committed
180 181
          | always_active -> (extendCSSubst env id' id, mkTicks ticks $ Var id)
          | otherwise     -> (env,                      mkTicks ticks $ Var id)
182 183 184 185 186 187 188 189
          -- 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
190
  where
191 192
    rhs' = cseExpr env rhs

193 194
    ticks = stripTicksT tickishFloatable rhs'
    rhs'' = stripTicksE tickishFloatable rhs'
Peter Wortmann's avatar
Peter Wortmann committed
195 196 197 198 199
    -- 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.

200 201
    always_active = isAlwaysActive (idInlineActivation id')
         -- See Note [CSE for INLINE and NOINLINE]
202

203
tryForCSE :: CSEnv -> InExpr -> OutExpr
204
tryForCSE env expr
Peter Wortmann's avatar
Peter Wortmann committed
205 206 207
  | exprIsTrivial expr'                    = expr'       -- No point
  | Just smaller <- lookupCSEnv env expr'' = foldr mkTick (Var smaller) ticks
  | otherwise                              = expr'
208 209
  where
    expr' = cseExpr env expr
210 211
    expr'' = stripTicksE tickishFloatable expr'
    ticks = stripTicksT tickishFloatable expr'
212

213
cseExpr :: CSEnv -> InExpr -> OutExpr
214 215
cseExpr env (Type t)               = Type (substTy (csEnvSubst env) t)
cseExpr env (Coercion c)           = Coercion (substCo (csEnvSubst env) c)
twanvl's avatar
twanvl committed
216
cseExpr _   (Lit lit)              = Lit lit
217 218
cseExpr env (Var v)                = lookupSubst env v
cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
219
cseExpr env (Tick t e)             = Tick t (cseExpr env e)
220
cseExpr env (Cast e co)            = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
221 222 223 224
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)
225
cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts'
226 227 228 229 230 231 232 233 234
                          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
                                (env2, scrut') = cseRhs env1 (bndr'', scrut)
                                -- Note [CSE for case expressions]
235

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

238
cseAlts env scrut' bndr bndr' alts
239 240
  = map cse_alt alts
  where
Peter Wortmann's avatar
Peter Wortmann committed
241
    scrut'' = stripTicksTopE tickishFloatable scrut'
242
    (con_target, alt_env)
Peter Wortmann's avatar
Peter Wortmann committed
243
        = case scrut'' of
244 245
            Var v' -> (v',     extendCSSubst env bndr v')    -- See Note [Case binders 1]
                                                             -- map: bndr -> v'
246

247 248
            _      ->  (bndr', extendCSEnv env scrut' bndr') -- See Note [Case binders 2]
                                                             -- map: scrut' -> bndr'
249

250
    arg_tys = tyConAppArgs (idType bndr)
251

252
    cse_alt (DataAlt con, args, rhs)
253 254 255 256 257 258 259 260 261
        | 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
262 263
          new_env       = extendCSEnv env' con_expr con_target
          con_expr      = mkAltExpr (DataAlt con) args' arg_tys
264 265

    cse_alt (con, args, rhs)
266 267 268
        = (con, args', tryForCSE env' rhs)
        where
          (env', args') = addBinders alt_env args
269

Austin Seipp's avatar
Austin Seipp committed
270 271 272
{-
************************************************************************
*                                                                      *
273
\section{The CSE envt}
Austin Seipp's avatar
Austin Seipp committed
274 275 276
*                                                                      *
************************************************************************
-}
277

278
type InExpr  = CoreExpr         -- Pre-cloning
279 280 281
type InBndr  = CoreBndr
type InAlt   = CoreAlt

282
type OutExpr  = CoreExpr        -- Post-cloning
283 284
type OutBndr  = CoreBndr
type OutAlt   = CoreAlt
285

286
data CSEnv  = CS { cs_map    :: CoreMap (OutExpr, Id)   -- Key, value
287 288 289 290 291
                 , cs_subst  :: Subst }

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

292
lookupCSEnv :: CSEnv -> OutExpr -> Maybe Id
293
lookupCSEnv (CS { cs_map = csmap }) expr
294 295 296 297
  = case lookupCoreMap csmap expr of
      Just (_,e) -> Just e
      Nothing    -> Nothing

298 299
extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv
extendCSEnv cse expr id
Peter Wortmann's avatar
Peter Wortmann committed
300
  = cse { cs_map = extendCoreMap (cs_map cse) sexpr (sexpr,id) }
301
  where sexpr = stripTicksE tickishFloatable expr
302 303 304 305

csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst

306
lookupSubst :: CSEnv -> Id -> OutExpr
307
lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
308 309

extendCSSubst :: CSEnv -> Id  -> Id -> CSEnv
310
extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) }
311 312

addBinder :: CSEnv -> Var -> (CSEnv, Var)
313
addBinder cse v = (cse { cs_subst = sub' }, v')
314 315
                where
                  (sub', v') = substBndr (cs_subst cse) v
316 317

addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
318
addBinders cse vs = (cse { cs_subst = sub' }, vs')
319 320
                where
                  (sub', vs') = substBndrs (cs_subst cse) vs
321

322
addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
323
addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
324 325
                where
                  (sub', vs') = substRecBndrs (cs_subst cse) vs