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 [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 transoform 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 env []     = []
 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 env (id, rhs)
 204   = case lookupCSEnv env rhs' of
 205         Just (Var other_id) -> (extendSubst env' id other_id,     (id', Var other_id))
 206         Just other_expr     -> (env',                             (id', other_expr))
 207         Nothing             -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
 208   where
 209     (env', id') = addBinder env id
 210     rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
 211          | otherwise                          = rhs
 212                 -- See Note [INLINE and NOINLINE]
 213
 214 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 215 tryForCSE env (Type t) = Type t
 216 tryForCSE env expr     = case lookupCSEnv env expr' of
 217                             Just smaller_expr -> smaller_expr
 218                             Nothing           -> expr'
 219                        where
 220                          expr' = cseExpr env expr
 221
 222 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 223 cseExpr env (Type t)               = Type t
 224 cseExpr env (Lit lit)              = Lit lit
 225 cseExpr env (Var v)                = Var (lookupSubst env v)
 226 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
 227 cseExpr evn (Note InlineMe e)      = Note InlineMe e    -- See Note [INLINE and NOINLINE]
 228 cseExpr env (Note n e)             = Note n (cseExpr env e)
 229 cseExpr env (Cast e co)            = Cast (cseExpr env e) co
 230 cseExpr env (Lam b e)              = let (env', b') = addBinder env b
 231                                      in Lam b' (cseExpr env' e)
 232 cseExpr env (Let bind e)           = let (env', bind') = cseBind env bind
 233                                      in Let bind' (cseExpr env' e)
 234 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
 235                                    where
 236                                      scrut' = tryForCSE env scrut
 237                                      (env', bndr') = addBinder env bndr
 238
 239
 240 cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
 241   | isUnboxedTupleCon con
 242         -- Unboxed tuples are special because the case binder isn't
 243         -- a real values.  See [Note: unboxed tuple case binders]
 244   = [(DataAlt con, args', tryForCSE new_env rhs)]
 245   where
 246     (env', args') = addBinders env args
 247     new_env | exprIsCheap scrut' = env'
 248             | otherwise          = extendCSEnv env' scrut' tup_value
 249     tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
 250
 251 cseAlts env scrut' bndr bndr' alts
 252   = map cse_alt alts
 253   where
 254     (con_target, alt_env)
 255         = case scrut' of
 256                 Var v' -> (v',    extendSubst env bndr v')      -- See [Note: case binder 1]
 257                                                                 -- map: bndr -> v'
 258
 259                 other ->  (bndr', extendCSEnv env scrut' (Var  bndr'))  -- See [Note: case binder 2]
 260                                                                         -- map: scrut' -> bndr'
 261
 262     arg_tys = tyConAppArgs (idType bndr)
 263
 264     cse_alt (DataAlt con, args, rhs)
 265         | not (null args)
 266                 -- Don't try CSE if there are no args; it just increases the number
 267                 -- of live vars.  E.g.
 268                 --      case x of { True -> ....True.... }
 269                 -- Don't replace True by x!
 270                 -- Hence the 'null args', which also deal with literals and DEFAULT
 271         = (DataAlt con, args', tryForCSE new_env rhs)
 272         where
 273           (env', args') = addBinders alt_env args
 274           new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
 275                                            (Var con_target)
 276
 277     cse_alt (con, args, rhs)
 278         = (con, args', tryForCSE env' rhs)
 279         where
 280           (env', args') = addBinders alt_env args
 281 \end{code}
 282
 283
 284 %************************************************************************
 285 %*                                                                      *
 286 \section{The CSE envt}
 287 %*                                                                      *
 288 %************************************************************************
 289
 290 \begin{code}
 291 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
 292                         -- Simple substitution
 293
 294 type CSEMap = UniqFM [(CoreExpr, CoreExpr)]     -- This is the reverse mapping
 295         -- It maps the hash-code of an expression e to list of (e,e') pairs
 296         -- This means that it's good to replace e by e'
 297         -- INVARIANT: The expr in the range has already been CSE'd
 298
 299 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 300
 301 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
 302 lookupCSEnv (CS cs _ _) expr
 303   = case lookupUFM cs (hashExpr expr) of
 304         Nothing -> Nothing
 305         Just pairs -> lookup_list pairs expr
 306
 307 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
 308 lookup_list [] expr = Nothing
 309 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
 310                              | otherwise          = lookup_list es expr
 311
 312 addCSEnvItem env expr expr' | exprIsBig expr = env
 313                             | otherwise      = extendCSEnv env expr expr'
 314    -- We don't try to CSE big expressions, because they are expensive to compare
 315    -- (and are unlikely to be the same anyway)
 316
 317 extendCSEnv (CS cs in_scope sub) expr expr'
 318   = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
 319   where
 320     hash = hashExpr expr
 321     combine old new
 322         = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
 323         where
 324           result = new ++ old
 325           short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result)
 326           long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
 327                    | otherwise          = empty
 328
 329 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
 330                                Just y  -> y
 331                                Nothing -> x
 332
 333 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
 334
 335 addBinder :: CSEnv -> Id -> (CSEnv, Id)
 336 addBinder env@(CS cs in_scope sub) v
 337   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                     v)
 338   | isId v                            = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
 339   | otherwise                         = WARN( True, ppr v )
 340                                         (CS emptyUFM in_scope                 sub,                     v)
 341         -- This last case is the unusual situation where we have shadowing of
 342         -- a type variable; we have to discard the CSE mapping
 343         -- See "IMPORTANT NOTE" at the top
 344   where
 345     v' = uniqAway in_scope v
 346
 347 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
 348 addBinders env vs = mapAccumL addBinder env vs
 349 \end{code}