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 {-# OPTIONS -w #-}
  42 -- The above warning supression flag is a temporary kludge.
  43 -- While working on this module you are encouraged to remove it and fix
  44 -- any warnings in the module. See
  45 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  46 -- for details
  47
  48 module SAT ( doStaticArgs ) where
  49
  50 #include "HsVersions.h"
  51
  52 import Panic    ( panic )
  53
  54 doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
  55
  56 {- LATER: to end of file:
  57
  58 import SATMonad
  59 import Util
  60 \end{code}
  61
  62 \begin{code}
  63 doStaticArgs :: [CoreBind] -> UniqSupply -> [CoreBind]
  64
  65 doStaticArgs binds
  66   = do {
  67         showPass "Static argument";
  68         let { binds' = initSAT (mapSAT sat_bind binds) };
  69         endPass "Static argument"
  70                 False           -- No specific flag for dumping SAT
  71                 binds'
  72     }
  73   where
  74     sat_bind (NonRec binder expr)
  75       = emptyEnvSAT  `thenSAT_`
  76         satExpr expr `thenSAT` (\ expr' ->
  77         returnSAT (NonRec binder expr') )
  78     sat_bind (Rec [(binder,rhs)])
  79       = emptyEnvSAT                       `thenSAT_`
  80         insSAEnv binder (getArgLists rhs) `thenSAT_`
  81         satExpr rhs                       `thenSAT` (\ rhs' ->
  82         saTransform binder rhs')
  83     sat_bind (Rec pairs)
  84       = emptyEnvSAT             `thenSAT_`
  85         mapSAT satExpr rhss     `thenSAT` \ rhss' ->
  86         returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
  87       where
  88         (binders, rhss) = unzip pairs
  89 \end{code}
  90
  91 \begin{code}
  92 satAtom (VarArg v)
  93   = updSAEnv (Just (v,([],[]))) `thenSAT_`
  94     returnSAT ()
  95
  96 satAtom _ = returnSAT ()
  97 \end{code}
  98
  99 \begin{code}
 100 satExpr :: CoreExpr -> SatM CoreExpr
 101
 102 satExpr var@(Var v)
 103   = updSAEnv (Just (v,([],[]))) `thenSAT_`
 104     returnSAT var
 105
 106 satExpr lit@(Lit _) = returnSAT lit
 107
 108 satExpr e@(Prim prim ty args)
 109   = mapSAT satAtom args     `thenSAT_`
 110     returnSAT e
 111
 112 satExpr (Lam binders body)
 113   = satExpr body                `thenSAT` \ body' ->
 114     returnSAT (Lam binders body')
 115
 116 satExpr (CoTyLam tyvar body)
 117   = satExpr body           `thenSAT` (\ body' ->
 118     returnSAT (CoTyLam tyvar body') )
 119
 120 satExpr app@(App _ _)
 121   = getAppArgs app
 122
 123 satExpr app@(CoTyApp _ _)
 124   = getAppArgs app
 125
 126 satExpr (Case expr alts)
 127   = satExpr expr        `thenSAT` \ expr' ->
 128     sat_alts alts       `thenSAT` \ alts' ->
 129     returnSAT (Case expr' alts')
 130   where
 131     sat_alts (AlgAlts alts deflt)
 132       = mapSAT satAlgAlt alts       `thenSAT` \ alts' ->
 133         sat_default deflt           `thenSAT` \ deflt' ->
 134         returnSAT (AlgAlts alts' deflt')
 135       where
 136         satAlgAlt (con, params, rhs)
 137           = satExpr rhs          `thenSAT` \ rhs' ->
 138             returnSAT (con, params, rhs')
 139
 140     sat_alts (PrimAlts alts deflt)
 141       = mapSAT satPrimAlt alts      `thenSAT` \ alts' ->
 142         sat_default deflt           `thenSAT` \ deflt' ->
 143         returnSAT (PrimAlts alts' deflt')
 144       where
 145         satPrimAlt (lit, rhs)
 146           = satExpr rhs `thenSAT` \ rhs' ->
 147             returnSAT (lit, rhs')
 148
 149     sat_default NoDefault
 150       = returnSAT NoDefault
 151     sat_default (BindDefault binder rhs)
 152       = satExpr rhs                  `thenSAT` \ rhs' ->
 153         returnSAT (BindDefault binder rhs')
 154
 155 satExpr (Let (NonRec binder rhs) body)
 156   = satExpr body                `thenSAT` \ body' ->
 157     satExpr rhs                 `thenSAT` \ rhs' ->
 158     returnSAT (Let (NonRec binder rhs') body')
 159
 160 satExpr (Let (Rec [(binder,rhs)]) body)
 161   = satExpr body                      `thenSAT` \ body' ->
 162     insSAEnv binder (getArgLists rhs) `thenSAT_`
 163     satExpr rhs                       `thenSAT` \ rhs' ->
 164     saTransform binder rhs'           `thenSAT` \ binding ->
 165     returnSAT (Let binding body')
 166
 167 satExpr (Let (Rec binds) body)
 168   = let
 169         (binders, rhss) = unzip binds
 170     in
 171     satExpr body                    `thenSAT` \ body' ->
 172     mapSAT satExpr rhss             `thenSAT` \ rhss' ->
 173     returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
 174
 175 satExpr (Note note expr)
 176   = satExpr expr                    `thenSAT` \ expr2 ->
 177     returnSAT (Note note expr2)
 178 \end{code}
 179
 180 \begin{code}
 181 getAppArgs :: CoreExpr -> SatM CoreExpr
 182
 183 getAppArgs app
 184   = get app             `thenSAT` \ (app',result) ->
 185     updSAEnv result     `thenSAT_`
 186     returnSAT app'
 187   where
 188     get :: CoreExpr
 189         -> SatM (CoreExpr, Maybe (Id, SATInfo))
 190
 191     get (CoTyApp e ty)
 192       = get e           `thenSAT` \ (e',result) ->
 193         returnSAT (
 194           CoTyApp e' ty,
 195           case result of
 196             Nothing          -> Nothing
 197             Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
 198         )
 199
 200     get (App e a)
 201       = get e           `thenSAT` \ (e', result) ->
 202         satAtom a       `thenSAT_`
 203         let si = case a of
 204                    (VarArg v) -> Static v
 205                    _             -> NotStatic
 206         in
 207           returnSAT (
 208             App e' a,
 209             case result of
 210                 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
 211                 Nothing          -> Nothing
 212           )
 213
 214     get var@(Var v)
 215       = returnSAT (var, Just (v,([],[])))
 216
 217     get e
 218       = satExpr e       `thenSAT` \ e2 ->
 219         returnSAT (e2, Nothing)
 220 -}
 221 \end{code}