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