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