1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
%
% (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}
|
