compiler/simplCore/CSE.lhs

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