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