Annotation of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml

Parent Directory | Revision Log

---

Revision 121 - (view) (download)

1 :	monnier	121	(* 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.sml does that fcontract doesn't do (yet):
20 :			* - inline across DeBruijn depths
21 :			* - elimination of let [dead-vs] = pure in body
22 :			*)
23 :
24 :			(* things that cpsopt/eta.sml did that fcontract doesn't do:
25 :			* - let f vs = select(v,i,g,g vs)
26 :			*)
27 :
28 :			(* things that cpsopt/contract.sml did that fcontract doesn't do:
29 :			* - IF-idiom
30 :			* - unifying branches
31 :			* - Handler operations
32 :			* - primops expressions
33 :			* - branch expressions
34 :			* - dropping of arguments
35 :			*)
36 :
37 :			(* things that could also be added:
38 :			* - elimination of dead vars in let (subsumes what lcontract does)
39 :			* - elimination of Con(Decon x)
40 :			* - elimination of Record(a.1, a.2, ...)
41 :			* - update counts when selecting a SWITCH alternative
42 :			*)
43 :
44 :			(* things that would require some type info:
45 :			* - dropping foo in LET vs = RAISE v IN foo
46 :			* - contracting RECORD(R.1,R.2) => R
47 :			*)
48 :
49 :			(* eta-reduction is tricky:
50 :			* - recognition of eta-redexes and introduction of the corresponding
51 :			* substitution in the table has to be done at the very beginning of
52 :			* the processing of the FIX
53 :			* - eta-reduction can turn a known function into an escaping function
54 :			* - fun f (g,v2,v3) = g(g,v2,v3) looks tremendously like an eta-redex
55 :			*)
56 :
57 :			(* order of contraction is important:
58 :			* - the body of a FIX is contracted before the functions because the
59 :			* functions might end up being inlined in the body in which case they
60 :			* could be contracted twice.
61 :			*)
62 :
63 :			(* When creating substitution f->g (as happens with eta redexes or with
64 :			* code like `LET [f] = RET[g]'), we need to make sure that the usage cout
65 :			* of f gets properly transfered to g. One way to do that is to make the
66 :			* transfer incremental: each time we apply the substitution, we decrement
67 :			* f's count and increment g's count. But this can be tricky since the
68 :			* elimination of the eta-redex (or the trivial binding) eliminates one of the
69 :			* references to g and if thyis is the only one, we might trigger the killing
70 :			* of g even though its count would be later incremented. Similarly, inlining
71 :			* of g would be dangerous as long as some references to f exist.
72 :			* So instead we do the transfer once and for all when we see the eta-redex,
73 :			* which frees us from those two problems but forces us to make sure that
74 :			* every existing reference to f will be substituted with g.
75 :			* Also, the transfer of counts from f to g is not quite straightforward
76 :			* since some of the references to f might be from inside g and without doing
77 :			* the transfer incrementally, we can't easily know which of the usage counts
78 :			* of f should be transfered to the internal counts of g and which to the
79 :			* external counts.
80 :			*)
81 :
82 :			(* Simple inlining (inlining called-once functions, which doesn't require
83 :			* alpha-renaming) seems inoffensive enough but is not always desirable.
84 :			* The typical example is wrapper functions introduced by fexpand: they
85 :			* usually (until inlined) contain the only call the the main function,
86 :			* but inlining the main function in the wrapper defeats the purpose of the
87 :			* wrapper.
88 :			* cpsopt dealt with this problem by adding a `NO_INLINE_INTO' hint to the
89 :			* wrapper function. In this file, the idea is to be careful instead:
90 :			* - all functions (even the ones that would have a `NO_INLINE_INTO') are
91 :			* contracted, because the "aggressive usage count maintenance" makes any
92 :			* alternative painful (the collect phase has already assumed that dead code
93 :			* will be eliminated, which means that fcontract should at the very least
94 :			* do the dead-code elimination, so you can only avoid fcontracting if you
95 :			* can be sure that the body doesn't contain any dead-code, which is generally
96 :			* not known).
97 :			* - once a function is fcontracted it is marked as non-inlinable since
98 :			* fcontractiong might have changed its form considerably (via inlining).
99 :			* - to ensure that this de-inlining doesn't prevent too much inlining, the
100 :			* inlineable functions should be contracted late.
101 :			* - at the very end of the optimization phase, cpsopt had a special pass
102 :			* that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
103 :			* into it doesn't have any undesirable side effects any more). The present
104 :			* code doesn't need such a thing. On another hand, the cpsopt approach
105 :			* had the advantage of keeping the `inline' bit from one contract phase to
106 :			* the next. If this ends up being important, I could add a global
107 :			* "noinline" flag that could be set to true whenever fcontracting an
108 :			* inlinable function.
109 :			*)
110 :
111 :			structure FContract :> FCONTRACT =
112 :			struct
113 :			local
114 :			structure F = FLINT
115 :			structure M = IntmapF
116 :			structure C = Collect
117 :			structure DI = DebIndex
118 :			structure PP = PPFlint
119 :			structure LV = LambdaVar
120 :			in
121 :
122 :			val say = Control.Print.say
123 :			fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
124 :			fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
125 :			fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
126 :
127 :			(* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
128 :
129 :			fun ASSERT (true,_) = ()
130 :			| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
131 :
132 :			(* copy an lexp, with alpha renaming. Could be moved to flint.sml
133 :			* since it's very generic (though probably not useful at many other places) *)
134 :			fun copy alpha le = let
135 :			fun substvar lv = ((M.lookup alpha lv) handle M.IntmapF => lv)
136 :			fun substval (F.VAR lv) = F.VAR(substvar lv)
137 :			| substval v = v
138 :			fun newv (lv,alpha) =
139 :			let val nlv = LV.mkLvar() in (nlv, M.add(alpha,lv,nlv)) end
140 :			fun newvs (lvs,alpha) =
141 :			foldr (fn (lv,(lvs,alpha)) =>
142 :			let val (nlv,nalpha) = newv(lv,alpha) in (nlv::lvs,nalpha) end)
143 :			([],alpha) lvs
144 :			fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
145 :			(s, Access.EXN(Access.LVAR(substvar lv)), lty)
146 :			| cdcon dc = dc
147 :			fun cpo (SOME{default,table},po,lty,tycs) =
148 :			(SOME{default=substvar default,
149 :			table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
150 :			po,lty,tycs)
151 :			| cpo po = po
152 :			in case le
153 :			of F.RET vs => F.RET(map substval vs)
154 :			| F.LET (lvs,le,body) =>
155 :			let val nle = copy alpha le
156 :			val (nlvs,nalpha) = newvs(lvs,alpha)
157 :			in F.LET(nlvs, nle, copy nalpha body)
158 :			end
159 :			| F.FIX (fdecs,le) =>
160 :			let fun cfun alpha ((fk,f,args,body):F.fundec,nf) =
161 :			let val (nargs,nalpha) = newvs(map #1 args, alpha)
162 :			in (fk, nf, ListPair.zip(nargs, (map #2 args)), copy nalpha body)
163 :			end
164 :			val (nfs, nalpha) = newvs(map #2 fdecs, alpha)
165 :			val nfdecs = ListPair.map (cfun nalpha) (fdecs, nfs)
166 :			in
167 :			F.FIX(nfdecs, copy nalpha le)
168 :			end
169 :			| F.APP (f,args) => F.APP(substval f, map substval args)
170 :			| F.TFN ((lv,args,body),le) =>
171 :			(* don't forget to rename the tvar also *)
172 :			let val (nlv,nalpha) = newv(lv,alpha)
173 :			val (nargs,ialpha) = newvs(map #1 args, nalpha)
174 :			in F.TFN((nlv, ListPair.zip(nargs, map #2 args), copy ialpha body),
175 :			copy nalpha le)
176 :			end
177 :			| F.TAPP (f,tycs) => F.TAPP(substval f, tycs)
178 :			| F.SWITCH (v,ac,arms,def) =>
179 :			let fun carm (F.DATAcon(dc,tycs,lv),le) =
180 :			let val (nlv,nalpha) = newv(lv, alpha)
181 :			in (F.DATAcon(cdcon dc, tycs, nlv), copy nalpha le)
182 :			end
183 :			| carm (con,le) = (con, copy alpha le)
184 :			in F.SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)
185 :			end
186 :			| F.CON (dc,tycs,v,lv,le) =>
187 :			let val (nlv,nalpha) = newv(lv, alpha)
188 :			in F.CON(cdcon dc, tycs, substval v, nlv, copy nalpha le)
189 :			end
190 :			| F.RECORD (rk,vs,lv,le) =>
191 :			let val (nlv,nalpha) = newv(lv, alpha)
192 :			in F.RECORD(rk, map substval vs, nlv, copy nalpha le)
193 :			end
194 :			| F.SELECT (v,i,lv,le) =>
195 :			let val (nlv,nalpha) = newv(lv, alpha)
196 :			in F.SELECT(substval v, i, nlv, copy nalpha le)
197 :			end
198 :			| F.RAISE (v,ltys) => F.RAISE(substval v, ltys)
199 :			| F.HANDLE (le,v) => F.HANDLE(copy alpha le, substval v)
200 :			| F.BRANCH (po,vs,le1,le2) =>
201 :			F.BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)
202 :			| F.PRIMOP (po,vs,lv,le) =>
203 :			let val (nlv,nalpha) = newv(lv, alpha)
204 :			in F.PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
205 :			end
206 :			end
207 :
208 :			datatype sval
209 :			= Val of F.value (* F.value should never be F.VAR lv *)
210 :			| Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth
211 :			| TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
212 :			| Record of F.lvar * F.value list
213 :			| Con of F.lvar * F.value * F.dcon
214 :			| Select of F.lvar * F.value * int
215 :			| Var of F.lvar * F.lty option (* cop out case *)
216 :
217 :			fun cexp (cfg as (d,od)) m le = let
218 :
219 :			val loop = cexp cfg
220 :
221 :			fun used lv = C.usenb lv > 0
222 :
223 :			fun impurePO po = true (* if a PrimOP is pure or not *)
224 :
225 :			fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2
226 :			| eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2
227 :			| eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2
228 :			| eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2
229 :			| eqConV (F.REALcon r1, F.REAL r2) = r1 = r2
230 :			| eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2
231 :			| eqConV (con,v) = bugval("unexpected comparison with val", v)
232 :
233 :			fun lookup m lv = (M.lookup m lv)
234 :			(* handle e as M.IntmapF =>
235 :			(say "\nlooking up unbound ";
236 :			say (!PP.LVarString lv);
237 :			raise e) *)
238 :
239 :			fun sval2val sv =
240 :			case sv
241 :			of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}
242 :			| Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
243 :			| Val v => v
244 :
245 :			fun val2sval m (F.VAR ov) = lookup m ov
246 :			| val2sval m v = Val v
247 :
248 :			fun bugsv (msg,sv) = bugval(msg, sval2val sv)
249 :
250 :			fun subst m ov = sval2val (lookup m ov)
251 :			val substval = sval2val o (val2sval m)
252 :			fun substvar lv =
253 :			case substval(F.VAR lv)
254 :			of F.VAR lv => lv
255 :			| v => bugval ("unexpected val", v)
256 :
257 :			fun unuseval f (F.VAR lv) = C.unuse f false lv
258 :			| unuseval f _ = ()
259 :
260 :			(* called when a variable becomes dead.
261 :			* it simply adjusts the use-counts *)
262 :			fun undertake m lv =
263 :			let val undertake = undertake m
264 :			in case lookup m lv
265 :			of Var {1=nlv,...} => ASSERT(nlv = lv, "nlv = lv")
266 :			| Val v => ()
267 :			| Fun (lv,le,args,_,_) =>
268 :			C.unusefdec undertake (lv, map #1 args, le)
269 :			| TFun{1=lv,2=le,...} => C.unusefdec undertake (lv, [], le)
270 :			| (Select {2=v,...} | Con {2=v,...}) => unuseval undertake v
271 :			| Record {2=vs,...} => app (unuseval undertake) vs
272 :			end
273 :			handle M.IntmapF =>
274 :			(say "\nUnable to undertake "; PP.printSval(F.VAR lv))
275 :			| x =>
276 :			(say "\nwhile undertaking "; PP.printSval(F.VAR lv); raise x)
277 :
278 :			fun addbind (m,lv,sv) = M.add(m, lv, sv)
279 :
280 :			(* substitute a value sv for a variable lv and unuse value v.
281 :			* This doesn't quite work for eta-redex since the `use' we have
282 :			* to remove in that case is a non-escaping use, whereas this code
283 :			* assumes that we're getting rid of an escaping use *)
284 :			fun substitute (m, lv1, sv, v) =
285 :			(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
286 :			unuseval (undertake m) v;
287 :			addbind(m, lv1, sv)) handle x =>
288 :			(say "\nwhile substituting ";
289 :			PP.printSval (F.VAR lv1);
290 :			say " for ";
291 :			PP.printSval (sval2val sv);
292 :			raise x)
293 :
294 :			(* common code for primops *)
295 :			fun cpo (SOME{default,table},po,lty,tycs) =
296 :			(SOME{default=substvar default,
297 :			table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
298 :			po,lty,tycs)
299 :			| cpo po = po
300 :
301 :			fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
302 :			(s, Access.EXN(Access.LVAR(substvar lv)), lty)
303 :			| cdcon dc = dc
304 :
305 :			(* F.APP inlining (if any) *)
306 :			fun inline (f,vs) =
307 :			case ((val2sval m f) handle x => raise x)
308 :			of Fun(g,body,args,F.FK_FUN{isrec,inline,...},od) =>
309 :			(ASSERT(C.usenb g > 0, "C.usenb g > 0");
310 :			if C.usenb g = 1 andalso od = d andalso not (C.recursive g)
311 :
312 :			(* simple inlining: we should copy the body and then
313 :			* kill the function, but instead we just move the body
314 :			* and kill only the function name. This inlining strategy
315 :			* looks inoffensive enough, but still requires some care:
316 :			* see comments at the begining of this file and in cfun *)
317 :			then (C.unuse (fn _ => ()) true g; ASSERT(not (used g), "killed");
318 :			SOME(F.LET(map #1 args, F.RET vs, body), od))
319 :
320 :			(* aggressive inlining (but hopefully safe). We allow
321 :			* inlining for mutually recursive functions (isrec)
322 :			* despite the potential risk. The reason is that it can
323 :			* happen that a wrapper (that should be inlined) has to be made
324 :			* mutually recursive with its main function. On another hand,
325 :			* self recursion (C.recursive) is too dangerous to be inlined
326 :			* except for loop unrolling which we don't support yet *)
327 :			else if inline andalso od = d andalso not(C.recursive g) then
328 :			let val nle = copy M.empty (F.LET(map #1 args, F.RET vs, body))
329 :			in C.uselexp nle;
330 :			app (unuseval (undertake m)) vs;
331 :			C.unuse (undertake m) true g;
332 :			SOME(nle, od)
333 :			end
334 :
335 :			else NONE)
336 :			| sv => NONE
337 :			in
338 :			case le
339 :			of F.RET vs => F.RET((map substval vs) handle x => raise x)
340 :
341 :			| F.LET (lvs,le,body) =>
342 :			let fun cassoc le = F.LET(lvs, le, body)
343 :			(* default behavior *)
344 :			fun clet () =
345 :			let val nle = loop m le
346 :			val nm = foldl (fn (lv,m) => addbind(m, lv, Var(lv, NONE)))
347 :			m lvs
348 :			in case loop nm body
349 :			of F.RET vs => if vs = (map F.VAR lvs) then nle
350 :			else F.LET(lvs, nle, F.RET vs)
351 :			| nbody => F.LET(lvs, nle, nbody)
352 :			end
353 :			val lopm = loop m
354 :			in case le
355 :			(* apply let associativity *)
356 :			of F.LET(lvs1,le',le) => lopm(F.LET(lvs1, le', cassoc le))
357 :			| F.FIX(fdecs,le) => lopm(F.FIX(fdecs, cassoc le))
358 :			| F.TFN(tfdec,le) => lopm(F.TFN(tfdec, cassoc le))
359 :			| F.CON(dc,tycs,v,lv,le) => lopm(F.CON(dc, tycs, v, lv, cassoc le))
360 :			| F.RECORD(rk,vs,lv,le) => lopm(F.RECORD(rk, vs, lv, cassoc le))
361 :			| F.SELECT(v,i,lv,le) => lopm(F.SELECT(v, i, lv, cassoc le))
362 :			| F.PRIMOP(po,vs,lv,le) => lopm(F.PRIMOP(po, vs, lv, cassoc le))
363 :			(* this is a hack originally meant to cleanup the BRANCH mess
364 :			* introduced in flintnm (where each branch returns just true or
365 :			* false which is generally only used as input to a SWITCH).
366 :			* The present code does slightly more than clean up this case *)
367 :			| F.BRANCH (po,vs,le1,le2) =>
368 :			let fun known (F.RECORD(_,_,_,le)) = known le
369 :			| known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')
370 :			| known (F.RET[F.VAR v]) = false
371 :			| known (F.RET[_]) = true
372 :			| known _ = false
373 :			fun cassoc (lv,v,body) wrap =
374 :			if lv = v andalso C.usenb lv = 1 andalso
375 :			known le1 andalso known le2 then
376 :			(* here I should also check that le1 != le2 *)
377 :			let val nle1 = F.LET([lv], le1, body)
378 :			val nlv = LV.mkLvar()
379 :			val body2 = copy (M.add(M.empty,lv,nlv)) body
380 :			val nle2 = F.LET([nlv], le2, body2)
381 :			in C.new false nlv; C.uselexp body2;
382 :			lopm(wrap(F.BRANCH(po, vs, nle1, nle2)))
383 :			end
384 :			else
385 :			clet()
386 :			in case (lvs,body)
387 :			of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
388 :			cassoc(lv, v, le) (fn x => x)
389 :			| ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
390 :			cassoc(lv, v, le) (fn le => F.LET(lvs,le,rest))
391 :			| _ => clet()
392 :			end
393 :			| F.RET vs =>
394 :			(let fun simplesubst ((lv,v),m) =
395 :			let val sv = (val2sval m v) handle x => raise x
396 :			in substitute(m, lv, sv, sval2val sv)
397 :			end
398 :			in loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body
399 :			end handle x => raise x)
400 :			| F.APP(f,vs) =>
401 :			(case inline(f, vs)
402 :			of SOME(le,od) => cexp (d,od) m (F.LET(lvs, le, body))
403 :			| NONE => clet())
404 :			| (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>
405 :			clet()
406 :			end
407 :
408 :			| F.FIX (fs,le) =>
409 :			let fun cfun (m,[]:F.fundec list,acc) = acc
410 :			| cfun (m,fdec as (fk,f,args,body)::fs,acc) =
411 :			if used f then
412 :			let (* make up the bindings for args inside the body *)
413 :			fun addnobind ((lv,lty),m) =
414 :			addbind(m, lv, Var(lv, SOME lty))
415 :			val nm = foldl addnobind m args
416 :			(* contract the body and create the resulting fundec *)
417 :			val nbody = C.inside f (fn()=> loop nm body)
418 :			(* fixup the fkind info with new data.
419 :			* C.recursive only tells us if a fun is self-recursive
420 :			* but doesn't deal with mutual recursion.
421 :			* Also the `inline' bit has to be turned off because
422 :			* it applied to the function before contraction
423 :			* but might not apply to its new form (inlining might
424 :			* have increased its size substantially or made it
425 :			* recursive in a different way which could make further
426 :			* inlining even dangerous) *)
427 :			val nfk =
428 :			case fk of F.FK_FCT => fk
429 :			| F.FK_FUN {isrec,fixed,known,inline} =>
430 :			let val nisrec = if isSome isrec andalso
431 :			null fs andalso
432 :			null acc andalso
433 :			not(C.recursive f)
434 :			then NONE else isrec
435 :			val nknown = known orelse not(C.escaping f)
436 :			in F.FK_FUN{isrec=nisrec, fixed=fixed,
437 :			inline=false, known=nknown}
438 :			end
439 :			(* update the binding in the map. This step is not
440 :			* not just a mere optimization but is necessary
441 :			* because if we don't do it and the function
442 :			* gets inlined afterwards, the counts will reflect the
443 :			* new contracted code while we'll be working on the
444 :			* the old uncontracted code *)
445 :			val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))
446 :			in cfun(nm, fs, (nfk, f, args, nbody)::acc)
447 :			end
448 :			else cfun(m, fs, acc)
449 :
450 :			(* check for eta redex *)
451 :			fun ceta ((fk,f,args,F.APP(g,vs)):F.fundec,(m,hs)) =
452 :			if vs = (map (F.VAR o #1) args) andalso
453 :			(* don't forget to check that g is not one of the args
454 :			* and not f itself either *)
455 :			(List.find (fn v => v = g) (F.VAR f::vs)) = NONE
456 :			then
457 :			let val svg = val2sval m g
458 :			val g = case sval2val svg
459 :			of F.VAR g => g
460 :			| v => bugval("not a variable", v)
461 :			(* NOTE: we don't want to turn a known function into an
462 :			* escaping one. It's dangerous for optimisations based
463 :			* on known functions (elimination of dead args, f.ex)
464 :			* and could generate cases where call>use in collect *)
465 :			in if not (C.escaping f andalso
466 :			not (C.escaping g))
467 :			then let
468 :			(* if an earlier function h has been eta-reduced
469 :			* to f, we have to be careful to update its
470 :			* binding to not refer to f any more since f
471 :			* will disappear *)
472 :			val nm = foldl (fn (h,m) =>
473 :			if sval2val(lookup m h) = F.VAR f
474 :			then addbind(m, h, svg) else m)
475 :			m hs
476 :			in
477 :			(* if g is one of the members of the FIX, f might
478 :			* appear in its body, so we don't know what parts
479 :			* of the counts of f should be counted as inside
480 :			* g and what parts should be counted as outside
481 :			* so we take the conservative approach of counting
482 :			* them in both *)
483 :			if isSome(List.find (fn (_,f,_,_) => f = g) fs)
484 :			then C.inside g (fn()=> C.addto(f,g)) else ();
485 :			C.transfer(f,g); C.unuse (undertake nm) true g;
486 :			(addbind(nm, f, svg),f::hs)
487 :			end
488 :			else (m, hs)
489 :			end
490 :			else (m, hs)
491 :			| ceta (_,(m,hs)) = (m, hs)
492 :
493 :			(* junk unused funs *)
494 :			val fs = List.filter (used o #2) fs
495 :
496 :			(* register the new bindings (uncontracted for now) *)
497 :			val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
498 :			addbind(m, f, Fun(f, body, args, fk, od)))
499 :			m fs
500 :			(* check for eta redexes *)
501 :			val (nm,_) = foldl ceta (nm,[]) fs
502 :
503 :			(* move the inlinable functions to the end of the list *)
504 :			val (f1s,f2s) =
505 :			List.partition (fn (F.FK_FUN{inline,...},_,_,_) => inline
506 :			| _ => false) fs
507 :			val fs = f2s @ f1s
508 :
509 :			(* contract the main body *)
510 :			val nle = loop nm le
511 :			(* contract the functions *)
512 :			val fs = cfun(nm, fs, [])
513 :			(* junk newly unused funs *)
514 :			val fs = List.filter (used o #2) fs
515 :			in
516 :			if List.null fs then nle else F.FIX(fs,nle)
517 :			end
518 :
519 :			| F.APP (f,vs) =>
520 :			let val nvs = ((map substval vs) handle x => raise x)
521 :			in case inline(f, nvs)
522 :			of SOME(le,od) => cexp (d,od) m le
523 :			| NONE => F.APP((substval f) handle x => raise x, nvs)
524 :			end
525 :
526 :			| F.TFN ((f,args,body),le) =>
527 :			if used f then
528 :			let val nbody = cexp (DI.next d, DI.next od) m body
529 :			val nm = addbind(m, f, TFun(f, nbody, args, od))
530 :			val nle = loop nm le
531 :			in
532 :			if used f then F.TFN((f, args, nbody), nle) else nle
533 :			end
534 :			else loop m le
535 :
536 :			| F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)
537 :
538 :			| F.SWITCH (v,ac,arms,def) =>
539 :			(case ((val2sval m v) handle x => raise x)
540 :			of sv as (Var{1=lvc,...} | Select{1=lvc,...} | Record{1=lvc,...}) =>
541 :			let fun carm (F.DATAcon(dc,tycs,lv),le) =
542 :			let val ndc = cdcon dc
543 :			(* here I should try to extract the type of lv *)
544 :			val nm = addbind(m, lv, Var(lv, NONE))
545 :			(* we can rebind lv to a more precise value *)
546 :			val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc))
547 :			in (F.DATAcon(ndc, tycs, lv), loop nm le)
548 :			end
549 :			| carm (con,le) = (con, loop m le)
550 :			val narms = map carm arms
551 :			val ndef = Option.map (loop m) def
552 :			in
553 :			F.SWITCH(sval2val sv, ac, narms, ndef)
554 :			end
555 :
556 :			| Con (lvc,v,(_,conrep,_)) =>
557 :			let fun carm ((F.DATAcon((_,crep,_),tycs,lv),le)::tl) =
558 :			if crep = conrep then
559 :			loop (substitute(m, lv, (val2sval m v) handle x => raise x, F.VAR lvc)) le
560 :			else carm tl
561 :			| carm [] = loop m (Option.valOf def)
562 :			| carm _ = buglexp("unexpected arm in switch(con,...)", le)
563 :			in carm arms
564 :			end
565 :
566 :			| Val v =>
567 :			let fun carm ((con,le)::tl) =
568 :			if eqConV(con, v) then loop m le else carm tl
569 :			| carm [] = loop m (Option.valOf def)
570 :			in carm arms
571 :			end
572 :			| sv as (Fun _ | TFun _) =>
573 :			bugval("unexpected switch arg", sval2val sv))
574 :
575 :			| F.CON (dc,tycs,v,lv,le) =>
576 :			if used lv then
577 :			let val ndc = cdcon dc
578 :			val nv = ((substval v) handle x => raise x)
579 :			val nm = addbind(m, lv, Con(lv, nv, ndc))
580 :			val nle = loop nm le
581 :			in if used lv then F.CON(ndc, tycs, nv, lv, nle) else nle
582 :			end
583 :			else loop m le
584 :
585 :			| F.RECORD (rk,vs,lv,le) =>
586 :			(* Here I could try to see if I'm reconstructing a preexisting record.
587 :			* The `lty option' of Var is there just for that purpose *)
588 :			if used lv then
589 :			let val nvs = ((map substval vs) handle x => raise x)
590 :			val nm = addbind(m, lv, Record(lv, nvs))
591 :			val nle = loop nm le
592 :			in if used lv then F.RECORD(rk, nvs, lv, nle) else nle
593 :			end
594 :			else loop m le
595 :
596 :			| F.SELECT (v,i,lv,le) =>
597 :			if used lv then
598 :			case ((val2sval m v) handle x => raise x)
599 :			of Record (lvr,vs) =>
600 :			let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x
601 :			in loop (substitute(m, lv, sv, F.VAR lvr)) le
602 :			end
603 :			| sv =>
604 :			let val nv = sval2val sv
605 :			val nm = addbind (m, lv, Select(lv, nv, i))
606 :			val nle = loop nm le
607 :			in if used lv then F.SELECT(nv, i, lv, nle) else nle
608 :			end
609 :			else loop m le
610 :
611 :			| F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)
612 :
613 :			| F.HANDLE (le,v) => F.HANDLE(loop m le, (substval v) handle x => raise x)
614 :
615 :			| F.BRANCH (po,vs,le1,le2) =>
616 :			let val nvs = ((map substval vs) handle x => raise x)
617 :			val npo = cpo po
618 :			val nle1 = loop m le1
619 :			val nle2 = loop m le2
620 :			in F.BRANCH(npo, nvs, nle1, nle2)
621 :			end
622 :
623 :			| F.PRIMOP (po,vs,lv,le) =>
624 :			let val impure = impurePO po
625 :			in if impure orelse used lv then
626 :			let val nvs = ((map substval vs) handle x => raise x)
627 :			val npo = cpo po
628 :			val nm = addbind(m, lv, Var(lv,NONE))
629 :			val nle = loop nm le
630 :			in
631 :			if impure orelse used lv
632 :			then F.PRIMOP(npo, nvs, lv, nle)
633 :			else nle
634 :			end
635 :			else loop m le
636 :			end
637 :			end
638 :
639 :			fun contract (fdec as (_,f,_,_)) =
640 :			(C.collect fdec;
641 :			case cexp (DI.top,DI.top) M.empty (F.FIX([fdec], F.RET[F.VAR f]))
642 :			of F.FIX([fdec], F.RET[F.VAR f]) => fdec
643 :			| fdec => bug "invalid return fundec")
644 :
645 :			end
646 :			end

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0