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 -> y  to the mapping.  Rather, we want the reverse, y -> x1
  41 so that a subsequent binding
  42         z = C y 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 x+x!
  60
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \section{Common subexpression}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 \begin{code}
  69 cseProgram :: [CoreBind] -> IO [CoreBind]
  70
  71 cseProgram binds
  72   = do {
  73         beginPass "Common sub-expression";
  74         let { binds' = cseBinds emptyCSEnv binds };
  75         endPass "Common sub-expression"
  76                 (opt_D_dump_cse || opt_D_verbose_core2core)
  77                 binds'
  78     }
  79
  80 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
  81 cseBinds env []     = []
  82 cseBinds env (b:bs) = (b':bs')
  83                     where
  84                       (env1, b') = cseBind  env  b
  85                       bs'        = cseBinds env1 bs
  86
  87 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
  88 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
  89                            in (env', NonRec b e')
  90 cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env pairs
  91                            in (env', Rec pairs')
  92
  93
  94 do_one env (id, rhs) = case lookupCSEnv env rhs' of
  95                           Just other_id -> (extendSubst env id other_id, (id, Var other_id))
  96                           Nothing       -> (addCSEnvItem env id rhs',    (id, rhs'))
  97                      where
  98                         rhs' = cseExpr env rhs
  99
 100
 101 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 102 tryForCSE env (Type t) = Type t
 103 tryForCSE env expr     = case lookupCSEnv env expr' of
 104                             Just id  -> Var id
 105                             Nothing  -> expr'
 106                        where
 107                          expr' = cseExpr env expr
 108
 109
 110 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 111 cseExpr env (Var v)                = Var (lookupSubst env v)
 112 cseExpr env (App f (Type t))       = App (cseExpr env f) (Type t)
 113 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
 114 cseExpr env expr@(Con con args)    = case lookupCSEnv env expr of
 115                                        Just id  -> Var id
 116                                        Nothing  -> Con con [tryForCSE env arg | arg <- args]
 117 cseExpr env (Note n e)             = Note n (cseExpr env e)
 118 cseExpr env (Lam b e)              = Lam b (cseExpr env e)
 119 cseExpr env (Let bind e)           = let (env1, bind') = cseBind env bind
 120                                      in Let bind' (cseExpr env1 e)
 121 cseExpr env (Type t)               = Type t
 122 cseExpr env (Case scrut bndr alts) = Case (tryForCSE env scrut) bndr (cseAlts env bndr alts)
 123
 124
 125 cseAlts env bndr alts
 126   = map cse_alt alts
 127   where
 128     arg_tys = case splitTyConApp_maybe (idType bndr) of
 129                 Just (_, arg_tys) -> map Type arg_tys
 130                 other             -> pprPanic "cseAlts" (ppr bndr)
 131
 132     cse_alt (con, args, rhs)
 133         | null args || not (isBoxedDataCon con) = (con, args, cseExpr env rhs)
 134                 -- Don't try CSE if there are no args; it just increases the number
 135                 -- of live vars.  E.g.
 136                 --      case x of { True -> ....True.... }
 137                 -- Don't replace True by x!
 138                 -- Hence the 'null args', which also deal with literals and DEFAULT
 139                 -- And we can't CSE on unboxed tuples
 140         | otherwise
 141         = (con, args, cseExpr (extendCSEnv env bndr (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs)
 142 \end{code}
 143
 144
 145 %************************************************************************
 146 %*                                                                      *
 147 \section{The CSE envt}
 148 %*                                                                      *
 149 %************************************************************************
 150
 151 \begin{code}
 152 data CSEnv = CS (UniqFM [(Id, CoreExpr)])       -- The expr in the range has already been CSE'd
 153                 (IdEnv Id)                      -- Simple substitution
 154
 155 emptyCSEnv = CS emptyUFM emptyVarEnv
 156
 157 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
 158 lookupCSEnv (CS cs _) expr
 159   = case lookupUFM cs (hashExpr expr) of
 160         Nothing -> Nothing
 161         Just pairs -> lookup_list pairs expr
 162
 163 lookup_list :: [(Id,CoreExpr)] -> CoreExpr -> Maybe Id
 164 lookup_list [] expr = Nothing
 165 lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x
 166                             | otherwise          = lookup_list es expr
 167
 168 addCSEnvItem env id expr | exprIsBig expr = env
 169                          | otherwise      = extendCSEnv env id expr
 170
 171 extendCSEnv (CS cs sub) id expr
 172   = CS (addToUFM_C combine cs hash [(id, expr)]) sub
 173   where
 174     hash   = hashExpr expr
 175     combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
 176                       result
 177                     where
 178                       result = new ++ old
 179
 180 lookupSubst (CS _ sub) x = case lookupVarEnv sub x of
 181                              Just y  -> y
 182                              Nothing -> x
 183
 184 extendSubst (CS cs sub) x y = CS cs (extendVarEnv sub x y)
 185 \end{code}