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            ( Con(..) )
  17 import DataCon          ( isUnboxedTupleCon )
  18 import Type             ( splitTyConApp_maybe )
  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 -> y  to the mapping.  Rather, we want the reverse, y -> x1
  42 so that a subsequent binding
  43         z = C y b
  44 will get transformed to C x1 b, and then to x2.
  45
  46 So we carry an extra var->var mapping which we apply before looking up in the
  47 reverse mapping.
  48
  49
  50 IMPORTANT NOTE
  51 ~~~~~~~~~~~~~~
  52 This pass relies on the no-shadowing invariant, so it must run
  53 immediately after the simplifier.
  54
  55 For example, consider
  56         f = \x -> let y = x+x in
  57                       h = \x -> x+x
  58                   in ...
  59
  60 Here we must *not* do CSE on the x+x!
  61
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \section{Common subexpression}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 cseProgram :: [CoreBind] -> IO [CoreBind]
  71
  72 cseProgram binds
  73   = do {
  74         beginPass "Common sub-expression";
  75         let { binds' = cseBinds emptyCSEnv binds };
  76         endPass "Common sub-expression"
  77                 (opt_D_dump_cse || opt_D_verbose_core2core)
  78                 binds'
  79     }
  80
  81 cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
  82 cseBinds env []     = []
  83 cseBinds env (b:bs) = (b':bs')
  84                     where
  85                       (env1, b') = cseBind  env  b
  86                       bs'        = cseBinds env1 bs
  87
  88 cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
  89 cseBind env (NonRec b e) = let (env', (_,e')) = do_one env (b, e)
  90                            in (env', NonRec b e')
  91 cseBind env (Rec pairs)  = let (env', pairs') = mapAccumL do_one env pairs
  92                            in (env', Rec pairs')
  93
  94
  95 do_one env (id, rhs) = case lookupCSEnv env rhs' of
  96                           Just other_id -> (extendSubst env id other_id, (id, Var other_id))
  97                           Nothing       -> (addCSEnvItem env id rhs',    (id, rhs'))
  98                      where
  99                         rhs' = cseExpr env rhs
 100
 101
 102 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 103 tryForCSE env (Type t) = Type t
 104 tryForCSE env expr     = case lookupCSEnv env expr' of
 105                             Just id  -> Var id
 106                             Nothing  -> expr'
 107                        where
 108                          expr' = cseExpr env expr
 109
 110
 111 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 112 cseExpr env (Var v)                = Var (lookupSubst env v)
 113 cseExpr env (App f (Type t))       = App (cseExpr env f) (Type t)
 114 cseExpr env (App f a)              = App (cseExpr env f) (tryForCSE env a)
 115 cseExpr env expr@(Con con args)    = case lookupCSEnv env expr of
 116                                        Just id  -> Var id
 117                                        Nothing  -> Con con [tryForCSE env arg | arg <- args]
 118 cseExpr env (Note n e)             = Note n (cseExpr env e)
 119 cseExpr env (Lam b e)              = Lam b (cseExpr env e)
 120 cseExpr env (Let bind e)           = let (env1, bind') = cseBind env bind
 121                                      in Let bind' (cseExpr env1 e)
 122 cseExpr env (Type t)               = Type t
 123 cseExpr env (Case scrut bndr alts) = Case (tryForCSE env scrut) bndr (cseAlts env bndr alts)
 124
 125
 126 cseAlts env bndr alts
 127   = map cse_alt alts
 128   where
 129     arg_tys = case splitTyConApp_maybe (idType bndr) of
 130                 Just (_, arg_tys) -> map Type arg_tys
 131                 other             -> pprPanic "cseAlts" (ppr bndr)
 132
 133     cse_alt (con, args, rhs)
 134         | ok_for_cse con = (con, args, cseExpr (extendCSEnv env bndr (Con con (arg_tys ++ (map varToCoreExpr args)))) rhs)
 135         | otherwise      = (con, args, cseExpr env rhs)
 136
 137     ok_for_cse DEFAULT      = False
 138     ok_for_cse (Literal l)  = True
 139     ok_for_cse (DataCon dc) = not (isUnboxedTupleCon dc)
 140         -- Unboxed tuples aren't shared
 141 \end{code}
 142
 143
 144 %************************************************************************
 145 %*                                                                      *
 146 \section{The CSE envt}
 147 %*                                                                      *
 148 %************************************************************************
 149
 150 \begin{code}
 151 data CSEnv = CS (UniqFM [(Id, CoreExpr)])       -- The expr in the range has already been CSE'd
 152                 (IdEnv Id)                      -- Simple substitution
 153
 154 emptyCSEnv = CS emptyUFM emptyVarEnv
 155
 156 lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
 157 lookupCSEnv (CS cs _) expr
 158   = case lookupUFM cs (hashExpr expr) of
 159         Nothing -> Nothing
 160         Just pairs -> lookup_list pairs expr
 161
 162 lookup_list :: [(Id,CoreExpr)] -> CoreExpr -> Maybe Id
 163 lookup_list [] expr = Nothing
 164 lookup_list ((x,e):es) expr | cheapEqExpr e expr = Just x
 165                             | otherwise          = lookup_list es expr
 166
 167 addCSEnvItem env id expr | exprIsBig expr = env
 168                          | otherwise      = extendCSEnv env id expr
 169
 170 extendCSEnv (CS cs sub) id expr
 171   = CS (addToUFM_C combine cs hash [(id, expr)]) sub
 172   where
 173     hash   = hashExpr expr
 174     combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
 175                       result
 176                     where
 177                       result = new ++ old
 178
 179 lookupSubst (CS _ sub) x = case lookupVarEnv sub x of
 180                              Just y  -> y
 181                              Nothing -> x
 182
 183 extendSubst (CS cs sub) x y = CS cs (extendVarEnv sub x y)
 184 \end{code}