ghc/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 CmdLineOpts      ( DynFlag(..), DynFlags )
  14 import Id               ( Id, idType, idWorkerInfo )
  15 import IdInfo           ( workerExists )
  16 import CoreUtils        ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
  17 import DataCon          ( isUnboxedTupleCon )
  18 import Type             ( tyConAppArgs )
  19 import CoreSyn
  20 import VarEnv
  21 import CoreLint         ( showPass, endPass )
  22 import Outputable
  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
 111 %************************************************************************
 112 %*                                                                      *
 113 \section{Common subexpression}
 114 %*                                                                      *
 115 %************************************************************************
 116
 117 \begin{code}
 118 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
 119
 120 cseProgram dflags binds
 121   = do {
 122         showPass dflags "Common sub-expression";
 123         let { binds' = cseBinds emptyCSEnv binds };
 124         endPass dflags "Common sub-expression"  Opt_D_dump_cse binds'
 125     }
 126
 127 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
 128 cseBinds env []     = []
 129 cseBinds env (b:bs) = (b':bs')
 130                     where
 131                       (env1, b') = cseBind  env  b
 132                       bs'        = cseBinds env1 bs
 133
 134 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
 135 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
 136                            in (env', NonRec b e')
 137 cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env pairs
 138                            in (env', Rec pairs')
 139
 140
 141 do_one env (id, rhs)
 142   = case lookupCSEnv env rhs' of
 143         Just (Var other_id) -> (extendSubst env' id other_id,     (id', Var other_id))
 144         Just other_expr     -> (env',                             (id', other_expr))
 145         Nothing             -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
 146   where
 147     (env', id') = addBinder env id
 148     rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs
 149
 150                 -- Hack alert: don't do CSE on wrapper RHSs.
 151                 -- Otherwise we find:
 152                 --      $wf = h
 153                 --      f = \x -> ...$wf...
 154                 -- ===>
 155                 --      f = \x -> ...h...
 156                 -- But the WorkerInfo for f still says $wf, which is now dead!
 157           | otherwise = rhs
 158
 159
 160 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 161 tryForCSE env (Type t) = Type t
 162 tryForCSE env expr     = case lookupCSEnv env expr' of
 163                             Just smaller_expr -> smaller_expr
 164                             Nothing           -> expr'
 165                        where
 166                          expr' = cseExpr env expr
 167
 168 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 169 cseExpr env (Type t)               = Type t
 170 cseExpr env (Lit lit)              = Lit lit
 171 cseExpr env (Var v)                = Var (lookupSubst env v)
 172 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
 173 cseExpr env (Note n e)             = Note n (cseExpr env e)
 174 cseExpr env (Lam b e)              = let (env', b') = addBinder env b
 175                                      in Lam b' (cseExpr env' e)
 176 cseExpr env (Let bind e)           = let (env', bind') = cseBind env bind
 177                                      in Let bind' (cseExpr env' e)
 178 -- gaw 2004
 179 cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
 180                                    where
 181                                      scrut' = tryForCSE env scrut
 182                                      (env', bndr') = addBinder env bndr
 183
 184
 185 cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
 186   | isUnboxedTupleCon con
 187         -- Unboxed tuples are special because the case binder isn't
 188         -- a real values.  See [Note: unboxed tuple case binders]
 189   = [(DataAlt con, args', tryForCSE new_env rhs)]
 190   where
 191     (env', args') = addBinders env args
 192     new_env | exprIsCheap scrut' = env'
 193             | otherwise          = extendCSEnv env' scrut' tup_value
 194     tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
 195
 196 cseAlts env scrut' bndr bndr' alts
 197   = map cse_alt alts
 198   where
 199     (con_target, alt_env)
 200         = case scrut' of
 201                 Var v' -> (v',    extendSubst env bndr v')      -- See [Note: case binder 1]
 202                                                                 -- map: bndr -> v'
 203
 204                 other ->  (bndr', extendCSEnv env scrut' (Var  bndr'))  -- See [Note: case binder 2]
 205                                                                         -- map: scrut' -> bndr'
 206
 207     arg_tys = tyConAppArgs (idType bndr)
 208
 209     cse_alt (DataAlt con, args, rhs)
 210         | not (null args)
 211                 -- Don't try CSE if there are no args; it just increases the number
 212                 -- of live vars.  E.g.
 213                 --      case x of { True -> ....True.... }
 214                 -- Don't replace True by x!
 215                 -- Hence the 'null args', which also deal with literals and DEFAULT
 216         = (DataAlt con, args', tryForCSE new_env rhs)
 217         where
 218           (env', args') = addBinders alt_env args
 219           new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
 220                                            (Var con_target)
 221
 222     cse_alt (con, args, rhs)
 223         = (con, args', tryForCSE env' rhs)
 224         where
 225           (env', args') = addBinders alt_env args
 226 \end{code}
 227
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \section{The CSE envt}
 232 %*                                                                      *
 233 %************************************************************************
 234
 235 \begin{code}
 236 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
 237                         -- Simple substitution
 238
 239 type CSEMap = UniqFM [(CoreExpr, CoreExpr)]     -- This is the reverse mapping
 240         -- It maps the hash-code of an expression e to list of (e,e') pairs
 241         -- This means that it's good to replace e by e'
 242         -- INVARIANT: The expr in the range has already been CSE'd
 243
 244 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 245
 246 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
 247 lookupCSEnv (CS cs _ _) expr
 248   = case lookupUFM cs (hashExpr expr) of
 249         Nothing -> Nothing
 250         Just pairs -> lookup_list pairs expr
 251
 252 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
 253 lookup_list [] expr = Nothing
 254 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
 255                              | otherwise          = lookup_list es expr
 256
 257 addCSEnvItem env expr expr' | exprIsBig expr = env
 258                             | otherwise      = extendCSEnv env expr expr'
 259    -- We don't try to CSE big expressions, because they are expensive to compare
 260    -- (and are unlikely to be the same anyway)
 261
 262 extendCSEnv (CS cs in_scope sub) expr expr'
 263   = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
 264   where
 265     hash   = hashExpr expr
 266     combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
 267                       result
 268                     where
 269                       result = new ++ old
 270
 271 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
 272                                Just y  -> y
 273                                Nothing -> x
 274
 275 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
 276
 277 addBinder :: CSEnv -> Id -> (CSEnv, Id)
 278 addBinder env@(CS cs in_scope sub) v
 279   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                     v)
 280   | isId v                            = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
 281   | not (isId v)                      = WARN( True, ppr v )
 282                                         (CS emptyUFM in_scope                 sub,                     v)
 283         -- This last case is the unusual situation where we have shadowing of
 284         -- a type variable; we have to discard the CSE mapping
 285         -- See "IMPORTANT NOTE" at the top
 286   where
 287     v' = uniqAway in_scope v
 288
 289 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
 290 addBinders env vs = mapAccumL addBinder env vs
 291 \end{code}