ghc/compiler/simplCore/SAT.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[SAT]{Static Argument Transformation pass}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 May be seen as removing invariants from loops:
  11 Arguments of recursive functions that do not change in recursive
  12 calls are removed from the recursion, which is done locally
  13 and only passes the arguments which effectively change.
  14
  15 Example:
  16 map = /\ ab -> \f -> \xs -> case xs of
  17                              []    -> []
  18                              (a:b) -> f a : map f b
  19
  20 as map is recursively called with the same argument f (unmodified)
  21 we transform it to
  22
  23 map = /\ ab -> \f -> \xs -> let map' ys = case ys of
  24                                            []    -> []
  25                                            (a:b) -> f a : map' b
  26                             in map' xs
  27
  28 Notice that for a compiler that uses lambda lifting this is
  29 useless as map' will be transformed back to what map was.
  30
  31 We could possibly do the same for big lambdas, but we don't as
  32 they will eventually be removed in later stages of the compiler,
  33 therefore there is no penalty in keeping them.
  34
  35 Experimental Evidence: Heap: +/- 7%
  36                        Instrs: Always improves for 2 or more Static Args.
  37
  38 \begin{code}
  39 #include "HsVersions.h"
  40
  41 module SAT (
  42         doStaticArgs
  43
  44         -- and to make the interface self-sufficient...
  45     ) where
  46
  47 import Maybes           ( Maybe(..) )
  48 import SATMonad
  49 import Util
  50 \end{code}
  51
  52 \begin{code}
  53 doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
  54
  55 doStaticArgs binds
  56   = initSAT (mapSAT sat_bind binds)
  57   where
  58     sat_bind (NonRec binder expr)
  59       = emptyEnvSAT  `thenSAT_`
  60         satExpr expr `thenSAT` (\ expr' ->
  61         returnSAT (NonRec binder expr') )
  62     sat_bind (Rec [(binder,rhs)])
  63       = emptyEnvSAT                       `thenSAT_`
  64         insSAEnv binder (getArgLists rhs) `thenSAT_`
  65         satExpr rhs                       `thenSAT` (\ rhs' ->
  66         saTransform binder rhs')
  67     sat_bind (Rec pairs)
  68       = emptyEnvSAT             `thenSAT_`
  69         mapSAT satExpr rhss     `thenSAT` \ rhss' ->
  70         returnSAT (Rec (binders `zip` rhss'))
  71       where
  72         (binders, rhss) = unzip pairs
  73 \end{code}
  74
  75 \begin{code}
  76 satAtom (VarArg v)
  77   = updSAEnv (Just (v,([],[]))) `thenSAT_`
  78     returnSAT ()
  79
  80 satAtom _ = returnSAT ()
  81 \end{code}
  82
  83 \begin{code}
  84 satExpr :: CoreExpr -> SatM CoreExpr
  85
  86 satExpr var@(Var v)
  87   = updSAEnv (Just (v,([],[]))) `thenSAT_`
  88     returnSAT var
  89
  90 satExpr lit@(Lit _) = returnSAT lit
  91
  92 satExpr e@(Con con types args)
  93   = mapSAT satAtom args     `thenSAT_`
  94     returnSAT e
  95
  96 satExpr e@(Prim prim ty args)
  97   = mapSAT satAtom args     `thenSAT_`
  98     returnSAT e
  99
 100 satExpr (Lam binders body)
 101   = satExpr body                `thenSAT` \ body' ->
 102     returnSAT (Lam binders body')
 103
 104 satExpr (CoTyLam tyvar body)
 105   = satExpr body           `thenSAT` (\ body' ->
 106     returnSAT (CoTyLam tyvar body') )
 107
 108 satExpr app@(App _ _)
 109   = getAppArgs app
 110
 111 satExpr app@(CoTyApp _ _)
 112   = getAppArgs app
 113
 114 satExpr (Case expr alts)
 115   = satExpr expr        `thenSAT` \ expr' ->
 116     sat_alts alts       `thenSAT` \ alts' ->
 117     returnSAT (Case expr' alts')
 118   where
 119     sat_alts (AlgAlts alts deflt)
 120       = mapSAT satAlgAlt alts       `thenSAT` \ alts' ->
 121         sat_default deflt           `thenSAT` \ deflt' ->
 122         returnSAT (AlgAlts alts' deflt')
 123       where
 124         satAlgAlt (con, params, rhs)
 125           = satExpr rhs          `thenSAT` \ rhs' ->
 126             returnSAT (con, params, rhs')
 127
 128     sat_alts (PrimAlts alts deflt)
 129       = mapSAT satPrimAlt alts      `thenSAT` \ alts' ->
 130         sat_default deflt           `thenSAT` \ deflt' ->
 131         returnSAT (PrimAlts alts' deflt')
 132       where
 133         satPrimAlt (lit, rhs)
 134           = satExpr rhs `thenSAT` \ rhs' ->
 135             returnSAT (lit, rhs')
 136
 137     sat_default NoDefault
 138       = returnSAT NoDefault
 139     sat_default (BindDefault binder rhs)
 140       = satExpr rhs                  `thenSAT` \ rhs' ->
 141         returnSAT (BindDefault binder rhs')
 142
 143 satExpr (Let (NonRec binder rhs) body)
 144   = satExpr body                `thenSAT` \ body' ->
 145     satExpr rhs                 `thenSAT` \ rhs' ->
 146     returnSAT (Let (NonRec binder rhs') body')
 147
 148 satExpr (Let (Rec [(binder,rhs)]) body)
 149   = satExpr body                      `thenSAT` \ body' ->
 150     insSAEnv binder (getArgLists rhs) `thenSAT_`
 151     satExpr rhs                       `thenSAT` \ rhs' ->
 152     saTransform binder rhs'           `thenSAT` \ binding ->
 153     returnSAT (Let binding body')
 154
 155 satExpr (Let (Rec binds) body)
 156   = let
 157         (binders, rhss) = unzip binds
 158     in
 159     satExpr body                    `thenSAT` \ body' ->
 160     mapSAT satExpr rhss             `thenSAT` \ rhss' ->
 161     returnSAT (Let (Rec (binders `zip` rhss')) body')
 162
 163 satExpr (SCC cc expr)
 164   = satExpr expr                    `thenSAT` \ expr2 ->
 165     returnSAT (SCC cc expr2)
 166 \end{code}
 167
 168 \begin{code}
 169 getAppArgs :: CoreExpr -> SatM CoreExpr
 170
 171 getAppArgs app
 172   = get app             `thenSAT` \ (app',result) ->
 173     updSAEnv result     `thenSAT_`
 174     returnSAT app'
 175   where
 176     get :: CoreExpr
 177         -> SatM (CoreExpr, Maybe (Id, SATInfo))
 178
 179     get (CoTyApp e ty)
 180       = get e           `thenSAT` \ (e',result) ->
 181         returnSAT (
 182           CoTyApp e' ty,
 183           case result of
 184             Nothing          -> Nothing
 185             Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
 186         )
 187
 188     get (App e a)
 189       = get e           `thenSAT` \ (e', result) ->
 190         satAtom a       `thenSAT_`
 191         let si = case a of
 192                    (VarArg v) -> Static v
 193                    _             -> NotStatic
 194         in
 195           returnSAT (
 196             App e' a,
 197             case result of
 198                 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
 199                 Nothing          -> Nothing
 200           )
 201
 202     get var@(Var v)
 203       = returnSAT (var, Just (v,([],[])))
 204
 205     get e
 206       = satExpr e       `thenSAT` \ e2 ->
 207         returnSAT (e2, Nothing)
 208 \end{code}
 209