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