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 18
                        , exprIsTrivial
                        , stripTicks, 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

Peter Wortmann's avatar
Peter Wortmann committed
193 194 195 196 197 198
    (ticks, rhs'') = stripTicks tickishFloatable rhs'
    -- 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.

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

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

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

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

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

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

248
    arg_tys = tyConAppArgs (idType bndr)
249

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

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

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

276
type InExpr  = CoreExpr         -- Pre-cloning
277 278 279
type InBndr  = CoreBndr
type InAlt   = CoreAlt

280
type OutExpr  = CoreExpr        -- Post-cloning
281 282
type OutBndr  = CoreBndr
type OutAlt   = CoreAlt
283

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

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

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

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

csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst

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

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

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

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

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