ghc/compiler/simplStg/StgSAT.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 \begin{code}
  32 #include "HsVersions.h"
  33
  34 module StgSAT (
  35         doStaticArgs,
  36
  37         -- and to make the interface self-sufficient...
  38         PlainStgProgram(..), StgExpr, StgBinding, Id
  39     ) where
  40
  41 import IdEnv
  42 import Maybes           ( Maybe(..) )
  43 import StgSyn
  44 import SATMonad         ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
  45                           SatM(..), initSAT, thenSAT, thenSAT_,
  46                           emptyEnvSAT, returnSAT, mapSAT )
  47 import StgSATMonad
  48 import SplitUniq
  49 import Util
  50 \end{code}
  51
  52 \begin{code}
  53 doStaticArgs :: PlainStgProgram -> SplitUniqSupply -> PlainStgProgram
  54
  55 doStaticArgs binds
  56   = initSAT (mapSAT sat_bind binds)
  57   where
  58     sat_bind (StgNonRec binder expr)
  59       = emptyEnvSAT  `thenSAT_`
  60         satRhs expr `thenSAT` (\ expr' ->
  61         returnSAT (StgNonRec binder expr'))
  62     sat_bind (StgRec [(binder,rhs)])
  63       = emptyEnvSAT                       `thenSAT_`
  64         insSAEnv binder (getArgLists rhs) `thenSAT_`
  65         satRhs rhs                        `thenSAT` (\ rhs' ->
  66         saTransform binder rhs')
  67     sat_bind (StgRec pairs)
  68       = emptyEnvSAT             `thenSAT_`
  69         mapSAT satRhs rhss      `thenSAT` \ rhss' ->
  70         returnSAT (StgRec (binders `zip` rhss'))
  71       where
  72         (binders, rhss) = unzip pairs
  73 \end{code}
  74
  75 \begin{code}
  76 satAtom (StgVarAtom v)
  77   = updSAEnv (Just (v,([],[]))) `thenSAT_`
  78     returnSAT ()
  79
  80 satAtom _ = returnSAT ()
  81 \end{code}
  82
  83 \begin{code}
  84 satExpr :: PlainStgExpr -> SatM PlainStgExpr
  85
  86 satExpr e@(StgConApp con args lvs)
  87   = mapSAT satAtom args     `thenSAT_`
  88     returnSAT e
  89
  90 satExpr e@(StgPrimApp op args lvs)
  91   = mapSAT satAtom args     `thenSAT_`
  92     returnSAT e
  93
  94 satExpr e@(StgApp (StgLitAtom _) _ _)
  95   = returnSAT e
  96
  97 satExpr e@(StgApp (StgVarAtom v) args _)
  98   = updSAEnv (Just (v,([],map tagArg args)))    `thenSAT_`
  99     mapSAT satAtom args                         `thenSAT_`
 100     returnSAT e
 101   where
 102     tagArg (StgVarAtom v) = Static v
 103     tagArg _              = NotStatic
 104
 105 satExpr (StgCase expr lv1 lv2 uniq alts)
 106   = satExpr expr        `thenSAT` \ expr' ->
 107     sat_alts alts       `thenSAT` \ alts' ->
 108     returnSAT (StgCase expr' lv1 lv2 uniq alts')
 109   where
 110     sat_alts (StgAlgAlts ty alts deflt)
 111       = mapSAT satAlgAlt alts       `thenSAT` \ alts' ->
 112         sat_default deflt           `thenSAT` \ deflt' ->
 113         returnSAT (StgAlgAlts ty alts' deflt')
 114       where
 115         satAlgAlt (con, params, use_mask, rhs)
 116           = satExpr rhs          `thenSAT` \ rhs' ->
 117             returnSAT (con, params, use_mask, rhs')
 118
 119     sat_alts (StgPrimAlts ty alts deflt)
 120       = mapSAT satPrimAlt alts      `thenSAT` \ alts' ->
 121         sat_default deflt           `thenSAT` \ deflt' ->
 122         returnSAT (StgPrimAlts ty alts' deflt')
 123       where
 124         satPrimAlt (lit, rhs)
 125           = satExpr rhs `thenSAT` \ rhs' ->
 126             returnSAT (lit, rhs')
 127
 128     sat_default StgNoDefault
 129       = returnSAT StgNoDefault
 130     sat_default (StgBindDefault binder used rhs)
 131       = satExpr rhs                  `thenSAT` \ rhs' ->
 132         returnSAT (StgBindDefault binder used rhs')
 133
 134 satExpr (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs) body)
 135   = satExpr body                `thenSAT` \ body' ->
 136     satRhs rhs                  `thenSAT` \ rhs' ->
 137     returnSAT (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs') body')
 138
 139 satExpr (StgLetNoEscape lv1 lv2 (StgRec [(binder,rhs)]) body)
 140   = satExpr body                      `thenSAT` \ body' ->
 141     insSAEnv binder (getArgLists rhs) `thenSAT_`
 142     satRhs rhs                        `thenSAT` \ rhs' ->
 143     saTransform binder rhs'           `thenSAT` \ binding ->
 144     returnSAT (StgLetNoEscape lv1 lv2 binding body')
 145
 146 satExpr (StgLetNoEscape lv1 lv2 (StgRec binds) body)
 147   = let (binders, rhss) = unzip binds
 148     in
 149     satExpr body                    `thenSAT` \ body' ->
 150     mapSAT satRhs rhss              `thenSAT` \ rhss' ->
 151     returnSAT (StgLetNoEscape lv1 lv2 (StgRec (binders `zip` rhss')) body')
 152
 153 satExpr (StgLet (StgNonRec binder rhs) body)
 154   = satExpr body                `thenSAT` \ body' ->
 155     satRhs rhs                  `thenSAT` \ rhs' ->
 156     returnSAT (StgLet (StgNonRec binder rhs') body')
 157
 158 satExpr (StgLet (StgRec [(binder,rhs)]) body)
 159   = satExpr body                      `thenSAT` \ body' ->
 160     insSAEnv binder (getArgLists rhs) `thenSAT_`
 161     satRhs rhs                        `thenSAT` \ rhs' ->
 162     saTransform binder rhs'           `thenSAT` \ binding ->
 163     returnSAT (StgLet binding body')
 164
 165 satExpr (StgLet (StgRec binds) body)
 166   = let (binders, rhss) = unzip binds
 167     in
 168     satExpr body                    `thenSAT` \ body' ->
 169     mapSAT satRhs rhss              `thenSAT` \ rhss' ->
 170     returnSAT (StgLet (StgRec (binders `zip` rhss')) body')
 171
 172 satExpr (StgSCC ty cc expr)
 173   = satExpr expr                    `thenSAT` \ expr' ->
 174     returnSAT (StgSCC ty cc expr')
 175
 176 -- ToDo: DPH stuff
 177 \end{code}
 178
 179 \begin{code}
 180 satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs
 181 satRhs (StgRhsClosure cc bi fvs upd args body)
 182   = satExpr body                `thenSAT` \ body' ->
 183     returnSAT (StgRhsClosure cc bi fvs upd args body')
 184
 185 \end{code}
 186