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