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
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
\section[SAT]{Static Argument Transformation pass}
%* *
%************************************************************************
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.
\begin{code}
#include "HsVersions.h"
module StgSAT ( doStaticArgs ) where
IMP_Ubiq(){-uitous-}
import StgSyn
import UniqSupply ( SYN_IE(UniqSM) )
import Util ( panic )
\end{code}
\begin{code}
doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding]
doStaticArgs = panic "StgSAT.doStaticArgs"
{- LATER: to end of file:
doStaticArgs binds
= initSAT (mapSAT sat_bind binds)
where
sat_bind (StgNonRec binder expr)
= emptyEnvSAT `thenSAT_`
satRhs expr `thenSAT` (\ expr' ->
returnSAT (StgNonRec binder expr'))
sat_bind (StgRec [(binder,rhs)])
= emptyEnvSAT `thenSAT_`
insSAEnv binder (getArgLists rhs) `thenSAT_`
satRhs rhs `thenSAT` (\ rhs' ->
saTransform binder rhs')
sat_bind (StgRec pairs)
= emptyEnvSAT `thenSAT_`
mapSAT satRhs rhss `thenSAT` \ rhss' ->
returnSAT (StgRec (binders `zip` rhss'))
where
(binders, rhss) = unzip pairs
\end{code}
\begin{code}
satAtom (StgVarArg v)
= updSAEnv (Just (v,([],[]))) `thenSAT_`
returnSAT ()
satAtom _ = returnSAT ()
\end{code}
\begin{code}
satExpr :: StgExpr -> SatM StgExpr
satExpr e@(StgCon con args lvs)
= mapSAT satAtom args `thenSAT_`
returnSAT e
satExpr e@(StgPrim op args lvs)
= mapSAT satAtom args `thenSAT_`
returnSAT e
satExpr e@(StgApp (StgLitArg _) _ _)
= returnSAT e
satExpr e@(StgApp (StgVarArg v) args _)
= updSAEnv (Just (v,([],map tagArg args))) `thenSAT_`
mapSAT satAtom args `thenSAT_`
returnSAT e
where
tagArg (StgVarArg v) = Static v
tagArg _ = NotStatic
satExpr (StgCase expr lv1 lv2 uniq alts)
= satExpr expr `thenSAT` \ expr' ->
sat_alts alts `thenSAT` \ alts' ->
returnSAT (StgCase expr' lv1 lv2 uniq alts')
where
sat_alts (StgAlgAlts ty alts deflt)
= mapSAT satAlgAlt alts `thenSAT` \ alts' ->
sat_default deflt `thenSAT` \ deflt' ->
returnSAT (StgAlgAlts ty alts' deflt')
where
satAlgAlt (con, params, use_mask, rhs)
= satExpr rhs `thenSAT` \ rhs' ->
returnSAT (con, params, use_mask, rhs')
sat_alts (StgPrimAlts ty alts deflt)
= mapSAT satPrimAlt alts `thenSAT` \ alts' ->
sat_default deflt `thenSAT` \ deflt' ->
returnSAT (StgPrimAlts ty alts' deflt')
where
satPrimAlt (lit, rhs)
= satExpr rhs `thenSAT` \ rhs' ->
returnSAT (lit, rhs')
sat_default StgNoDefault
= returnSAT StgNoDefault
sat_default (StgBindDefault binder used rhs)
= satExpr rhs `thenSAT` \ rhs' ->
returnSAT (StgBindDefault binder used rhs')
satExpr (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs) body)
= satExpr body `thenSAT` \ body' ->
satRhs rhs `thenSAT` \ rhs' ->
returnSAT (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs') body')
satExpr (StgLetNoEscape lv1 lv2 (StgRec [(binder,rhs)]) body)
= satExpr body `thenSAT` \ body' ->
insSAEnv binder (getArgLists rhs) `thenSAT_`
satRhs rhs `thenSAT` \ rhs' ->
saTransform binder rhs' `thenSAT` \ binding ->
returnSAT (StgLetNoEscape lv1 lv2 binding body')
satExpr (StgLetNoEscape lv1 lv2 (StgRec binds) body)
= let (binders, rhss) = unzip binds
in
satExpr body `thenSAT` \ body' ->
mapSAT satRhs rhss `thenSAT` \ rhss' ->
returnSAT (StgLetNoEscape lv1 lv2 (StgRec (binders `zip` rhss')) body')
satExpr (StgLet (StgNonRec binder rhs) body)
= satExpr body `thenSAT` \ body' ->
satRhs rhs `thenSAT` \ rhs' ->
returnSAT (StgLet (StgNonRec binder rhs') body')
satExpr (StgLet (StgRec [(binder,rhs)]) body)
= satExpr body `thenSAT` \ body' ->
insSAEnv binder (getArgLists rhs) `thenSAT_`
satRhs rhs `thenSAT` \ rhs' ->
saTransform binder rhs' `thenSAT` \ binding ->
returnSAT (StgLet binding body')
satExpr (StgLet (StgRec binds) body)
= let (binders, rhss) = unzip binds
in
satExpr body `thenSAT` \ body' ->
mapSAT satRhs rhss `thenSAT` \ rhss' ->
returnSAT (StgLet (StgRec (binders `zip` rhss')) body')
satExpr (StgSCC ty cc expr)
= satExpr expr `thenSAT` \ expr' ->
returnSAT (StgSCC ty cc expr')
\end{code}
\begin{code}
satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs
satRhs (StgRhsClosure cc bi fvs upd args body)
= satExpr body `thenSAT` \ body' ->
returnSAT (StgRhsClosure cc bi fvs upd args body')
-}
\end{code}
|
