--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+%************************************************************************
+%* *
+\section[SAT]{Static Argument Transformation pass}
+%* *
+%************************************************************************
+
+96/03: We aren't using the static-argument transformation right now.
+
+May be seen as removing invariants from loops:
+Arguments of recursive functions that do not change in recursive
+calls are removed from the recursion, which is done locally
+and only passes the arguments which effectively change.
+
+Example:
+map = /\ ab -> \f -> \xs -> case xs of
+ [] -> []
+ (a:b) -> f a : map f b
+
+as map is recursively called with the same argument f (unmodified)
+we transform it to
+
+map = /\ ab -> \f -> \xs -> let map' ys = case ys of
+ [] -> []
+ (a:b) -> f a : map' b
+ in map' xs
+
+Notice that for a compiler that uses lambda lifting this is
+useless as map' will be transformed back to what map was.
+
+We could possibly do the same for big lambdas, but we don't as
+they will eventually be removed in later stages of the compiler,
+therefore there is no penalty in keeping them.
+
+Experimental Evidence: Heap: +/- 7%
+ Instrs: Always improves for 2 or more Static Args.
+
+\begin{code}
+module SAT ( doStaticArgs ) where
+
+#include "HsVersions.h"
+
+import Panic ( panic )
+
+doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
+
+{- LATER: to end of file:
+
+import SATMonad
+import Util
+\end{code}
+
+\begin{code}
+doStaticArgs :: [CoreBind] -> UniqSupply -> [CoreBind]
+
+doStaticArgs binds
+ = do {
+ showPass "Static argument";
+ let { binds' = initSAT (mapSAT sat_bind binds) };
+ endPass "Static argument"
+ False -- No specific flag for dumping SAT
+ binds'
+ }
+ where
+ sat_bind (NonRec binder expr)
+ = emptyEnvSAT `thenSAT_`
+ satExpr expr `thenSAT` (\ expr' ->
+ returnSAT (NonRec binder expr') )
+ sat_bind (Rec [(binder,rhs)])
+ = emptyEnvSAT `thenSAT_`
+ insSAEnv binder (getArgLists rhs) `thenSAT_`
+ satExpr rhs `thenSAT` (\ rhs' ->
+ saTransform binder rhs')
+ sat_bind (Rec pairs)
+ = emptyEnvSAT `thenSAT_`
+ mapSAT satExpr rhss `thenSAT` \ rhss' ->
+ returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
+ where
+ (binders, rhss) = unzip pairs
+\end{code}
+
+\begin{code}
+satAtom (VarArg v)
+ = updSAEnv (Just (v,([],[]))) `thenSAT_`
+ returnSAT ()
+
+satAtom _ = returnSAT ()
+\end{code}
+
+\begin{code}
+satExpr :: CoreExpr -> SatM CoreExpr
+
+satExpr var@(Var v)
+ = updSAEnv (Just (v,([],[]))) `thenSAT_`
+ returnSAT var
+
+satExpr lit@(Lit _) = returnSAT lit
+
+satExpr e@(Prim prim ty args)
+ = mapSAT satAtom args `thenSAT_`
+ returnSAT e
+
+satExpr (Lam binders body)
+ = satExpr body `thenSAT` \ body' ->
+ returnSAT (Lam binders body')
+
+satExpr (CoTyLam tyvar body)
+ = satExpr body `thenSAT` (\ body' ->
+ returnSAT (CoTyLam tyvar body') )
+
+satExpr app@(App _ _)
+ = getAppArgs app
+
+satExpr app@(CoTyApp _ _)
+ = getAppArgs app
+
+satExpr (Case expr alts)
+ = satExpr expr `thenSAT` \ expr' ->
+ sat_alts alts `thenSAT` \ alts' ->
+ returnSAT (Case expr' alts')
+ where
+ sat_alts (AlgAlts alts deflt)
+ = mapSAT satAlgAlt alts `thenSAT` \ alts' ->
+ sat_default deflt `thenSAT` \ deflt' ->
+ returnSAT (AlgAlts alts' deflt')
+ where
+ satAlgAlt (con, params, rhs)
+ = satExpr rhs `thenSAT` \ rhs' ->
+ returnSAT (con, params, rhs')
+
+ sat_alts (PrimAlts alts deflt)
+ = mapSAT satPrimAlt alts `thenSAT` \ alts' ->
+ sat_default deflt `thenSAT` \ deflt' ->
+ returnSAT (PrimAlts alts' deflt')
+ where
+ satPrimAlt (lit, rhs)
+ = satExpr rhs `thenSAT` \ rhs' ->
+ returnSAT (lit, rhs')
+
+ sat_default NoDefault
+ = returnSAT NoDefault
+ sat_default (BindDefault binder rhs)
+ = satExpr rhs `thenSAT` \ rhs' ->
+ returnSAT (BindDefault binder rhs')
+
+satExpr (Let (NonRec binder rhs) body)
+ = satExpr body `thenSAT` \ body' ->
+ satExpr rhs `thenSAT` \ rhs' ->
+ returnSAT (Let (NonRec binder rhs') body')
+
+satExpr (Let (Rec [(binder,rhs)]) body)
+ = satExpr body `thenSAT` \ body' ->
+ insSAEnv binder (getArgLists rhs) `thenSAT_`
+ satExpr rhs `thenSAT` \ rhs' ->
+ saTransform binder rhs' `thenSAT` \ binding ->
+ returnSAT (Let binding body')
+
+satExpr (Let (Rec binds) body)
+ = let
+ (binders, rhss) = unzip binds
+ in
+ satExpr body `thenSAT` \ body' ->
+ mapSAT satExpr rhss `thenSAT` \ rhss' ->
+ returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
+
+satExpr (Note note expr)
+ = satExpr expr `thenSAT` \ expr2 ->
+ returnSAT (Note note expr2)
+\end{code}
+
+\begin{code}
+getAppArgs :: CoreExpr -> SatM CoreExpr
+
+getAppArgs app
+ = get app `thenSAT` \ (app',result) ->
+ updSAEnv result `thenSAT_`
+ returnSAT app'
+ where
+ get :: CoreExpr
+ -> SatM (CoreExpr, Maybe (Id, SATInfo))
+
+ get (CoTyApp e ty)
+ = get e `thenSAT` \ (e',result) ->
+ returnSAT (
+ CoTyApp e' ty,
+ case result of
+ Nothing -> Nothing
+ Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
+ )
+
+ get (App e a)
+ = get e `thenSAT` \ (e', result) ->
+ satAtom a `thenSAT_`
+ let si = case a of
+ (VarArg v) -> Static v
+ _ -> NotStatic
+ in
+ returnSAT (
+ App e' a,
+ case result of
+ Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
+ Nothing -> Nothing
+ )
+
+ get var@(Var v)
+ = returnSAT (var, Just (v,([],[])))
+
+ get e
+ = satExpr e `thenSAT` \ e2 ->
+ returnSAT (e2, Nothing)
+-}
+\end{code}
projects / ghc-hetmet.git / blobdiff