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 Maybes           ( Maybe(..) )
  53 import SATMonad
  54 import Util
  55 \end{code}
  56
  57 \begin{code}
  58 doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
  59
  60 doStaticArgs binds
  61   = initSAT (mapSAT sat_bind binds)
  62   where
  63     sat_bind (NonRec binder expr)
  64       = emptyEnvSAT  `thenSAT_`
  65         satExpr expr `thenSAT` (\ expr' ->
  66         returnSAT (NonRec binder expr') )
  67     sat_bind (Rec [(binder,rhs)])
  68       = emptyEnvSAT                       `thenSAT_`
  69         insSAEnv binder (getArgLists rhs) `thenSAT_`
  70         satExpr rhs                       `thenSAT` (\ rhs' ->
  71         saTransform binder rhs')
  72     sat_bind (Rec pairs)
  73       = emptyEnvSAT             `thenSAT_`
  74         mapSAT satExpr rhss     `thenSAT` \ rhss' ->
  75         returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
  76       where
  77         (binders, rhss) = unzip pairs
  78 \end{code}
  79
  80 \begin{code}
  81 satAtom (VarArg v)
  82   = updSAEnv (Just (v,([],[]))) `thenSAT_`
  83     returnSAT ()
  84
  85 satAtom _ = returnSAT ()
  86 \end{code}
  87
  88 \begin{code}
  89 satExpr :: CoreExpr -> SatM CoreExpr
  90
  91 satExpr var@(Var v)
  92   = updSAEnv (Just (v,([],[]))) `thenSAT_`
  93     returnSAT var
  94
  95 satExpr lit@(Lit _) = returnSAT lit
  96
  97 satExpr e@(Con con types args)
  98   = mapSAT satAtom args     `thenSAT_`
  99     returnSAT e
 100
 101 satExpr e@(Prim prim ty args)
 102   = mapSAT satAtom args     `thenSAT_`
 103     returnSAT e
 104
 105 satExpr (Lam binders body)
 106   = satExpr body                `thenSAT` \ body' ->
 107     returnSAT (Lam binders body')
 108
 109 satExpr (CoTyLam tyvar body)
 110   = satExpr body           `thenSAT` (\ body' ->
 111     returnSAT (CoTyLam tyvar body') )
 112
 113 satExpr app@(App _ _)
 114   = getAppArgs app
 115
 116 satExpr app@(CoTyApp _ _)
 117   = getAppArgs app
 118
 119 satExpr (Case expr alts)
 120   = satExpr expr        `thenSAT` \ expr' ->
 121     sat_alts alts       `thenSAT` \ alts' ->
 122     returnSAT (Case expr' alts')
 123   where
 124     sat_alts (AlgAlts alts deflt)
 125       = mapSAT satAlgAlt alts       `thenSAT` \ alts' ->
 126         sat_default deflt           `thenSAT` \ deflt' ->
 127         returnSAT (AlgAlts alts' deflt')
 128       where
 129         satAlgAlt (con, params, rhs)
 130           = satExpr rhs          `thenSAT` \ rhs' ->
 131             returnSAT (con, params, rhs')
 132
 133     sat_alts (PrimAlts alts deflt)
 134       = mapSAT satPrimAlt alts      `thenSAT` \ alts' ->
 135         sat_default deflt           `thenSAT` \ deflt' ->
 136         returnSAT (PrimAlts alts' deflt')
 137       where
 138         satPrimAlt (lit, rhs)
 139           = satExpr rhs `thenSAT` \ rhs' ->
 140             returnSAT (lit, rhs')
 141
 142     sat_default NoDefault
 143       = returnSAT NoDefault
 144     sat_default (BindDefault binder rhs)
 145       = satExpr rhs                  `thenSAT` \ rhs' ->
 146         returnSAT (BindDefault binder rhs')
 147
 148 satExpr (Let (NonRec binder rhs) body)
 149   = satExpr body                `thenSAT` \ body' ->
 150     satExpr rhs                 `thenSAT` \ rhs' ->
 151     returnSAT (Let (NonRec binder rhs') body')
 152
 153 satExpr (Let (Rec [(binder,rhs)]) body)
 154   = satExpr body                      `thenSAT` \ body' ->
 155     insSAEnv binder (getArgLists rhs) `thenSAT_`
 156     satExpr rhs                       `thenSAT` \ rhs' ->
 157     saTransform binder rhs'           `thenSAT` \ binding ->
 158     returnSAT (Let binding body')
 159
 160 satExpr (Let (Rec binds) body)
 161   = let
 162         (binders, rhss) = unzip binds
 163     in
 164     satExpr body                    `thenSAT` \ body' ->
 165     mapSAT satExpr rhss             `thenSAT` \ rhss' ->
 166     returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
 167
 168 satExpr (SCC cc expr)
 169   = satExpr expr                    `thenSAT` \ expr2 ->
 170     returnSAT (SCC cc expr2)
 171
 172 satExpr (Coerce c ty expr)
 173   = satExpr expr                    `thenSAT` \ expr2 ->
 174     returnSAT (Coerce c ty 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}