SCM Repository
Annotation of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml
Parent Directory
|
Revision Log
Revision 63 - (view) (download)
1 : | monnier | 58 | (* copyright 1998 YALE FLINT PROJECT *) |
2 : | |||
3 : | signature FCONTRACT = | ||
4 : | sig | ||
5 : | |||
6 : | (* needs Collect to be setup properly *) | ||
7 : | val contract : FLINT.fundec -> FLINT.fundec | ||
8 : | |||
9 : | end | ||
10 : | |||
11 : | (* All kinds of beta-reductions. In order to do as much work per pass as | ||
12 : | * possible, the usage counts of each variable (maintained by the Collect | ||
13 : | * module) is kept as much uptodate as possible. For instance as soon as a | ||
14 : | * variable becomes dead, all the variables that were referenced have their | ||
15 : | * usage counts decremented correspondingly. This means that we have to | ||
16 : | * be careful to make sure that a dead variable will indeed not appear | ||
17 : | * in the output lexp since it might else reference other dead variables *) | ||
18 : | |||
19 : | (* things that lcontract did that fcontract doesn't do (yet): | ||
20 : | * | ||
21 : | * - inline across DeBruijn depths | ||
22 : | monnier | 63 | * - elimination of let [dead-vs] = pure in body |
23 : | *) | ||
24 : | monnier | 58 | |
25 : | structure FContract :> FCONTRACT = | ||
26 : | struct | ||
27 : | local | ||
28 : | structure F = FLINT | ||
29 : | structure M = Intmap | ||
30 : | structure C = Collect | ||
31 : | structure DI = DebIndex | ||
32 : | structure PP = PPFlint | ||
33 : | in | ||
34 : | |||
35 : | val say = Control.Print.say | ||
36 : | fun bug msg = ErrorMsg.impossible ("FContract: "^msg) | ||
37 : | fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg) | ||
38 : | fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg) | ||
39 : | |||
40 : | (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *) | ||
41 : | |||
42 : | fun ASSERT (true,_) = () | ||
43 : | | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed") | ||
44 : | |||
45 : | datatype sval | ||
46 : | = Val of F.value | ||
47 : | | Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth | ||
48 : | | TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth | ||
49 : | | Record of F.lvar * F.value list | ||
50 : | | Select of F.lvar * F.value * int | ||
51 : | | Con of F.lvar * F.value * F.dcon | ||
52 : | |||
53 : | exception NotFound | ||
54 : | val m : sval M.intmap = M.new(128, NotFound) | ||
55 : | |||
56 : | fun cexp (cfg as (d,od)) le = let | ||
57 : | |||
58 : | val loop = cexp cfg | ||
59 : | |||
60 : | fun used lv = C.usenb lv > 0 | ||
61 : | |||
62 : | fun impurePO po = true (* if a PrimOP is pure or not *) | ||
63 : | |||
64 : | monnier | 63 | fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2 |
65 : | | eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2 | ||
66 : | | eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2 | ||
67 : | | eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2 | ||
68 : | | eqConV (F.REALcon r1, F.REAL r2) = r1 = r2 | ||
69 : | | eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2 | ||
70 : | | eqConV (con,v) = bugval("unexpected comparison with val", v) | ||
71 : | |||
72 : | monnier | 58 | fun lookup lv = M.map m lv |
73 : | (* handle e as NotFound => *) | ||
74 : | (* (say (concat ["\nlooking up unbound ", *) | ||
75 : | (* !PP.LVarString lv]); *) | ||
76 : | (* raise e) *) | ||
77 : | |||
78 : | fun sval2val sv = | ||
79 : | case sv | ||
80 : | monnier | 63 | of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} |
81 : | | Select{1=lv,...} | Con{1=lv,...}) => F.VAR lv | ||
82 : | monnier | 58 | | Val v => v |
83 : | |||
84 : | monnier | 63 | fun val2sval (F.VAR ov) = lookup ov |
85 : | monnier | 58 | | val2sval v = Val v |
86 : | |||
87 : | fun bugsv (msg,sv) = bugval(msg, sval2val sv) | ||
88 : | |||
89 : | fun subst ov = sval2val (lookup ov) | ||
90 : | val substval = sval2val o val2sval | ||
91 : | fun substvar lv = | ||
92 : | case substval (F.VAR lv) | ||
93 : | of F.VAR lv => lv | ||
94 : | | v => bugval ("unexpected val", v) | ||
95 : | |||
96 : | fun unuseval f (F.VAR lv) = C.unuse f false lv | ||
97 : | | unuseval f _ = () | ||
98 : | |||
99 : | (* called when a variable becomes dead. | ||
100 : | * it simply adjusts the use-counts *) | ||
101 : | fun undertake lv = | ||
102 : | monnier | 63 | case lookup lv |
103 : | of Val (F.VAR nlv) => ASSERT(nlv = lv, "nlv = lv") | ||
104 : | | Val v => unuseval undertake v | ||
105 : | monnier | 58 | | ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) => |
106 : | monnier | 63 | C.inside lv (fn()=> C.unuselexp undertake le) |
107 : | monnier | 58 | | ( Select {2=v,...} | Con {2=v,...} ) => |
108 : | monnier | 63 | unuseval undertake v |
109 : | | Record {2=vs,...} => app (unuseval undertake) vs | ||
110 : | monnier | 58 | |
111 : | fun addbind (lv,sv) = | ||
112 : | let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2) | ||
113 : | fun correct (Val v) = true | ||
114 : | | correct sv = | ||
115 : | let val F.VAR lv = sval2val sv | ||
116 : | in eqsv(sv, M.map m lv) | ||
117 : | end handle NotFound => true | ||
118 : | in ASSERT(correct sv, "addbind"); | ||
119 : | M.add m (lv, sv) | ||
120 : | end | ||
121 : | |||
122 : | (* substitute a value sv for a variable lv and unuse value v *) | ||
123 : | fun substitute (lv1, sv, v) = | ||
124 : | (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => (); | ||
125 : | unuseval undertake v; | ||
126 : | monnier | 63 | addbind (lv1, sv)) |
127 : | monnier | 58 | |
128 : | (* common code for all the lexps "let v = <op>[v1,...] in ..." *) | ||
129 : | fun clet1 (svcon,lecon) (lv,vs,le) = | ||
130 : | if used lv then | ||
131 : | let val nvs = map substval vs | ||
132 : | val _ = addbind (lv, svcon(nvs)) | ||
133 : | val nle = loop le | ||
134 : | in if used lv then lecon(nvs, nle) else nle | ||
135 : | end | ||
136 : | else loop le | ||
137 : | |||
138 : | (* common code for primops *) | ||
139 : | fun cpo (SOME{default,table},po,lty,tycs) = | ||
140 : | (SOME{default=substvar default, | ||
141 : | table=map (fn (tycs,lv) => (tycs, substvar lv)) table}, | ||
142 : | po,lty,tycs) | ||
143 : | | cpo po = po | ||
144 : | |||
145 : | fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = | ||
146 : | (s, Access.EXN(Access.LVAR(substvar lv)), lty) | ||
147 : | | cdcon dc = dc | ||
148 : | |||
149 : | in | ||
150 : | case le | ||
151 : | monnier | 63 | of F.RET vs => F.RET(map substval vs) |
152 : | monnier | 58 | |
153 : | | F.LET (lvs,le,body) => | ||
154 : | monnier | 63 | let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2) |
155 : | (* let associativity | ||
156 : | * !!BEWARE!! applying the associativity rule might | ||
157 : | * change the liveness of the bound variables *) | ||
158 : | | clet (F.FIX(fdecs,le)) = | ||
159 : | let val nbody = clet le | ||
160 : | val nfdecs = List.filter (used o #2) fdecs | ||
161 : | in if null nfdecs then nbody else F.FIX(nfdecs, nbody) | ||
162 : | end | ||
163 : | | clet (F.TFN(tfdec,le)) = | ||
164 : | let val nbody = clet le | ||
165 : | in if used (#1 tfdec) then F.TFN(tfdec, nbody) else nbody | ||
166 : | end | ||
167 : | | clet (F.CON(dc,tycs,v,lv,le)) = | ||
168 : | let val nbody = clet le | ||
169 : | in if used lv then F.CON(dc, tycs, v, lv, nbody) else nbody | ||
170 : | end | ||
171 : | | clet (F.RECORD(rk,vs,lv,le)) = | ||
172 : | let val nbody = clet le | ||
173 : | in if used lv then F.RECORD(rk, vs, lv, nbody) else nbody | ||
174 : | end | ||
175 : | | clet (F.SELECT(v,i,lv,le)) = | ||
176 : | let val nbody = clet le | ||
177 : | in if used lv then F.SELECT(v, i, lv, nbody) else nbody | ||
178 : | end | ||
179 : | | clet (F.PRIMOP(po,vs,lv,le)) = | ||
180 : | let val nbody = clet le | ||
181 : | in if impurePO po orelse used lv | ||
182 : | then F.PRIMOP(po, vs, lv, nbody) | ||
183 : | else nbody | ||
184 : | end | ||
185 : | (* F.RAISE never returns so the body of the let could be | ||
186 : | * dropped on the floor, but since I don't propagate | ||
187 : | * types I can't come up with the right return type | ||
188 : | * | F.RAISE(v,ltys) => | ||
189 : | * (C.unuselexp undertake body; | ||
190 : | * F.RAISE(v, ?????)) *) | ||
191 : | | clet (F.RET vs) = | ||
192 : | (* LET[lvs] = RET[vs] is replaced by substitutions *) | ||
193 : | (app (fn (lv,v) => substitute (lv, val2sval v, v)) | ||
194 : | (ListPair.zip(lvs, vs)); | ||
195 : | loop body) | ||
196 : | | clet le = | ||
197 : | (app (fn lv => addbind (lv, Val(F.VAR lv))) lvs; | ||
198 : | case loop body | ||
199 : | of F.RET vs => if vs = (map F.VAR lvs) then le | ||
200 : | else F.LET(lvs, le, F.RET vs) | ||
201 : | | nbody => F.LET(lvs, le, nbody)) | ||
202 : | monnier | 58 | in |
203 : | clet (loop le) | ||
204 : | monnier | 63 | end |
205 : | monnier | 58 | |
206 : | | F.FIX (fs,le) => | ||
207 : | monnier | 63 | let fun cfun [] acc = rev acc |
208 : | | cfun (fdec as (fk,f,args,body)::fs) acc = | ||
209 : | if used f then | ||
210 : | let (* make up the bindings for args inside the body *) | ||
211 : | val _ = app (fn lv => addbind (lv, Val(F.VAR lv))) | ||
212 : | (map #1 args) | ||
213 : | (* contract the body and create the resulting fundec *) | ||
214 : | val nbody = C.inside f (fn()=> loop body) | ||
215 : | val nsv = Fun(f, nbody, args, fk, od) | ||
216 : | |||
217 : | val _ = (* update the subst with the new code *) | ||
218 : | case nbody (* look for eta redex *) | ||
219 : | of F.APP(g,vs) => | ||
220 : | if vs = (map (F.VAR o #1) args) | ||
221 : | then substitute (f, val2sval g, g) | ||
222 : | else addbind (f, nsv) | ||
223 : | | _ => addbind (f, nsv) | ||
224 : | in cfun fs ((fk, f, args, nbody)::acc) | ||
225 : | end | ||
226 : | else cfun fs acc | ||
227 : | |||
228 : | (* register the new bindings. We register them | ||
229 : | * uncontracted first, for the needs of mutual recursion, | ||
230 : | * and then we replace the contracted versions as they | ||
231 : | * become available *) | ||
232 : | val _ = app (fn fdec as (fk,f,args,body) => | ||
233 : | addbind (f, Fun(f, body, args, fk, od))) | ||
234 : | fs | ||
235 : | |||
236 : | (* recurse on the bodies *) | ||
237 : | val fs = cfun fs [] | ||
238 : | |||
239 : | val nle = loop le (* contract the main body *) | ||
240 : | val fs = List.filter (used o #2) fs (* junk newly unused funs *) | ||
241 : | monnier | 58 | in |
242 : | if List.null fs | ||
243 : | then nle | ||
244 : | else F.FIX(fs,nle) | ||
245 : | monnier | 63 | end |
246 : | monnier | 58 | |
247 : | | F.APP (f,vs) => | ||
248 : | monnier | 63 | let val nvs = map substval vs |
249 : | monnier | 58 | in case val2sval f |
250 : | of Fun(g,body,args,fk,od) => | ||
251 : | (ASSERT(C.usenb g > 0, "C.usenb g > 0"); | ||
252 : | if C.usenb g = 1 andalso od = d andalso not (C.recursive g) | ||
253 : | |||
254 : | (* simple inlining: we should copy the body and then | ||
255 : | * kill the function, but instead we keep the body | ||
256 : | * and kill only the function name *) | ||
257 : | then (C.unuse (fn lv => ()) true g; | ||
258 : | cexp (d,od) (F.LET(map #1 args, F.RET nvs, body))) | ||
259 : | |||
260 : | (* no inlining: just substitute the vars and vals *) | ||
261 : | else F.APP(F.VAR g, nvs)) | ||
262 : | |||
263 : | | sv => F.APP(sval2val sv, nvs) | ||
264 : | monnier | 63 | end |
265 : | monnier | 58 | |
266 : | | F.TFN ((f,args,body),le) => | ||
267 : | monnier | 63 | if used f then |
268 : | let (* val _ = addbind (f, TFun(f, body, args, od)) *) | ||
269 : | val nbody = cexp (DI.next d, DI.next od) body | ||
270 : | val _ = addbind (f, TFun(f, nbody, args, od)) | ||
271 : | val nle = loop le | ||
272 : | in | ||
273 : | if used f | ||
274 : | then F.TFN((f, args, nbody), nle) | ||
275 : | else nle | ||
276 : | end | ||
277 : | else loop le | ||
278 : | monnier | 58 | |
279 : | | F.TAPP(f,tycs) => F.TAPP(substval f, tycs) | ||
280 : | |||
281 : | | F.SWITCH (v,ac,arms,def) => | ||
282 : | monnier | 63 | (case val2sval v |
283 : | of sv as (Val(F.VAR lv) | Select(lv,_,_)) => | ||
284 : | (let fun carm (F.DATAcon(dc,tycs,lv),le) = | ||
285 : | (addbind(lv, Val(F.VAR lv)); | ||
286 : | (F.DATAcon(cdcon dc, tycs, lv), loop le)) | ||
287 : | | carm (con,le) = (con, loop le) | ||
288 : | val narms = map carm arms | ||
289 : | val ndef = Option.map loop def | ||
290 : | in | ||
291 : | F.SWITCH(sval2val sv, ac, narms, ndef) | ||
292 : | end handle x => raise x) | ||
293 : | |||
294 : | | Con (lvc,v,(_,conrep,_)) => | ||
295 : | let fun carm ((F.DATAcon((_,crep,_),tycs,lv),le)::tl) = | ||
296 : | if crep = conrep then | ||
297 : | (substitute(lv, val2sval v, F.VAR lvc); | ||
298 : | loop le) | ||
299 : | else carm tl | ||
300 : | | carm [] = loop (Option.valOf def) | ||
301 : | | carm _ = buglexp("unexpected arm in switch(con,...)", le) | ||
302 : | in carm arms | ||
303 : | end | ||
304 : | |||
305 : | | Val v => | ||
306 : | let fun carm ((con,le)::tl) = | ||
307 : | if eqConV(con, v) then loop le else carm tl | ||
308 : | | carm [] = loop(Option.valOf def) | ||
309 : | in carm arms | ||
310 : | end | ||
311 : | | sv => bugval("unexpected switch argument", sval2val sv)) | ||
312 : | monnier | 58 | |
313 : | | F.CON (dc,tycs,v,lv,le) => | ||
314 : | let val ndc = cdcon dc | ||
315 : | in clet1 (fn [nv] => Con(lv, nv, ndc), | ||
316 : | fn ([nv],nle) => F.CON(ndc, tycs, nv, lv, nle)) | ||
317 : | (lv,[v],le) | ||
318 : | end | ||
319 : | |||
320 : | | F.RECORD (rk,vs,lv,le) => | ||
321 : | clet1 (fn nvs => Record(lv, nvs), | ||
322 : | fn (nvs,nle) => F.RECORD(rk, nvs, lv, nle)) | ||
323 : | (lv,vs,le) | ||
324 : | |||
325 : | | F.SELECT (v,i,lv,le) => | ||
326 : | if used lv then | ||
327 : | case val2sval v | ||
328 : | of Record (lvr,vs) => | ||
329 : | (let val sv = val2sval (List.nth(vs, i)) | ||
330 : | in substitute (lv, sv, F.VAR lvr); | ||
331 : | loop le | ||
332 : | end handle x => raise x) | ||
333 : | | sv => | ||
334 : | (let val nv = sval2val sv | ||
335 : | val _ = addbind (lv, Select(lv, nv, i)) | ||
336 : | val nle = loop le | ||
337 : | in if used lv then F.SELECT(nv, i, lv, nle) else nle | ||
338 : | end handle x => raise x) | ||
339 : | else loop le | ||
340 : | |||
341 : | | F.RAISE (v,ltys) => F.RAISE(substval v, ltys) | ||
342 : | |||
343 : | | F.HANDLE (le,v) => F.HANDLE(loop le, substval v) | ||
344 : | |||
345 : | | F.BRANCH (po,vs,le1,le2) => | ||
346 : | monnier | 63 | let val nvs = map substval vs |
347 : | val npo = cpo po | ||
348 : | val nle1 = loop le1 | ||
349 : | val nle2 = loop le2 | ||
350 : | monnier | 58 | in F.BRANCH(npo, nvs, nle1, le2) |
351 : | monnier | 63 | end |
352 : | monnier | 58 | |
353 : | | F.PRIMOP (po,vs,lv,le) => | ||
354 : | monnier | 63 | let val nvs = map substval vs |
355 : | val npo = cpo po | ||
356 : | val _ = addbind(lv, Val(F.VAR lv)) | ||
357 : | val nle = loop le | ||
358 : | monnier | 58 | in if impurePO po orelse used lv |
359 : | then F.PRIMOP(npo, nvs, lv, nle) | ||
360 : | else nle | ||
361 : | monnier | 63 | end |
362 : | monnier | 58 | |
363 : | monnier | 63 | end |
364 : | monnier | 58 | |
365 : | fun contract (fdec as (_,f,_,_)) = | ||
366 : | let val _ = M.clear m | ||
367 : | val F.FIX([fdec], F.RET[F.VAR f]) = | ||
368 : | cexp (DI.top,DI.top) (F.FIX([fdec], F.RET[F.VAR f])) | ||
369 : | val _ = M.clear m | ||
370 : | in fdec | ||
371 : | end | ||
372 : | |||
373 : | end | ||
374 : | end |
root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
Powered by ViewVC 1.0.0 |