+++ /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