ghc/compiler/simplCore/SAT.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 #include "HsVersions.h"
  42
  43 module SAT ( doStaticArgs ) where
  44
  45 IMP_Ubiq(){-uitous-}
  46 import Util             ( panic )
  47
  48 doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
  49
  50 {- LATER: to end of file:
  51
  52 import SATMonad
  53 import Util
  54 \end{code}
  55
  56 \begin{code}
  57 doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
  58
  59 doStaticArgs binds
  60   = initSAT (mapSAT sat_bind binds)
  61   where
  62     sat_bind (NonRec binder expr)
  63       = emptyEnvSAT  `thenSAT_`
  64         satExpr expr `thenSAT` (\ expr' ->
  65         returnSAT (NonRec binder expr') )
  66     sat_bind (Rec [(binder,rhs)])
  67       = emptyEnvSAT                       `thenSAT_`
  68         insSAEnv binder (getArgLists rhs) `thenSAT_`
  69         satExpr rhs                       `thenSAT` (\ rhs' ->
  70         saTransform binder rhs')
  71     sat_bind (Rec pairs)
  72       = emptyEnvSAT             `thenSAT_`
  73         mapSAT satExpr rhss     `thenSAT` \ rhss' ->
  74         returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
  75       where
  76         (binders, rhss) = unzip pairs
  77 \end{code}
  78
  79 \begin{code}
  80 satAtom (VarArg v)
  81   = updSAEnv (Just (v,([],[]))) `thenSAT_`
  82     returnSAT ()
  83
  84 satAtom _ = returnSAT ()
  85 \end{code}
  86
  87 \begin{code}
  88 satExpr :: CoreExpr -> SatM CoreExpr
  89
  90 satExpr var@(Var v)
  91   = updSAEnv (Just (v,([],[]))) `thenSAT_`
  92     returnSAT var
  93
  94 satExpr lit@(Lit _) = returnSAT lit
  95
  96 satExpr e@(Con con types args)
  97   = mapSAT satAtom args     `thenSAT_`
  98     returnSAT e
  99
 100 satExpr e@(Prim prim ty args)
 101   = mapSAT satAtom args     `thenSAT_`
 102     returnSAT e
 103
 104 satExpr (Lam binders body)
 105   = satExpr body                `thenSAT` \ body' ->
 106     returnSAT (Lam binders body')
 107
 108 satExpr (CoTyLam tyvar body)
 109   = satExpr body           `thenSAT` (\ body' ->
 110     returnSAT (CoTyLam tyvar body') )
 111
 112 satExpr app@(App _ _)
 113   = getAppArgs app
 114
 115 satExpr app@(CoTyApp _ _)
 116   = getAppArgs app
 117
 118 satExpr (Case expr alts)
 119   = satExpr expr        `thenSAT` \ expr' ->
 120     sat_alts alts       `thenSAT` \ alts' ->
 121     returnSAT (Case expr' alts')
 122   where
 123     sat_alts (AlgAlts alts deflt)
 124       = mapSAT satAlgAlt alts       `thenSAT` \ alts' ->
 125         sat_default deflt           `thenSAT` \ deflt' ->
 126         returnSAT (AlgAlts alts' deflt')
 127       where
 128         satAlgAlt (con, params, rhs)
 129           = satExpr rhs          `thenSAT` \ rhs' ->
 130             returnSAT (con, params, rhs')
 131
 132     sat_alts (PrimAlts alts deflt)
 133       = mapSAT satPrimAlt alts      `thenSAT` \ alts' ->
 134         sat_default deflt           `thenSAT` \ deflt' ->
 135         returnSAT (PrimAlts alts' deflt')
 136       where
 137         satPrimAlt (lit, rhs)
 138           = satExpr rhs `thenSAT` \ rhs' ->
 139             returnSAT (lit, rhs')
 140
 141     sat_default NoDefault
 142       = returnSAT NoDefault
 143     sat_default (BindDefault binder rhs)
 144       = satExpr rhs                  `thenSAT` \ rhs' ->
 145         returnSAT (BindDefault binder rhs')
 146
 147 satExpr (Let (NonRec binder rhs) body)
 148   = satExpr body                `thenSAT` \ body' ->
 149     satExpr rhs                 `thenSAT` \ rhs' ->
 150     returnSAT (Let (NonRec binder rhs') body')
 151
 152 satExpr (Let (Rec [(binder,rhs)]) body)
 153   = satExpr body                      `thenSAT` \ body' ->
 154     insSAEnv binder (getArgLists rhs) `thenSAT_`
 155     satExpr rhs                       `thenSAT` \ rhs' ->
 156     saTransform binder rhs'           `thenSAT` \ binding ->
 157     returnSAT (Let binding body')
 158
 159 satExpr (Let (Rec binds) body)
 160   = let
 161         (binders, rhss) = unzip binds
 162     in
 163     satExpr body                    `thenSAT` \ body' ->
 164     mapSAT satExpr rhss             `thenSAT` \ rhss' ->
 165     returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
 166
 167 satExpr (SCC cc expr)
 168   = satExpr expr                    `thenSAT` \ expr2 ->
 169     returnSAT (SCC cc expr2)
 170
 171 satExpr (Coerce c ty expr)
 172   = satExpr expr                    `thenSAT` \ expr2 ->
 173     returnSAT (Coerce c ty expr2)
 174 \end{code}
 175
 176 \begin{code}
 177 getAppArgs :: CoreExpr -> SatM CoreExpr
 178
 179 getAppArgs app
 180   = get app             `thenSAT` \ (app',result) ->
 181     updSAEnv result     `thenSAT_`
 182     returnSAT app'
 183   where
 184     get :: CoreExpr
 185         -> SatM (CoreExpr, Maybe (Id, SATInfo))
 186
 187     get (CoTyApp e ty)
 188       = get e           `thenSAT` \ (e',result) ->
 189         returnSAT (
 190           CoTyApp e' ty,
 191           case result of
 192             Nothing          -> Nothing
 193             Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
 194         )
 195
 196     get (App e a)
 197       = get e           `thenSAT` \ (e', result) ->
 198         satAtom a       `thenSAT_`
 199         let si = case a of
 200                    (VarArg v) -> Static v
 201                    _             -> NotStatic
 202         in
 203           returnSAT (
 204             App e' a,
 205             case result of
 206                 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
 207                 Nothing          -> Nothing
 208           )
 209
 210     get var@(Var v)
 211       = returnSAT (var, Just (v,([],[])))
 212
 213     get e
 214       = satExpr e       `thenSAT` \ e2 ->
 215         returnSAT (e2, Nothing)
 216 -}
 217 \end{code}