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 )
  16 import Const            ( isBoxedDataCon )
  17 import Type             ( splitTyConApp_maybe )
  18 import CoreSyn
  19 import VarEnv
  20 import CoreLint         ( beginPass, endPass )
  21 import Outputable
  22 import Util             ( mapAccumL )
  23 import UniqFM
  24 \end{code}
  25
  26
  27                         Simple common sub-expression
  28                         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  29 When we see
  30         x1 = C a b
  31         x2 = C x1 b
  32 we build up a reverse mapping:   C a b  -> x1
  33                                  C x1 b -> x2
  34 and apply that to the rest of the program.
  35
  36 When we then see
  37         y1 = C a b
  38         y2 = C y1 b
  39 we replace the C a b with x1.  But then we *dont* want to
  40 add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
  41 so that a subsequent binding
  42         y2 = C y1 b
  43 will get transformed to C x1 b, and then to x2.
  44
  45 So we carry an extra var->var mapping which we apply *before* looking up in the
  46 reverse mapping.
  47
  48
  49 IMPORTANT NOTE
  50 ~~~~~~~~~~~~~~
  51 This pass relies on the no-shadowing invariant, so it must run
  52 immediately after the simplifier.
  53
  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!
  60
  61
  62 Another important wrinkle
  63 ~~~~~~~~~~~~~~~~~~~~~~~~~
  64 Consider
  65
  66         f = \x -> case x of wild {
  67                         (a:as) -> case a of wild1 {
  68                                     (p,q) -> ...(wild1:as)...
  69
  70 Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.
  71 But that's not quite obvious.  In general we want to keep it as (wild1:as),
  72 but for CSE purpose that's a bad idea.
  73
  74 So we add the binding (wild1 -> a) to the extra var->var mapping.
  75
  76
  77 Yet another wrinkle
  78 ~~~~~~~~~~~~~~~~~~~
  79 Consider
  80         case (h x) of y -> ...(h x)...
  81
  82 We'd like to replace (h x) in the alternative, by y.  But because of
  83 the preceding "Another important wrinkle", we only want to add the mapping
  84         scrutinee -> case binder
  85 to the CSE mapping if the scrutinee is a non-trivial expression.
  86
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \section{Common subexpression}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 \begin{code}
  95 cseProgram :: [CoreBind] -> IO [CoreBind]
  96
  97 cseProgram binds
  98   = do {
  99         beginPass "Common sub-expression";
 100         let { binds' = cseBinds emptyCSEnv binds };
 101         endPass "Common sub-expression"
 102                 (opt_D_dump_cse || opt_D_verbose_core2core)
 103                 binds'
 104     }
 105
 106 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
 107 cseBinds env []     = []
 108 cseBinds env (b:bs) = (b':bs')
 109                     where
 110                       (env1, b') = cseBind  env  b
 111                       bs'        = cseBinds env1 bs
 112
 113 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
 114 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
 115                            in (env', NonRec b e')
 116 cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env pairs
 117                            in (env', Rec pairs')
 118
 119
 120 do_one env (id, rhs) = case lookupCSEnv env rhs' of
 121                           Just other_id -> (extendSubst env id other_id, (id, Var other_id))
 122                           Nothing       -> (addCSEnvItem env id rhs',    (id, rhs'))
 123                      where
 124                         rhs' = cseExpr env rhs
 125
 126
 127 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 128 tryForCSE env (Type t) = Type t
 129 tryForCSE env expr     = case lookupCSEnv env expr' of
 130                             Just id  -> Var id
 131                             Nothing  -> expr'
 132                        where
 133                          expr' = cseExpr env expr
 134
 135
 136 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 137 cseExpr env (Var v)                = Var (lookupSubst env v)
 138 cseExpr env (App f (Type t))       = App (cseExpr env f) (Type t)
 139 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
 140 cseExpr env expr@(Con con args)    = case lookupCSEnv env expr of
 141                                        Just id  -> Var id
 142                                        Nothing  -> Con con [tryForCSE env arg | arg <- args]
 143 cseExpr env (Note n e)             = Note n (cseExpr env e)
 144 cseExpr env (Lam b e)              = Lam b (cseExpr env e)
 145 cseExpr env (Let bind e)           = let (env1, bind') = cseBind env bind
 146                                      in Let bind' (cseExpr env1 e)
 147 cseExpr env (Type t)               = Type t
 148 cseExpr env (Case scrut bndr alts) = Case scrut' bndr (cseAlts env scrut' bndr alts)
 149                                    where
 150                                      scrut' = tryForCSE env scrut
 151
 152
 153 cseAlts env new_scrut bndr alts
 154   = map cse_alt alts
 155   where
 156     (con_target, alt_env)
 157         = case new_scrut of
 158                 Var v -> (v,    extendSubst env bndr v)         -- See "another important wrinkle"
 159                                                                 -- map: bndr -> v
 160
 161                 other -> (bndr, extendCSEnv env bndr new_scrut) -- See "yet another wrinkle"
 162                                                                 -- map: new_scrut -> bndr
 163
 164     arg_tys = case splitTyConApp_maybe (idType bndr) of
 165                 Just (_, arg_tys) -> map Type arg_tys
 166                 other             -> pprPanic "cseAlts" (ppr bndr)
 167
 168     cse_alt (con, args, rhs)
 169         | null args || not (isBoxedDataCon con) = (con, args, cseExpr alt_env rhs)
 170                 -- Don't try CSE if there are no args; it just increases the number
 171                 -- of live vars.  E.g.
 172                 --      case x of { True -> ....True.... }
 173                 -- Don't replace True by x!
 174                 -- Hence the 'null args', which also deal with literals and DEFAULT
 175                 -- And we can't CSE on unboxed tuples
 176         | otherwise
 177         = (con, args, cseExpr (extendCSEnv alt_env con_target (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs)
 178 \end{code}
 179
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \section{The CSE envt}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 \begin{code}
 188 data CSEnv = CS (UniqFM [(Id, CoreExpr)])       -- The expr in the range has already been CSE'd
 189                 (IdEnv Id)                      -- Simple substitution
 190
 191 emptyCSEnv = CS emptyUFM emptyVarEnv
 192
 193 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
 194 lookupCSEnv (CS cs _) expr
 195   = case lookupUFM cs (hashExpr expr) of
 196         Nothing -> Nothing
 197         Just pairs -> lookup_list pairs expr
 198
 199 lookup_list :: [(Id,CoreExpr)] -> CoreExpr -> Maybe Id
 200 lookup_list [] expr = Nothing
 201 lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x
 202                             | otherwise          = lookup_list es expr
 203
 204 addCSEnvItem env id expr | exprIsBig expr = env
 205                          | otherwise      = extendCSEnv env id expr
 206
 207 extendCSEnv (CS cs sub) id expr
 208   = CS (addToUFM_C combine cs hash [(id, expr)]) sub
 209   where
 210     hash   = hashExpr expr
 211     combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
 212                       result
 213                     where
 214                       result = new ++ old
 215
 216 lookupSubst (CS _ sub) x = case lookupVarEnv sub x of
 217                              Just y  -> y
 218                              Nothing -> x
 219
 220 extendSubst (CS cs sub) x y = CS cs (extendVarEnv sub x y)
 221 \end{code}