2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %************************************************************************
6 \section[SAT]{Static Argument Transformation pass}
8 %************************************************************************
10 96/03: We aren't using the static-argument transformation right now.
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.
18 map = /\ ab -> \f -> \xs -> case xs of
20 (a:b) -> f a : map f b
22 as map is recursively called with the same argument f (unmodified)
25 map = /\ ab -> \f -> \xs -> let map' ys = case ys of
30 Notice that for a compiler that uses lambda lifting this is
31 useless as map' will be transformed back to what map was.
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.
37 Experimental Evidence: Heap: +/- 7%
38 Instrs: Always improves for 2 or more Static Args.
41 module SAT ( doStaticArgs ) where
43 #include "HsVersions.h"
47 doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
49 {- LATER: to end of file:
56 doStaticArgs :: [CoreBind] -> UniqSupply -> [CoreBind]
60 beginPass "Static argument";
61 let { binds' = initSAT (mapSAT sat_bind binds) };
62 endPass "Static argument"
63 False -- No specific flag for dumping SAT
67 sat_bind (NonRec binder expr)
68 = emptyEnvSAT `thenSAT_`
69 satExpr expr `thenSAT` (\ expr' ->
70 returnSAT (NonRec binder expr') )
71 sat_bind (Rec [(binder,rhs)])
72 = emptyEnvSAT `thenSAT_`
73 insSAEnv binder (getArgLists rhs) `thenSAT_`
74 satExpr rhs `thenSAT` (\ rhs' ->
75 saTransform binder rhs')
77 = emptyEnvSAT `thenSAT_`
78 mapSAT satExpr rhss `thenSAT` \ rhss' ->
79 returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
81 (binders, rhss) = unzip pairs
86 = updSAEnv (Just (v,([],[]))) `thenSAT_`
89 satAtom _ = returnSAT ()
93 satExpr :: CoreExpr -> SatM CoreExpr
96 = updSAEnv (Just (v,([],[]))) `thenSAT_`
99 satExpr lit@(Lit _) = returnSAT lit
101 satExpr e@(Con con types args)
102 = mapSAT satAtom args `thenSAT_`
105 satExpr e@(Prim prim ty args)
106 = mapSAT satAtom args `thenSAT_`
109 satExpr (Lam binders body)
110 = satExpr body `thenSAT` \ body' ->
111 returnSAT (Lam binders body')
113 satExpr (CoTyLam tyvar body)
114 = satExpr body `thenSAT` (\ body' ->
115 returnSAT (CoTyLam tyvar body') )
117 satExpr app@(App _ _)
120 satExpr app@(CoTyApp _ _)
123 satExpr (Case expr alts)
124 = satExpr expr `thenSAT` \ expr' ->
125 sat_alts alts `thenSAT` \ alts' ->
126 returnSAT (Case expr' alts')
128 sat_alts (AlgAlts alts deflt)
129 = mapSAT satAlgAlt alts `thenSAT` \ alts' ->
130 sat_default deflt `thenSAT` \ deflt' ->
131 returnSAT (AlgAlts alts' deflt')
133 satAlgAlt (con, params, rhs)
134 = satExpr rhs `thenSAT` \ rhs' ->
135 returnSAT (con, params, rhs')
137 sat_alts (PrimAlts alts deflt)
138 = mapSAT satPrimAlt alts `thenSAT` \ alts' ->
139 sat_default deflt `thenSAT` \ deflt' ->
140 returnSAT (PrimAlts alts' deflt')
142 satPrimAlt (lit, rhs)
143 = satExpr rhs `thenSAT` \ rhs' ->
144 returnSAT (lit, rhs')
146 sat_default NoDefault
147 = returnSAT NoDefault
148 sat_default (BindDefault binder rhs)
149 = satExpr rhs `thenSAT` \ rhs' ->
150 returnSAT (BindDefault binder rhs')
152 satExpr (Let (NonRec binder rhs) body)
153 = satExpr body `thenSAT` \ body' ->
154 satExpr rhs `thenSAT` \ rhs' ->
155 returnSAT (Let (NonRec binder rhs') body')
157 satExpr (Let (Rec [(binder,rhs)]) body)
158 = satExpr body `thenSAT` \ body' ->
159 insSAEnv binder (getArgLists rhs) `thenSAT_`
160 satExpr rhs `thenSAT` \ rhs' ->
161 saTransform binder rhs' `thenSAT` \ binding ->
162 returnSAT (Let binding body')
164 satExpr (Let (Rec binds) body)
166 (binders, rhss) = unzip binds
168 satExpr body `thenSAT` \ body' ->
169 mapSAT satExpr rhss `thenSAT` \ rhss' ->
170 returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
172 satExpr (Note note expr)
173 = satExpr expr `thenSAT` \ expr2 ->
174 returnSAT (Note note expr2)
178 getAppArgs :: CoreExpr -> SatM CoreExpr
181 = get app `thenSAT` \ (app',result) ->
182 updSAEnv result `thenSAT_`
186 -> SatM (CoreExpr, Maybe (Id, SATInfo))
189 = get e `thenSAT` \ (e',result) ->
194 Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
198 = get e `thenSAT` \ (e', result) ->
201 (VarArg v) -> Static v
207 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
212 = returnSAT (var, Just (v,([],[])))
215 = satExpr e `thenSAT` \ e2 ->
216 returnSAT (e2, Nothing)