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

Parent Directory | Revision Log

---

Revision 532 - (view) (download)

1 :	monnier	121	(* copyright 1998 YALE FLINT PROJECT *)
2 :	monnier	159	(* monnier@cs.yale.edu *)
3 :	monnier	121
4 :			signature FCONTRACT =
5 :			sig
6 :	monnier	259
7 :			type options = {etaSplit : bool, tfnInline : bool}
8 :	monnier	121
9 :			(* needs Collect to be setup properly *)
10 :	monnier	259	val contract : options -> FLINT.prog -> FLINT.prog
11 :
12 :	monnier	121	end
13 :
14 :			(* All kinds of beta-reductions. In order to do as much work per pass as
15 :			* possible, the usage counts of each variable (maintained by the Collect
16 :			* module) is kept as much uptodate as possible. For instance as soon as a
17 :			* variable becomes dead, all the variables that were referenced have their
18 :			* usage counts decremented correspondingly. This means that we have to
19 :			* be careful to make sure that a dead variable will indeed not appear
20 :			* in the output lexp since it might else reference other dead variables *)
21 :
22 :	monnier	159	(* things that fcontract does:
23 :			* - several things not mentioned
24 :			* - elimination of Con(Decon x)
25 :			* - update counts when selecting a SWITCH alternative
26 :	monnier	162	* - contracting RECORD(R.1,R.2) => R (only if the type is easily available)
27 :	monnier	184	* - dropping of dead arguments
28 :	monnier	159	*)
29 :
30 :	monnier	121	(* things that lcontract.sml does that fcontract doesn't do (yet):
31 :	monnier	159	* - inline across DeBruijn depths (will be solved by named-tvar)
32 :	monnier	121	* - elimination of let [dead-vs] = pure in body
33 :			*)
34 :
35 :			(* things that cpsopt/eta.sml did that fcontract doesn't do:
36 :	monnier	159	* - let f vs = select(v,i,g,g vs)
37 :	monnier	121	*)
38 :
39 :			(* things that cpsopt/contract.sml did that fcontract doesn't do:
40 :	monnier	159	* - IF-idiom (I still don't know what it is)
41 :	monnier	121	* - unifying branches
42 :			* - Handler operations
43 :			* - primops expressions
44 :			* - branch expressions
45 :			*)
46 :
47 :			(* things that could also be added:
48 :	monnier	184	* - elimination of dead vars in let
49 :	monnier	191	* - elimination of constant arguments
50 :	monnier	121	*)
51 :
52 :			(* things that would require some type info:
53 :			* - dropping foo in LET vs = RAISE v IN foo
54 :			*)
55 :
56 :			(* eta-reduction is tricky:
57 :			* - recognition of eta-redexes and introduction of the corresponding
58 :			* substitution in the table has to be done at the very beginning of
59 :			* the processing of the FIX
60 :			* - eta-reduction can turn a known function into an escaping function
61 :			* - fun f (g,v2,v3) = g(g,v2,v3) looks tremendously like an eta-redex
62 :			*)
63 :
64 :			(* order of contraction is important:
65 :			* - the body of a FIX is contracted before the functions because the
66 :			* functions might end up being inlined in the body in which case they
67 :			* could be contracted twice.
68 :			*)
69 :
70 :			(* When creating substitution f->g (as happens with eta redexes or with
71 :			* code like `LET [f] = RET[g]'), we need to make sure that the usage cout
72 :			* of f gets properly transfered to g. One way to do that is to make the
73 :			* transfer incremental: each time we apply the substitution, we decrement
74 :			* f's count and increment g's count. But this can be tricky since the
75 :			* elimination of the eta-redex (or the trivial binding) eliminates one of the
76 :	monnier	159	* references to g and if this is the only one, we might trigger the killing
77 :	monnier	121	* of g even though its count would be later incremented. Similarly, inlining
78 :			* of g would be dangerous as long as some references to f exist.
79 :			* So instead we do the transfer once and for all when we see the eta-redex,
80 :			* which frees us from those two problems but forces us to make sure that
81 :			* every existing reference to f will be substituted with g.
82 :			* Also, the transfer of counts from f to g is not quite straightforward
83 :			* since some of the references to f might be from inside g and without doing
84 :			* the transfer incrementally, we can't easily know which of the usage counts
85 :			* of f should be transfered to the internal counts of g and which to the
86 :			* external counts.
87 :			*)
88 :
89 :	monnier	159	(* Preventing infinite inlining:
90 :			* - inlining a function in its own body amounts to unrolling which has
91 :			* to be controlled (you only want to unroll some number of times).
92 :			* It's currently simply not allowed.
93 :			* - inlining a recursive function outside of tis body amounts to `peeling'
94 :			* one iteration. Here also, since the inlined body will have yet another
95 :			* call, the inlining risks non-termination. It's hence also
96 :			* not allowed.
97 :			* - inlining a mutually recursive function is just a more general form
98 :			* of the problem above although it can be safe and desirable in some cases.
99 :			* To be safe, you simply need that one of the functions forming the
100 :			* mutual-recursion loop cannot be inlined (to break the loop). This cannot
101 :			* be trivially checked. So we (foolishly?) trust the `inline' bit in
102 :			* those cases. This is mostly used to inline wrappers inside the
103 :			* function they wrap.
104 :			* - even if one only allows inlining of funtions showing no sign of
105 :			* recursion, we can be bitten by a program creating its own Y combinator:
106 :			* datatype dt = F of dt -> int -> int
107 :			* let fun f (F g) x = g (F g) x in f (F f) end
108 :			* To solve this problem, `cexp' has an `ifs' parameter containing the set
109 :			* of funtions that we are inlining in order to detect (and break) cycles.
110 :			* - funnily enough, if we allow inlining recursive functions the cycle
111 :			* detection will ensure that the unrolling (or peeling) will only be done
112 :			* once. In the future, maybe.
113 :			*)
114 :
115 :	monnier	184	(* Dropping useless arguments.
116 :			* Arguments whose value is constant (i.e. the function is known and each
117 :			* call site provides the same value for that argument (or the argument
118 :			* itself in the case of recursive calls) can be safely removed and replaced
119 :			* inside the body by a simple let binding. The only problem is that the
120 :			* constant argument might be out of scope at the function definition site.
121 :			* It is obviously always possible to move the function to bring the argument
122 :			* in scope, but since we don't do any code motion here, we're stuck.
123 :			* If it wasn't for this little problem, we could do the cst-arg removal in
124 :			* collect (we don't gain anything from doing it here).
125 :			* The removal of dead arguments (args not used in the body) on the other
126 :			* hand can quite well be done in collect, the only problem being that it
127 :			* is convenient to do it after the cst-arg removal so that we can rely
128 :			* on deadarg to do the actual removal of the cst-arg.
129 :			*)
130 :
131 :	monnier	121	(* Simple inlining (inlining called-once functions, which doesn't require
132 :			* alpha-renaming) seems inoffensive enough but is not always desirable.
133 :	monnier	159	* The typical example is wrapper functions introduced by eta-expand: they
134 :			* usually (until inlined) contain the only call to the main function,
135 :	monnier	121	* but inlining the main function in the wrapper defeats the purpose of the
136 :			* wrapper.
137 :			* cpsopt dealt with this problem by adding a `NO_INLINE_INTO' hint to the
138 :	monnier	159	* wrapper function. In this file, the idea is the following:
139 :			* If you have a function declaration like `let f x = body in exp', first
140 :			* contract `exp' and only contract `body' afterwards. This ensures that
141 :			* the eta-wrapper gets a chance to be inlined before it is (potentially)
142 :			* eta-reduced away. Interesting details:
143 :	monnier	121	* - all functions (even the ones that would have a `NO_INLINE_INTO') are
144 :			* contracted, because the "aggressive usage count maintenance" makes any
145 :			* alternative painful (the collect phase has already assumed that dead code
146 :			* will be eliminated, which means that fcontract should at the very least
147 :	monnier	159	* do the dead-code elimination, so you can only avoid fcontracting a
148 :			* a function if you can be sure that the body doesn't contain any dead-code,
149 :			* which is generally not known).
150 :	monnier	190	* - once a function is fcontracted, its inlinable status is re-examined.
151 :			* More specifically, if no inlining occured during its fcontraction, then
152 :			* we assume that the code has just become smaller and should hence
153 :			* still be considered inlinable. On another hand, if inlining took place,
154 :			* then we have to reset the inline-bit because the new body might
155 :			* be completely different (i.e. much bigger) and inlining it might be
156 :			* undesirable.
157 :	monnier	159	* This means that in the case of
158 :			* let fwrap x = body1 and f y = body2 in exp
159 :	monnier	190	* if fwrap is fcontracted before f and something gets inlined into it,
160 :			* then fwrap cannot be inlined in f.
161 :	monnier	159	* To minimize the impact of this problem, we make sure that we fcontract
162 :			* inlinable functions only after fcontracting other mutually recursive
163 :	monnier	190	* functions. One way to solve the problem more thoroughly would be
164 :			* to keep the uncontracted fwrap around until f has been contracted.
165 :			* Such a trick hasn't seemed necessary yet.
166 :	monnier	121	* - at the very end of the optimization phase, cpsopt had a special pass
167 :			* that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
168 :			* into it doesn't have any undesirable side effects any more). The present
169 :			* code doesn't need such a thing. On another hand, the cpsopt approach
170 :			* had the advantage of keeping the `inline' bit from one contract phase to
171 :	monnier	159	* the next. If this ends up being important, one could add a global
172 :	monnier	121	* "noinline" flag that could be set to true whenever fcontracting an
173 :	monnier	159	* inlinable function (this would ensure that fcontracting such an inlinable
174 :			* function can only reduce its size, which would allow keeping the `inline'
175 :			* bit set after fcontracting).
176 :	monnier	121	*)
177 :
178 :			structure FContract :> FCONTRACT =
179 :			struct
180 :			local
181 :			structure F = FLINT
182 :	monnier	506	structure M = FLINTIntMap
183 :	monnier	504	structure S = IntRedBlackSet
184 :	monnier	121	structure C = Collect
185 :	monnier	184	structure O = Option
186 :	monnier	121	structure DI = DebIndex
187 :			structure PP = PPFlint
188 :	monnier	159	structure FU = FlintUtil
189 :			structure LT = LtyExtern
190 :	monnier	200	structure LK = LtyKernel
191 :	monnier	163	structure OU = OptUtils
192 :	monnier	202	structure PO = PrimOp
193 :	monnier	220	structure CTRL = FLINT_Control
194 :	monnier	121	in
195 :
196 :	monnier	259	fun say s = (Control_Print.say s; Control_Print.flush())
197 :	monnier	121	fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
198 :			fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
199 :			fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
200 :
201 :			(* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
202 :
203 :	monnier	159	val cplv = LambdaVar.dupLvar
204 :	monnier	200	val mklv = LambdaVar.mkLvar
205 :	monnier	121
206 :	monnier	259	type options = {etaSplit : bool, tfnInline : bool}
207 :
208 :	monnier	121	datatype sval
209 :			= Val of F.value (* F.value should never be F.VAR lv *)
210 :	monnier	202	| Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * sval list list ref
211 :	monnier	259	| TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * F.tfkind
212 :	monnier	189	| Record of F.lvar * sval list
213 :			| Con of F.lvar * sval * F.dcon * F.tyc list
214 :			| Decon of F.lvar * sval * F.dcon * F.tyc list
215 :			| Select of F.lvar * sval * int
216 :	monnier	121	| Var of F.lvar * F.lty option (* cop out case *)
217 :
218 :	monnier	159	fun sval2lty (Var(_,x)) = x
219 :			| sval2lty (Decon(_,_,(_,_,lty),tycs)) =
220 :			SOME(hd(#2 (LT.ltd_arrow (hd(LT.lt_inst(lty, tycs))))))
221 :	monnier	199	| sval2lty (Select(_,sv,i)) =
222 :			(case sval2lty sv of SOME lty => SOME(LT.lt_select(lty, i)) | _ => NONE)
223 :	monnier	159	| sval2lty _ = NONE
224 :	monnier	121
225 :	monnier	159	fun tycs_eq ([],[]) = true
226 :			| tycs_eq (tyc1::tycs1,tyc2::tycs2) =
227 :			LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
228 :			| tycs_eq _ = false
229 :	monnier	121
230 :	monnier	200	(* calls `code' to append a lexp to each leaf of `le'.
231 :			* Typically used to transform `let lvs = le in code' so that
232 :			* `code' is now copied at the end of each branch of `le'.
233 :			* `lvs' is a list of lvars that should be used if the result of `le'
234 :			* needs to be bound before calling `code'. *)
235 :			fun append lvs code le =
236 :			let fun l (F.RET vs) = code vs
237 :			| l (le as (F.APP _ | F.TAPP _ | F.RAISE _ | F.HANDLE _)) =
238 :			let val lvs = map (fn lv => let val nlv = cplv lv
239 :			in C.new NONE nlv; nlv end)
240 :			lvs
241 :			in F.LET(lvs, le, code(map F.VAR lvs))
242 :			end
243 :			| l (F.LET (lvs,body,le)) = F.LET(lvs,body, l le)
244 :			| l (F.FIX (fdecs,le)) = F.FIX(fdecs, l le)
245 :			| l (F.TFN (tfdec,le)) = F.TFN(tfdec, l le)
246 :			| l (F.SWITCH (v,ac,arms,def)) =
247 :			let fun larm (con,le) = (con, l le)
248 :			in F.SWITCH(v, ac, map larm arms, O.map l def)
249 :			end
250 :			| l (F.CON (dc,tycs,v,lv,le)) = F.CON(dc, tycs, v, lv, l le)
251 :			| l (F.RECORD (rk,vs,lv,le)) = F.RECORD(rk, vs, lv, l le)
252 :			| l (F.SELECT (v,i,lv,le)) = F.SELECT(v, i, lv, l le)
253 :			| l (F.BRANCH (po,vs,le1,le2)) = F.BRANCH(po, vs, l le1, l le2)
254 :			| l (F.PRIMOP (po,vs,lv,le)) = F.PRIMOP(po, vs, lv, l le)
255 :			in l le
256 :			end
257 :
258 :	monnier	201	(* `extract' extracts the code of a switch arm into a function
259 :			* and replaces it with a call to that function *)
260 :			fun extract (con,le) =
261 :			let val f = mklv()
262 :			val fk = {isrec=NONE,known=true,inline=F.IH_SAFE,
263 :			cconv=F.CC_FUN(LK.FF_FIXED)}
264 :			in case con of
265 :			F.DATAcon(dc as (_,_,lty),tycs,lv) =>
266 :			let val nlv = cplv lv
267 :			val _ = C.new (SOME[lv]) f
268 :			val _ = C.use NONE (C.new NONE nlv)
269 :			val (lty,_) = LT.ltd_parrow(hd(LT.lt_inst(lty, tycs)))
270 :			in ((F.DATAcon(dc, tycs, nlv),
271 :			F.APP(F.VAR f, [F.VAR nlv])),
272 :			(fk, f, [(lv, lty)], le))
273 :			end
274 :			| con =>
275 :			let val _ = C.new (SOME[]) f
276 :			in ((con, F.APP(F.VAR f, [])),
277 :			(fk, f, [], le))
278 :			end
279 :			end
280 :
281 :	monnier	422	fun inScope m lv = Option.isSome(M.find(m,lv))
282 :	monnier	202
283 :	monnier	213	fun click s c = (if !CTRL.misc = 1 then say s else ();
284 :			c := !c + 1 (* Stats.addCounter c 1 *) )
285 :	monnier	185
286 :	monnier	259	fun contract {etaSplit,tfnInline} (fdec as (_,f,_,_)) = let
287 :	monnier	185
288 :	monnier	213	val c_dummy = ref 0 (* Stats.newCounter[] *)
289 :			val c_miss = ref 0 (* Stats.newCounter[] *)
290 :	monnier	189
291 :	monnier	213	val counter = c_dummy
292 :	monnier	189
293 :			fun click_deadval () = (click "d" counter)
294 :			fun click_deadlexp () = (click "D" counter)
295 :			fun click_select () = (click "s" counter)
296 :			fun click_record () = (click "r" counter)
297 :			fun click_con () = (click "c" counter)
298 :			fun click_switch () = (click "s" counter)
299 :			fun click_eta () = (click "e" counter)
300 :			fun click_etasplit () = (click "E" counter)
301 :			fun click_branch () = (click "b" counter)
302 :			fun click_dropargs () = (click "a" counter)
303 :
304 :			fun click_lacktype () = (click "t" c_miss)
305 :
306 :			(* this counters is actually *used* by fcontract.
307 :			* It's not used just for statistics. *)
308 :	monnier	213	val c_inline = ref 0 (* Stats.newCounter[counter] *)
309 :	monnier	189	fun click_simpleinline () = (click "i" c_inline)
310 :			fun click_copyinline () = (click "I" c_inline)
311 :			fun click_unroll () = (click "u" c_inline)
312 :	monnier	213	fun inline_count () = (* Stats.getCounter *) !c_inline
313 :	monnier	189
314 :	monnier	186	fun used lv = (C.usenb(C.get lv) > 0)
315 :	monnier	199	(* handle x =>
316 :	monnier	186	(say("while in FContract.used "^(C.LVarString lv)^"\n");
317 :	monnier	199	raise x) *)
318 :	monnier	121
319 :			fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2
320 :			| eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2
321 :			| eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2
322 :			| eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2
323 :			| eqConV (F.REALcon r1, F.REAL r2) = r1 = r2
324 :			| eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2
325 :			| eqConV (con,v) = bugval("unexpected comparison with val", v)
326 :
327 :	monnier	422	exception Lookup
328 :			fun lookup m lv =
329 :			(case M.find(m,lv)
330 :			of NONE =>
331 :			(say "\nlooking up unbound ";
332 :			say (!PP.LVarString lv);
333 :			raise Lookup)
334 :			| SOME x => x
335 :			(*esac*))
336 :	monnier	121
337 :			fun sval2val sv =
338 :			case sv
339 :	monnier	159	of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} | Decon{1=lv,...}
340 :	monnier	121	| Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
341 :			| Val v => v
342 :
343 :	monnier	163	fun val2sval m (F.VAR ov) =
344 :	monnier	199	((lookup m ov) (* handle x =>
345 :			(say("val2sval "^(C.LVarString ov)^"\n"); raise x) *) )
346 :	monnier	121	| val2sval m v = Val v
347 :
348 :			fun bugsv (msg,sv) = bugval(msg, sval2val sv)
349 :
350 :			fun subst m ov = sval2val (lookup m ov)
351 :	monnier	199	fun substval m = sval2val o (val2sval m)
352 :			fun substvar m lv =
353 :			case substval m (F.VAR lv)
354 :	monnier	121	of F.VAR lv => lv
355 :			| v => bugval ("unexpected val", v)
356 :
357 :			(* called when a variable becomes dead.
358 :			* it simply adjusts the use-counts *)
359 :			fun undertake m lv =
360 :			let val undertake = undertake m
361 :			in case lookup m lv
362 :	monnier	186	of Var {1=nlv,...} => ()
363 :	monnier	121	| Val v => ()
364 :	monnier	202	| Fun (lv,le,args,_,_) =>
365 :	monnier	187	C.unuselexp undertake
366 :			(F.LET(map #1 args,
367 :			F.RET (map (fn _ => F.INT 0) args),
368 :			le))
369 :			| TFun{1=lv,2=le,...} =>
370 :			C.unuselexp undertake le
371 :	monnier	189	| (Select {2=sv,...} | Con {2=sv,...}) => unusesval m sv
372 :			| Record {2=svs,...} => app (unusesval m) svs
373 :	monnier	159	(* decon's are implicit so we can't get rid of them *)
374 :			| Decon _ => ()
375 :	monnier	121	end
376 :	monnier	422	handle
377 :			Lookup =>
378 :			(say("Unable to undertake "^(C.LVarString lv)^"\n"))
379 :			| x =>
380 :			(say("while undertaking "^(C.LVarString lv)^"\n");
381 :			raise x)
382 :	monnier	121
383 :	monnier	189	and unusesval m sv = unuseval m (sval2val sv)
384 :	monnier	187	and unuseval m (F.VAR lv) =
385 :			if (C.unuse false (C.get lv)) then undertake m lv else ()
386 :			| unuseval f _ = ()
387 :			fun unusecall m lv =
388 :			if (C.unuse true (C.get lv)) then undertake m lv else ()
389 :
390 :
391 :	monnier	423	fun addbind (m,lv,sv) = M.insert(m, lv, sv)
392 :	monnier	121
393 :	monnier	164	(* substitute a value sv for a variable lv and unuse value v. *)
394 :	monnier	121	fun substitute (m, lv1, sv, v) =
395 :			(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
396 :	monnier	187	unuseval m v;
397 :	monnier	199	addbind(m, lv1, sv)) (* handle x =>
398 :	monnier	186	(say ("while substituting "^
399 :	monnier	164	(C.LVarString lv1)^
400 :			" -> ");
401 :	monnier	121	PP.printSval (sval2val sv);
402 :	monnier	199	raise x) *)
403 :	monnier	121
404 :			(* common code for primops *)
405 :	monnier	199	fun cpo m (SOME{default,table},po,lty,tycs) =
406 :			(SOME{default=substvar m default,
407 :			table=map (fn (tycs,lv) => (tycs, substvar m lv)) table},
408 :	monnier	121	po,lty,tycs)
409 :	monnier	199	| cpo _ po = po
410 :	monnier	121
411 :	monnier	199	fun cdcon m (s,Access.EXN(Access.LVAR lv),lty) =
412 :			(s, Access.EXN(Access.LVAR(substvar m lv)), lty)
413 :			| cdcon _ dc = dc
414 :	monnier	121
415 :	monnier	201	(* ifs (inlined functions): records which functions we're currently inlining
416 :	monnier	199	* in order to detect loops
417 :			* m: is a map lvars to their defining expressions (svals) *)
418 :	monnier	201	fun fcexp ifs m le cont = let
419 :			val loop = fcexp ifs
420 :	monnier	199	val substval = substval m
421 :			val cdcon = cdcon m
422 :			val cpo = cpo m
423 :	monnier	163
424 :	monnier	201	fun fcLet (lvs,le,body) =
425 :			loop m le
426 :			(fn (nm,nle) =>
427 :			let fun cbody () =
428 :			let val nm = (foldl (fn (lv,m) =>
429 :			addbind(m, lv, Var(lv, NONE)))
430 :			nm lvs)
431 :			in case loop nm body cont
432 :			of F.RET vs => if vs = (map F.VAR lvs) then nle
433 :			else F.LET(lvs, nle, F.RET vs)
434 :			| nbody => F.LET(lvs, nle, nbody)
435 :			end
436 :			in case nle
437 :			of F.RET vs =>
438 :			let fun simplesubst (lv,v,m) =
439 :			let val sv = val2sval m v
440 :			in substitute(m, lv, sv, sval2val sv)
441 :			end
442 :			val nm = (ListPair.foldl simplesubst nm (lvs, vs))
443 :			in loop nm body cont
444 :			end
445 :			| F.TAPP _ =>
446 :			if List.all (C.dead o C.get) lvs
447 :			then loop nm body cont
448 :			else cbody()
449 :			| _ => cbody()
450 :			end)
451 :	monnier	200
452 :	monnier	201	fun fcFix (fs,le) =
453 :	monnier	202	let (* merge actual arguments to extract the constant subpart *)
454 :			fun merge_actuals ((lv,lty),[],m) = addbind(m, lv, Var(lv, SOME lty))
455 :			| merge_actuals ((lv,lty),a::bs,m) = addbind(m, lv, Var(lv, SOME lty))
456 :			(* FIXME: there's a bug here, but it's not caught by chkflint
457 :			let fun f (b::bs) =
458 :			if sval2val a = sval2val b then f bs
459 :			else addbind(m, lv, Var(lv, SOME lty))
460 :			| f [] =
461 :			(click "C" c_cstarg;
462 :			case sval2val a
463 :			of v as F.VAR lv' =>
464 :			(* FIXME: this inScope check is wrong for non-recursive
465 :			* functions. But it only matters if the function is
466 :			* passed itself as a parameter which cannot happen
467 :			* with the current type system I believe. *)
468 :			if inScope m lv' then
469 :			let val sv =
470 :			case a of Var (v,NONE) => Var(v, SOME lty)
471 :			| _ => a
472 :			in substitute(m, lv, sv, v)
473 :			end
474 :			else (click "O" c_outofscope;
475 :
476 :			addbind(m, lv, Var(lv, SOME lty)))
477 :			| v => substitute(m, lv, a, v))
478 :			in f bs
479 :			end *)
480 :			(* The actual function contraction *)
481 :	monnier	203	fun fcFun ((f,body,args,fk as {inline,cconv,known,isrec},actuals),
482 :			(m,fs)) =
483 :	monnier	201	let val fi = C.get f
484 :	monnier	203	in if C.dead fi then (m,fs)
485 :	monnier	201	else if C.iusenb fi = C.usenb fi then
486 :			(* we need to be careful that undertake not be called
487 :			* recursively *)
488 :	monnier	203	(C.use NONE fi; undertake m f; (m,fs))
489 :	monnier	201	else
490 :	monnier	220	let (* val _ = say ("\nEntering "^(C.LVarString f)^"\n") *)
491 :	monnier	201	val saved_ic = inline_count()
492 :			(* make up the bindings for args inside the body *)
493 :	monnier	202	val actuals = if isSome isrec orelse
494 :			C.escaping fi orelse
495 :			null(!actuals)
496 :			then map (fn _ => []) args
497 :			else OU.transpose(!actuals)
498 :			val nm = ListPair.foldl merge_actuals m (args, actuals)
499 :	monnier	506	(* contract the body and create the resulting fundec.
500 :			* Temporarily remove f's definition from the
501 :			* environment while we're rebuilding it to avoid
502 :			* nasty problems. *)
503 :			val nbody = fcexp (S.add(ifs, f))
504 :			(addbind(nm, f, Var(f, NONE)))
505 :			body #2
506 :	monnier	201	(* if inlining took place, the body might be completely
507 :			* changed (read: bigger), so we have to reset the
508 :			* `inline' bit *)
509 :			val nfk = {isrec=isrec, cconv=cconv,
510 :			known=known orelse not(C.escaping fi),
511 :			inline=if inline_count() = saved_ic
512 :			then inline
513 :			else F.IH_SAFE}
514 :			(* update the binding in the map. This step is
515 :			* not just a mere optimization but is necessary
516 :			* because if we don't do it and the function
517 :			* gets inlined afterwards, the counts will reflect the
518 :			* new contracted code while we'll be working on the
519 :			* the old uncontracted code *)
520 :	monnier	203	val nm = addbind(m, f, Fun(f, nbody, args, nfk, ref []))
521 :			in (nm, (nfk, f, args, nbody)::fs)
522 :	monnier	220	(* before say ("Exiting "^(C.LVarString f)^"\n") *)
523 :	monnier	201	end
524 :			end
525 :
526 :			(* check for eta redex *)
527 :	monnier	202	fun fcEta (fdec as (f,F.APP(F.VAR g,vs),args,_,_),(m,fs,hs)) =
528 :	monnier	201	if List.length args = List.length vs andalso
529 :			OU.ListPair_all (fn (v,(lv,t)) =>
530 :			case v of F.VAR v => v = lv andalso lv <> g
531 :			| _ => false)
532 :			(vs, args)
533 :			then
534 :			let val svg = lookup m g
535 :			val g = case sval2val svg
536 :			of F.VAR g => g
537 :			| v => bugval("not a variable", v)
538 :			(* NOTE: we don't want to turn a known function into an
539 :			* escaping one. It's dangerous for optimisations based
540 :			* on known functions (elimination of dead args, f.ex)
541 :	monnier	217	* and could generate cases where call>use in collect.
542 :			* Of course, if g is not a locally defined function (it's
543 :			* bound by a LET or as an argument), then knownness is
544 :			* irrelevant. *)
545 :	monnier	215	in if f = g orelse
546 :	monnier	217	((C.escaping(C.get f)) andalso
547 :			not(C.escaping(C.get g)) andalso
548 :			(case svg of Fun _ => true | _ => false))
549 :	monnier	201	(* the default case could ensure the inline *)
550 :			then (m, fdec::fs, hs)
551 :			else let
552 :			(* if an earlier function h has been eta-reduced
553 :			* to f, we have to be careful to update its
554 :			* binding to not refer to f any more since f
555 :			* will disappear *)
556 :			val nm = foldl (fn (h,m) =>
557 :			if sval2val(lookup m h) = F.VAR f
558 :			then addbind(m, h, svg) else m)
559 :			m hs
560 :			in
561 :			(* I could almost reuse `substitute' but the
562 :			* unuse in substitute assumes the val is escaping *)
563 :			click_eta();
564 :			C.transfer(f, g);
565 :			unusecall m g;
566 :			(addbind(m, f, svg), fs, f::hs)
567 :			end
568 :	monnier	189	end
569 :	monnier	201	else (m, fdec::fs, hs)
570 :			| fcEta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
571 :
572 :			(* add wrapper for various purposes *)
573 :	monnier	217	fun wrap (f as (fk as {isrec,inline,...},g,args,body):F.fundec,fs) =
574 :	monnier	201	let val gi = C.get g
575 :			fun dropargs filter =
576 :			let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
577 :			val args' = filter args
578 :			val ng = cplv g
579 :			val nargs = map (fn (v,t) => (cplv v, t)) args
580 :			val nargs' = map #1 (filter nargs)
581 :			val appargs = (map F.VAR nargs')
582 :			val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))
583 :			val nf' = (nfk', ng, args', body)
584 :
585 :			val ngi = C.new (SOME(map #1 args')) ng
586 :			in
587 :			C.ireset gi;
588 :			app (ignore o (C.new NONE) o #1) nargs;
589 :			C.use (SOME appargs) ngi;
590 :			app (C.use NONE o C.get) nargs';
591 :			nf'::nf::fs
592 :	monnier	121	end
593 :	monnier	201	in
594 :			(* Don't introduce wrappers for escaping-only functions.
595 :			* This is debatable since although wrappers are useless
596 :			* on escaping-only functions, some of the escaping uses
597 :			* might turn into calls in the course of fcontract, so
598 :			* by not introducing wrappers here, we avoid useless work
599 :			* but we also postpone useful work to later invocations. *)
600 :	monnier	217	if C.dead gi then fs
601 :			else if inline=F.IH_ALWAYS then f::fs else
602 :	monnier	201	let val used = map (used o #1) args
603 :			in if C.called gi then
604 :			(* if some args are not used, let's drop them *)
605 :			if not (List.all (fn x => x) used) then
606 :			(click_dropargs();
607 :	monnier	203	dropargs (fn xs => OU.filter used xs))
608 :	monnier	190
609 :	monnier	201	(* eta-split: add a wrapper for escaping uses *)
610 :	monnier	259	else if etaSplit andalso C.escaping gi then
611 :	monnier	201	(* like dropargs but keeping all args *)
612 :			(click_etasplit(); dropargs (fn x => x))
613 :
614 :			else f::fs
615 :			else f::fs
616 :			end
617 :			end
618 :
619 :			(* add various wrappers *)
620 :			val fs = foldl wrap [] fs
621 :
622 :			(* register the new bindings (uncontracted for now) *)
623 :	monnier	202	val (nm,fs) = foldl (fn (fdec as (fk,f,args,body),(m,fs)) =>
624 :			let val nf = (f, body, args, fk, ref [])
625 :			in (addbind(m, f, Fun nf), nf::fs) end)
626 :			(m,[]) fs
627 :	monnier	201	(* check for eta redexes *)
628 :			val (nm,fs,_) = foldl fcEta (nm,[],[]) fs
629 :
630 :	monnier	204	val (wrappers,funs) =
631 :	monnier	202	List.partition (fn (_,_,_,{inline=F.IH_ALWAYS,...},_) => true
632 :	monnier	201	| _ => false) fs
633 :	monnier	204	val (maybes,funs) =
634 :	monnier	203	List.partition (fn (_,_,_,{inline=F.IH_MAYBE _,...},_) => true
635 :			| _ => false) funs
636 :	monnier	213
637 :	monnier	204	(* First contract the big inlinable functions. This might make them
638 :			* non-inlinable and we'd rather know that before we inline them.
639 :			* Then we inline the body (so that we won't go through the inline-once
640 :			* functions twice), then the normal functions and finally the wrappers
641 :			* (which need to come last to make sure that they get inlined if
642 :			* at all possible) *)
643 :			val fs = []
644 :			val (nm,fs) = foldl fcFun (nm,fs) maybes
645 :	monnier	201	val nle = loop nm le cont
646 :	monnier	203	val (nm,fs) = foldl fcFun (nm,fs) funs
647 :			val (nm,fs) = foldl fcFun (nm,fs) wrappers
648 :	monnier	201	(* junk newly unused funs *)
649 :			val fs = List.filter (used o #2) fs
650 :			in
651 :			case fs
652 :			of [] => nle
653 :			| [f1 as ({isrec=NONE,...},_,_,_),f2] =>
654 :			(* gross hack: `wrap' might have added a second
655 :			* non-recursive function. we need to split them into
656 :	monnier	203	* 2 FIXes. This is _very_ ad-hoc. *)
657 :	monnier	204	F.FIX([f2], F.FIX([f1], nle))
658 :	monnier	201	| _ => F.FIX(fs, nle)
659 :			end
660 :	monnier	163
661 :	monnier	201	fun fcApp (f,vs) =
662 :	monnier	202	let val svs = map (val2sval m) vs
663 :	monnier	201	val svf = val2sval m f
664 :			(* F.APP inlining (if any) *)
665 :	monnier	202
666 :	monnier	201	in case svf
667 :	monnier	202	of Fun(g,body,args,{inline,...},actuals) =>
668 :			let val gi = C.get g
669 :			fun noinline () =
670 :			(actuals := svs :: (!actuals);
671 :	monnier	259	cont(m, F.APP(sval2val svf, map sval2val svs)))
672 :	monnier	202	fun simpleinline () =
673 :			(* simple inlining: we should copy the body and then
674 :			* kill the function, but instead we just move the body
675 :			* and kill only the function name.
676 :			* This inlining strategy looks inoffensive enough,
677 :			* but still requires some care: see comments at the
678 :			* begining of this file and in cfun *)
679 :	monnier	213	(click_simpleinline();
680 :	monnier	220	(* say("simpleinline "^(C.LVarString g)^"\n"); *)
681 :	monnier	202	ignore(C.unuse true gi);
682 :			loop m (F.LET(map #1 args, F.RET vs, body)) cont)
683 :			fun copyinline () =
684 :			(* aggressive inlining. We allow pretty much
685 :			* any inlinling, but we detect and reject inlining
686 :			* recursively which would else lead to infinite loop *)
687 :			(* unrolling is not as straightforward as it seems:
688 :			* if you inline the function you're currently
689 :			* fcontracting, you're asking for trouble: there is a
690 :			* hidden assumption in the counting that the old code
691 :			* will be replaced by the new code (and is hence dead).
692 :			* If the function to be unrolled has the only call to
693 :			* function f, then f might get simpleinlined before
694 :			* unrolling, which means that unrolling will introduce
695 :			* a second occurence of the `only call' but at that point
696 :			* f has already been killed. *)
697 :			let val nle = (F.LET(map #1 args, F.RET vs, body))
698 :			val nle = C.copylexp M.empty nle
699 :			in
700 :			click_copyinline();
701 :	monnier	220	(* say("copyinline "^(C.LVarString g)^"\n"); *)
702 :	monnier	202	(app (unuseval m) vs);
703 :			unusecall m g;
704 :	monnier	506	fcexp (S.add(ifs, g)) m nle cont
705 :	monnier	202	end
706 :
707 :	monnier	423	in if C.usenb gi = 1 andalso not(S.member(ifs, g)) then simpleinline()
708 :	monnier	202	else case inline of
709 :			F.IH_SAFE => noinline()
710 :			| F.IH_UNROLL => noinline()
711 :			| F.IH_ALWAYS =>
712 :	monnier	423	if S.member(ifs, g) then noinline() else copyinline()
713 :	monnier	202	| F.IH_MAYBE(min,ws) =>
714 :	monnier	423	if S.member(ifs, g) then noinline() else let
715 :	monnier	202	fun value w _ (Val _ | Con _ | Record _) = w
716 :			| value w v (Fun (f,_,args,_,_)) =
717 :			if C.usenb(C.get v) = 1 then w * 2 else w
718 :			| value w _ _ = 0
719 :			val s = (OU.foldl3 (fn (sv,w,(v,t),s) => value w v sv + s)
720 :			0 (svs,ws,args))
721 :			handle OU.Unbalanced => 0
722 :			in if s > min then copyinline() else noinline()
723 :			end
724 :			end
725 :	monnier	259	| sv => cont(m, F.APP(sval2val svf, map sval2val svs))
726 :	monnier	201	end
727 :	monnier	184
728 :	monnier	220	fun fcTfn ((tfk,f,args,body),le) =
729 :	monnier	201	let val fi = C.get f
730 :			in if C.dead fi then (click_deadlexp(); loop m le cont) else
731 :	monnier	259	let val saved_ic = inline_count()
732 :			val nbody = fcexp ifs m body #2
733 :			val ntfk =
734 :			if inline_count() = saved_ic then tfk else {inline=F.IH_SAFE}
735 :			val nm = addbind(m, f, TFun(f, nbody, args, tfk))
736 :	monnier	184	val nle = loop nm le cont
737 :	monnier	121	in
738 :	monnier	220	if C.dead fi then nle else F.TFN((tfk, f, args, nbody), nle)
739 :	monnier	121	end
740 :	monnier	201	end
741 :
742 :	monnier	259	fun fcTapp (f,tycs) =
743 :			let val svf = val2sval m f
744 :			(* F.TAPP inlining (if any) *)
745 :
746 :			fun noinline () = (cont(m, F.TAPP(sval2val svf, tycs)))
747 :
748 :			fun specialize (g,tfk,args,body,tycs) =
749 :			let val prog =
750 :			({cconv=F.CC_FCT,inline=F.IH_SAFE,isrec=NONE,known=false},
751 :			mklv(), [],
752 :			F.TFN((tfk, g, args, body), F.TAPP(F.VAR g, tycs)))
753 :			val F.LET(_,nprog,F.RET _) = #4(Specialize.specialize prog)
754 :			in PP.printLexp nprog; nprog end
755 :
756 :			in case (tfnInline,svf)
757 :			of (true,TFun(g,body,args,tfk as {inline,...})) =>
758 :			let val gi = C.get g
759 :			fun simpleinline () =
760 :			(* simple inlining: we should copy the body and then
761 :			* kill the function, but instead we just move the body
762 :			* and kill only the function name.
763 :			* This inlining strategy looks inoffensive enough,
764 :			* but still requires some care: see comments at the
765 :			* begining of this file and in cfun *)
766 :			(click_simpleinline();
767 :			(* say("simpleinline "^(C.LVarString g)^"\n"); *)
768 :			ignore(C.unuse true gi);
769 :			loop m (specialize(g, tfk, args, body, tycs)) cont)
770 :			fun copyinline () =
771 :			(* aggressive inlining. We allow pretty much
772 :			* any inlinling, but we detect and reject inlining
773 :			* recursively which would else lead to infinite loop *)
774 :			let val nle = (F.TFN((tfk, g, args, body),
775 :			F.TAPP(F.VAR g, tycs)))
776 :			val nle = C.copylexp M.empty nle
777 :			in
778 :			click_copyinline();
779 :			(* say("copyinline "^(C.LVarString g)^"\n"); *)
780 :			unusecall m g;
781 :	monnier	423	fcexp (S.add(ifs, g)) m nle cont
782 :	monnier	259	end
783 :
784 :	monnier	423	in if C.usenb gi = 1 andalso not(S.member(ifs, g))
785 :	monnier	259	then noinline() (* simpleinline() *)
786 :			else case inline of
787 :			F.IH_ALWAYS =>
788 :	monnier	423	if S.member(ifs, g) then noinline() else copyinline()
789 :	monnier	259	| _ => noinline()
790 :			end
791 :			| sv => noinline()
792 :			end
793 :
794 :
795 :
796 :	monnier	201	fun fcSwitch (v,ac,arms,def) =
797 :			let fun fcsCon (lvc,svc,dc1:F.dcon,tycs1) =
798 :			let fun killle le = C.unuselexp (undertake m) le
799 :			fun kill lv le =
800 :			C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le
801 :			fun killarm (F.DATAcon(_,_,lv),le) = kill lv le
802 :			| killarm _ = buglexp("bad arm in switch(con)", le)
803 :
804 :			fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) =
805 :			(* sometimes lty1 <> lty2 :-( so this doesn't work:
806 :			* FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) *)
807 :			if #2 dc1 = #2 (cdcon dc2) then
808 :			(map killarm tl; (* kill the rest *)
809 :			O.map killle def; (* and the default case *)
810 :			loop (substitute(m, lv, svc, F.VAR lvc))
811 :			le cont)
812 :			else
813 :			(* kill this arm and continue with the rest *)
814 :			(kill lv le; carm tl)
815 :			| carm [] = loop m (O.valOf def) cont
816 :			| carm _ = buglexp("unexpected arm in switch(con,...)", le)
817 :			in click_switch(); carm arms
818 :	monnier	186	end
819 :	monnier	121
820 :	monnier	201	fun fcsVal v =
821 :			let fun kill le = C.unuselexp (undertake m) le
822 :			fun carm ((con,le)::tl) =
823 :			if eqConV(con, v) then
824 :			(map (kill o #2) tl;
825 :			O.map kill def;
826 :			loop m le cont)
827 :			else (kill le; carm tl)
828 :			| carm [] = loop m (O.valOf def) cont
829 :			in click_switch(); carm arms
830 :			end
831 :
832 :			fun fcsDefault (sv,lvc) =
833 :			case (arms,def)
834 :			of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>
835 :			(* this is a mere DECON, so we can push the let binding
836 :			* (hidden in cont) inside and maybe even drop the DECON *)
837 :			let val ndc = cdcon dc
838 :			val slv = Decon(lv, sv, ndc, tycs)
839 :			val nm = addbind(m, lv, slv)
840 :			(* see below *)
841 :			(* val nm = addbind(nm, lvc, Con(lvc, slv, ndc, tycs)) *)
842 :			val nle = loop nm le cont
843 :			val nv = sval2val sv
844 :			in
845 :			if used lv then
846 :			F.SWITCH(nv,ac,[(F.DATAcon(ndc,tycs,lv),nle)],NONE)
847 :			else (unuseval m nv; nle)
848 :			end
849 :			| (([(_,le)],NONE) | ([],SOME le)) =>
850 :			(* This should never happen, but we can optimize it away *)
851 :			(unuseval m (sval2val sv); loop m le cont)
852 :			| _ =>
853 :			let fun carm (F.DATAcon(dc,tycs,lv),le) =
854 :			let val ndc = cdcon dc
855 :			val slv = Decon(lv, sv, ndc, tycs)
856 :			val nm = addbind(m, lv, slv)
857 :			(* we can rebind lv to a more precise value
858 :			* !!BEWARE!! This rebinding is misleading:
859 :			* - it gives the impression that `lvc' is built
860 :			* from`lv' although the reverse is true:
861 :			* if `lvc' is undertaken, `lv's count should
862 :			* *not* be updated!
863 :			* Luckily, `lvc' will not become dead while
864 :			* rebound to Con(lv) because it's used by the
865 :			* SWITCH. All in all, it works fine, but it's
866 :			* not as straightforward as it seems.
867 :			* - it seems to be a good idea, but it can hide
868 :			* other opt-opportunities since it hides the
869 :			* previous binding. *)
870 :			(* val nm = addbind(nm, lvc, Con(lvc,slv,ndc,tycs)) *)
871 :			in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
872 :			end
873 :			| carm (con,le) = (con, loop m le #2)
874 :			val narms = map carm arms
875 :			val ndef = Option.map (fn le => loop m le #2) def
876 :			in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
877 :			end
878 :	monnier	121
879 :	monnier	201	in case val2sval m v
880 :			of sv as Con x => fcsCon x
881 :			| sv as Val v => fcsVal v
882 :			| sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
883 :			| (* will probably never happen *) Record{1=lvc,...}) =>
884 :			fcsDefault(sv, lvc)
885 :			| sv as (Fun _ | TFun _) =>
886 :			bugval("unexpected switch arg", sval2val sv)
887 :			end
888 :	monnier	159
889 :	monnier	201	fun fcCon (dc1,tycs1,v,lv,le) =
890 :			let val lvi = C.get lv
891 :			in if C.dead lvi then (click_deadval(); loop m le cont) else
892 :			let val ndc = cdcon dc1
893 :			fun ccon sv =
894 :			let val nm = addbind(m, lv, Con(lv, sv, ndc, tycs1))
895 :			val nle = loop nm le cont
896 :			in if C.dead lvi then nle
897 :			else F.CON(ndc, tycs1, sval2val sv, lv, nle)
898 :			end
899 :			in case val2sval m v
900 :			of sv as (Decon (lvd,sv',dc2,tycs2)) =>
901 :			if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
902 :			(click_con();
903 :			loop (substitute(m, lv, sv', F.VAR lvd)) le cont)
904 :			else ccon sv
905 :			| sv => ccon sv
906 :	monnier	189	end
907 :	monnier	201	end
908 :	monnier	121
909 :	monnier	201	fun fcRecord (rk,vs,lv,le) =
910 :			(* g: check whether the record already exists *)
911 :			let val lvi = C.get lv
912 :			in if C.dead lvi then (click_deadval(); loop m le cont) else
913 :			let fun g (Select(_,sv,0)::ss) =
914 :			let fun g' (n,Select(_,sv',i)::ss) =
915 :			if n = i andalso (sval2val sv) = (sval2val sv')
916 :			then g'(n+1,ss) else NONE
917 :	monnier	204	| g' (n,[]) =
918 :	monnier	201	(case sval2lty sv
919 :			of SOME lty =>
920 :	monnier	204	let val ltd =
921 :			case (rk, LT.ltp_tyc lty)
922 :			of (F.RK_STRUCT,false) => LT.ltd_str
923 :			| (F.RK_TUPLE _,true) => LT.ltd_tuple
924 :			(* we might select out of a struct
925 :			* into a tuple or vice-versa *)
926 :			| _ => (fn _ => [])
927 :	monnier	201	in if length(ltd lty) = n
928 :			then SOME sv else NONE
929 :			end
930 :			| _ => (click_lacktype(); NONE)) (* sad *)
931 :			| g' _ = NONE
932 :			in g'(1,ss)
933 :			end
934 :			| g _ = NONE
935 :			val svs = map (val2sval m) vs
936 :			in case g svs
937 :			of SOME sv => (click_record();
938 :			loop (substitute(m, lv, sv, F.INT 0)) le cont
939 :			before app (unuseval m) vs)
940 :			| _ =>
941 :			let val nm = addbind(m, lv, Record(lv, svs))
942 :			val nle = loop nm le cont
943 :			in if C.dead lvi then nle
944 :			else F.RECORD(rk, map sval2val svs, lv, nle)
945 :			end
946 :	monnier	189	end
947 :	monnier	201	end
948 :	monnier	121
949 :	monnier	201	fun fcSelect (v,i,lv,le) =
950 :			let val lvi = C.get lv
951 :			in if C.dead lvi then (click_deadval(); loop m le cont) else
952 :			(case val2sval m v
953 :			of Record (lvr,svs) =>
954 :			let val sv = List.nth(svs, i)
955 :			in click_select();
956 :			loop (substitute(m, lv, sv, F.VAR lvr)) le cont
957 :			end
958 :			| sv =>
959 :			let val nm = addbind (m, lv, Select(lv, sv, i))
960 :			val nle = loop nm le cont
961 :			in if C.dead lvi then nle
962 :			else F.SELECT(sval2val sv, i, lv, nle)
963 :			end)
964 :			end
965 :	monnier	121
966 :	monnier	201	fun fcBranch (po,vs,le1,le2) =
967 :			let val nvs = map substval vs
968 :			val npo = cpo po
969 :			val nle1 = loop m le1 #2
970 :			val nle2 = loop m le2 #2
971 :			in cont(m, F.BRANCH(npo, nvs, nle1, nle2))
972 :			end
973 :	monnier	121
974 :	monnier	201	fun fcPrimop (po,vs,lv,le) =
975 :			let val lvi = C.get lv
976 :	monnier	204	val pure = not(PO.effect(#2 po))
977 :	monnier	201	in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else
978 :	monnier	199	let val nvs = map substval vs
979 :	monnier	121	val npo = cpo po
980 :	monnier	201	val nm = addbind(m, lv, Var(lv,NONE))
981 :			val nle = loop nm le cont
982 :			in
983 :			if pure andalso C.dead lvi then nle
984 :			else F.PRIMOP(npo, nvs, lv, nle)
985 :	monnier	121	end
986 :	monnier	201	end
987 :	monnier	121
988 :	monnier	201	in case le
989 :			of F.RET vs => cont(m, F.RET(map substval vs))
990 :			| F.LET x => fcLet x
991 :			| F.FIX x => fcFix x
992 :			| F.APP x => fcApp x
993 :			| F.TFN x => fcTfn x
994 :	monnier	259	(* | F.TAPP (f,tycs) => cont(m, F.TAPP(substval f, tycs)) *)
995 :			| F.TAPP x => fcTapp x
996 :	monnier	201	| F.SWITCH x => fcSwitch x
997 :			| F.CON x => fcCon x
998 :			| F.RECORD x => fcRecord x
999 :			| F.SELECT x => fcSelect x
1000 :			| F.RAISE (v,ltys) => cont(m, F.RAISE(substval v, ltys))
1001 :			| F.HANDLE (le,v) => cont(m, F.HANDLE(loop m le #2, substval v))
1002 :			| F.BRANCH x => fcBranch x
1003 :			| F.PRIMOP x => fcPrimop x
1004 :	monnier	121	end
1005 :
1006 :	monnier	185	in
1007 :			(* C.collect fdec; *)
1008 :	monnier	201	case fcexp S.empty
1009 :	monnier	185	M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
1010 :			of F.FIX([fdec], F.RET[F.VAR f]) => fdec
1011 :			| fdec => bug "invalid return fundec"
1012 :			end
1013 :	monnier	121
1014 :			end
1015 :			end
1016 :	monnier	422

---

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