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 Panic    ( 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         showPass "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@(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 (Note note expr)
 169   = satExpr expr                    `thenSAT` \ expr2 ->
 170     returnSAT (Note note expr2)
 171 \end{code}
 172
 173 \begin{code}
 174 getAppArgs :: CoreExpr -> SatM CoreExpr
 175
 176 getAppArgs app
 177   = get app             `thenSAT` \ (app',result) ->
 178     updSAEnv result     `thenSAT_`
 179     returnSAT app'
 180   where
 181     get :: CoreExpr
 182         -> SatM (CoreExpr, Maybe (Id, SATInfo))
 183
 184     get (CoTyApp e ty)
 185       = get e           `thenSAT` \ (e',result) ->
 186         returnSAT (
 187           CoTyApp e' ty,
 188           case result of
 189             Nothing          -> Nothing
 190             Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
 191         )
 192
 193     get (App e a)
 194       = get e           `thenSAT` \ (e', result) ->
 195         satAtom a       `thenSAT_`
 196         let si = case a of
 197                    (VarArg v) -> Static v
 198                    _             -> NotStatic
 199         in
 200           returnSAT (
 201             App e' a,
 202             case result of
 203                 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
 204                 Nothing          -> Nothing
 205           )
 206
 207     get var@(Var v)
 208       = returnSAT (var, Just (v,([],[])))
 209
 210     get e
 211       = satExpr e       `thenSAT` \ e2 ->
 212         returnSAT (e2, Nothing)
 213 -}
 214 \end{code}