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