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