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

Parent Directory | Revision Log

---

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

---

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