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 Subst            ( InScopeSet, uniqAway, emptyInScopeSet,
  20                           extendInScopeSet, elemInScopeSet )
  21 import CoreSyn
  22 import VarEnv
  23 import CoreLint         ( showPass, endPass )
  24 import Outputable
  25 import Util             ( mapAccumL, lengthExceeds )
  26 import UniqFM
  27 \end{code}
  28
  29
  30                         Simple common sub-expression
  31                         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  32 When we see
  33         x1 = C a b
  34         x2 = C x1 b
  35 we build up a reverse mapping:   C a b  -> x1
  36                                  C x1 b -> x2
  37 and apply that to the rest of the program.
  38
  39 When we then see
  40         y1 = C a b
  41         y2 = C y1 b
  42 we replace the C a b with x1.  But then we *dont* want to
  43 add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
  44 so that a subsequent binding
  45         y2 = C y1 b
  46 will get transformed to C x1 b, and then to x2.
  47
  48 So we carry an extra var->var substitution which we apply *before* looking up in the
  49 reverse mapping.
  50
  51
  52 [Note: SHADOWING]
  53 ~~~~~~~~~~~~~~~~~
  54 We have to be careful about shadowing.
  55 For example, consider
  56         f = \x -> let y = x+x in
  57                       h = \x -> x+x
  58                   in ...
  59
  60 Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
  61 shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
  62 We can simply add clones to the substitution already described.
  63
  64 However, we do NOT clone type variables.  It's just too hard, because then we need
  65 to run the substitution over types and IdInfo.  No no no.  Instead, we just throw
  66
  67 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
  68
  69
  70 [Note: case binders 1]
  71 ~~~~~~~~~~~~~~~~~~~~~~
  72 Consider
  73
  74         f = \x -> case x of wild {
  75                         (a:as) -> case a of wild1 {
  76                                     (p,q) -> ...(wild1:as)...
  77
  78 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
  79 But that's not quite obvious.  In general we want to keep it as (wild1:as),
  80 but for CSE purpose that's a bad idea.
  81
  82 So we add the binding (wild1 -> a) to the extra var->var mapping.
  83 Notice this is exactly backwards to what the simplifier does, which is
  84 to try to replaces uses of a with uses of wild1
  85
  86 [Note: case binders 2]
  87 ~~~~~~~~~~~~~~~~~~~~~~
  88 Consider
  89         case (h x) of y -> ...(h x)...
  90
  91 We'd like to replace (h x) in the alternative, by y.  But because of
  92 the preceding [Note: case binders 1], we only want to add the mapping
  93         scrutinee -> case binder
  94 to the reverse CSE mapping if the scrutinee is a non-trivial expression.
  95 (If the scrutinee is a simple variable we want to add the mapping
  96         case binder -> scrutinee
  97 to the substitution
  98
  99 [Note: unboxed tuple case binders]
 100 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 101 Consider
 102         case f x of t { (# a,b #) ->
 103         case ... of
 104           True -> f x
 105           False -> 0 }
 106
 107 We must not replace (f x) by t, because t is an unboxed-tuple binder.
 108 Instead, we shoudl replace (f x) by (# a,b #).  That is, the "reverse mapping" is
 109         f x --> (# a,b #)
 110 That is why the CSEMap has pairs of expressions.
 111
 112
 113 %************************************************************************
 114 %*                                                                      *
 115 \section{Common subexpression}
 116 %*                                                                      *
 117 %************************************************************************
 118
 119 \begin{code}
 120 cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
 121
 122 cseProgram dflags binds
 123   = do {
 124         showPass dflags "Common sub-expression";
 125         let { binds' = cseBinds emptyCSEnv binds };
 126         endPass dflags "Common sub-expression"  Opt_D_dump_cse binds'
 127     }
 128
 129 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
 130 cseBinds env []     = []
 131 cseBinds env (b:bs) = (b':bs')
 132                     where
 133                       (env1, b') = cseBind  env  b
 134                       bs'        = cseBinds env1 bs
 135
 136 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
 137 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
 138                            in (env', NonRec b e')
 139 cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env pairs
 140                            in (env', Rec pairs')
 141
 142
 143 do_one env (id, rhs)
 144   = case lookupCSEnv env rhs' of
 145         Just (Var other_id) -> (extendSubst env' id other_id,     (id', Var other_id))
 146         Just other_expr     -> (env',                             (id', other_expr))
 147         Nothing             -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
 148   where
 149     (env', id') = addBinder env id
 150     rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs
 151
 152                 -- Hack alert: don't do CSE on wrapper RHSs.
 153                 -- Otherwise we find:
 154                 --      $wf = h
 155                 --      f = \x -> ...$wf...
 156                 -- ===>
 157                 --      f = \x -> ...h...
 158                 -- But the WorkerInfo for f still says $wf, which is now dead!
 159           | otherwise = rhs
 160
 161
 162 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 163 tryForCSE env (Type t) = Type t
 164 tryForCSE env expr     = case lookupCSEnv env expr' of
 165                             Just smaller_expr -> smaller_expr
 166                             Nothing           -> expr'
 167                        where
 168                          expr' = cseExpr env expr
 169
 170 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 171 cseExpr env (Type t)               = Type t
 172 cseExpr env (Lit lit)              = Lit lit
 173 cseExpr env (Var v)                = Var (lookupSubst env v)
 174 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
 175 cseExpr env (Note n e)             = Note n (cseExpr env e)
 176 cseExpr env (Lam b e)              = let (env', b') = addBinder env b
 177                                      in Lam b' (cseExpr env' e)
 178 cseExpr env (Let bind e)           = let (env', bind') = cseBind env bind
 179                                      in Let bind' (cseExpr env' e)
 180 cseExpr env (Case scrut bndr alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts)
 181                                    where
 182                                      scrut' = tryForCSE env scrut
 183                                      (env', bndr') = addBinder env bndr
 184
 185
 186 cseAlts env scrut' bndr bndr' [(DataAlt con, args, rhs)]
 187   | isUnboxedTupleCon con
 188         -- Unboxed tuples are special because the case binder isn't
 189         -- a real values.  See [Note: unboxed tuple case binders]
 190   = [(DataAlt con, args', tryForCSE new_env rhs)]
 191   where
 192     (env', args') = addBinders env args
 193     new_env | exprIsCheap scrut' = env'
 194             | otherwise          = extendCSEnv env' scrut' tup_value
 195     tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
 196
 197 cseAlts env scrut' bndr bndr' alts
 198   = map cse_alt alts
 199   where
 200     (con_target, alt_env)
 201         = case scrut' of
 202                 Var v' -> (v',    extendSubst env bndr v')      -- See [Note: case binder 1]
 203                                                                 -- map: bndr -> v'
 204
 205                 other ->  (bndr', extendCSEnv env scrut' (Var  bndr'))  -- See [Note: case binder 2]
 206                                                                         -- map: scrut' -> bndr'
 207
 208     arg_tys = tyConAppArgs (idType bndr)
 209
 210     cse_alt (DataAlt con, args, rhs)
 211         | not (null args)
 212                 -- Don't try CSE if there are no args; it just increases the number
 213                 -- of live vars.  E.g.
 214                 --      case x of { True -> ....True.... }
 215                 -- Don't replace True by x!
 216                 -- Hence the 'null args', which also deal with literals and DEFAULT
 217         = (DataAlt con, args', tryForCSE new_env rhs)
 218         where
 219           (env', args') = addBinders alt_env args
 220           new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys)
 221                                            (Var con_target)
 222
 223     cse_alt (con, args, rhs)
 224         = (con, args', tryForCSE env' rhs)
 225         where
 226           (env', args') = addBinders alt_env args
 227 \end{code}
 228
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \section{The CSE envt}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 \begin{code}
 237 data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
 238                         -- Simple substitution
 239
 240 type CSEMap = UniqFM [(CoreExpr, CoreExpr)]     -- This is the reverse mapping
 241         -- It maps the hash-code of an expression e to list of (e,e') pairs
 242         -- This means that it's good to replace e by e'
 243         -- INVARIANT: The expr in the range has already been CSE'd
 244
 245 emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
 246
 247 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr
 248 lookupCSEnv (CS cs _ _) expr
 249   = case lookupUFM cs (hashExpr expr) of
 250         Nothing -> Nothing
 251         Just pairs -> lookup_list pairs expr
 252
 253 lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr
 254 lookup_list [] expr = Nothing
 255 lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e'
 256                              | otherwise          = lookup_list es expr
 257
 258 addCSEnvItem env expr expr' | exprIsBig expr = env
 259                             | otherwise      = extendCSEnv env expr expr'
 260    -- We don't try to CSE big expressions, because they are expensive to compare
 261    -- (and are unlikely to be the same anyway)
 262
 263 extendCSEnv (CS cs in_scope sub) expr expr'
 264   = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
 265   where
 266     hash   = hashExpr expr
 267     combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
 268                       result
 269                     where
 270                       result = new ++ old
 271
 272 lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
 273                                Just y  -> y
 274                                Nothing -> x
 275
 276 extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
 277
 278 addBinder :: CSEnv -> Id -> (CSEnv, Id)
 279 addBinder env@(CS cs in_scope sub) v
 280   | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v)  sub,                     v)
 281   | isId v                            = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
 282   | not (isId v)                      = WARN( True, ppr v )
 283                                         (CS emptyUFM in_scope                 sub,                     v)
 284         -- This last case is the unusual situation where we have shadowing of
 285         -- a type variable; we have to discard the CSE mapping
 286         -- See "IMPORTANT NOTE" at the top
 287   where
 288     v' = uniqAway in_scope v
 289
 290 addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
 291 addBinders env vs = mapAccumL addBinder env vs
 292 \end{code}