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