ghc/compiler/simplCore/SAT.lhs

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