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