ghc/compiler/simplCore/SAT.lhs

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