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

Parent Directory | Revision Log

---

Revision 186 - (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 :			val contract : FLINT.fundec -> FLINT.fundec
9 :
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 :			* - elimination of constant arguments
27 :	monnier	159	*)
28 :
29 :	monnier	121	(* things that lcontract.sml does that fcontract doesn't do (yet):
30 :	monnier	159	* - inline across DeBruijn depths (will be solved by named-tvar)
31 :	monnier	121	* - elimination of let [dead-vs] = pure in body
32 :			*)
33 :
34 :			(* things that cpsopt/eta.sml did that fcontract doesn't do:
35 :	monnier	159	* - let f vs = select(v,i,g,g vs)
36 :	monnier	121	*)
37 :
38 :			(* things that cpsopt/contract.sml did that fcontract doesn't do:
39 :	monnier	159	* - IF-idiom (I still don't know what it is)
40 :	monnier	121	* - unifying branches
41 :			* - Handler operations
42 :			* - primops expressions
43 :			* - branch expressions
44 :			*)
45 :
46 :			(* things that could also be added:
47 :	monnier	184	* - elimination of dead vars in let
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	121	* - once a function is fcontracted it is marked as non-inlinable since
149 :	monnier	159	* fcontraction might have changed its shape considerably (via inlining).
150 :			* This means that in the case of
151 :			* let fwrap x = body1 and f y = body2 in exp
152 :			* if fwrap is fcontracted before f, then fwrap cannot be inlined in f.
153 :			* To minimize the impact of this problem, we make sure that we fcontract
154 :			* inlinable functions only after fcontracting other mutually recursive
155 :			* functions.
156 :	monnier	121	* - at the very end of the optimization phase, cpsopt had a special pass
157 :			* that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
158 :			* into it doesn't have any undesirable side effects any more). The present
159 :			* code doesn't need such a thing. On another hand, the cpsopt approach
160 :			* had the advantage of keeping the `inline' bit from one contract phase to
161 :	monnier	159	* the next. If this ends up being important, one could add a global
162 :	monnier	121	* "noinline" flag that could be set to true whenever fcontracting an
163 :	monnier	159	* inlinable function (this would ensure that fcontracting such an inlinable
164 :			* function can only reduce its size, which would allow keeping the `inline'
165 :			* bit set after fcontracting).
166 :	monnier	121	*)
167 :
168 :			structure FContract :> FCONTRACT =
169 :			struct
170 :			local
171 :			structure F = FLINT
172 :			structure M = IntmapF
173 :	monnier	159	structure S = IntSetF
174 :	monnier	121	structure C = Collect
175 :	monnier	184	structure O = Option
176 :	monnier	121	structure DI = DebIndex
177 :			structure PP = PPFlint
178 :	monnier	159	structure FU = FlintUtil
179 :			structure LT = LtyExtern
180 :	monnier	163	structure OU = OptUtils
181 :	monnier	159	structure CTRL = Control.FLINT
182 :	monnier	121	in
183 :
184 :			val say = Control.Print.say
185 :			fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
186 :			fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
187 :			fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
188 :
189 :			(* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
190 :
191 :			fun ASSERT (true,_) = ()
192 :			| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
193 :
194 :	monnier	159	val cplv = LambdaVar.dupLvar
195 :	monnier	121
196 :			datatype sval
197 :			= Val of F.value (* F.value should never be F.VAR lv *)
198 :			| Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth
199 :			| TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
200 :			| Record of F.lvar * F.value list
201 :	monnier	159	| Con of F.lvar * F.value * F.dcon * F.tyc list
202 :			| Decon of F.lvar * F.value * F.dcon * F.tyc list
203 :	monnier	121	| Select of F.lvar * F.value * int
204 :			| Var of F.lvar * F.lty option (* cop out case *)
205 :
206 :	monnier	159	fun sval2lty (Var(_,x)) = x
207 :			| sval2lty (Decon(_,_,(_,_,lty),tycs)) =
208 :			SOME(hd(#2 (LT.ltd_arrow (hd(LT.lt_inst(lty, tycs))))))
209 :			| sval2lty _ = NONE
210 :	monnier	121
211 :	monnier	159	fun tycs_eq ([],[]) = true
212 :			| tycs_eq (tyc1::tycs1,tyc2::tycs2) =
213 :			LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
214 :			| tycs_eq _ = false
215 :	monnier	121
216 :	monnier	185	fun contract (fdec as (_,f,_,_)) = let
217 :
218 :			val inlineWitness = ref false
219 :
220 :	monnier	159	(* cfg: is used for deBruijn renumbering when inlining at different depths
221 :			* ifs (inlined functions): records which functions we're currently inlining
222 :			* in order to detect loops
223 :			* m: is a map lvars to their defining expressions (svals) *)
224 :	monnier	184	fun cexp (cfg as (d,od)) ifs m le cont = let
225 :	monnier	159
226 :			val loop = cexp cfg ifs
227 :
228 :	monnier	186	fun used lv = (C.usenb(C.get lv) > 0)
229 :			handle x =>
230 :			(say("while in FContract.used "^(C.LVarString lv)^"\n");
231 :			raise x)
232 :	monnier	121
233 :			fun impurePO po = true (* if a PrimOP is pure or not *)
234 :
235 :			fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2
236 :			| eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2
237 :			| eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2
238 :			| eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2
239 :			| eqConV (F.REALcon r1, F.REAL r2) = r1 = r2
240 :			| eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2
241 :			| eqConV (con,v) = bugval("unexpected comparison with val", v)
242 :
243 :			fun lookup m lv = (M.lookup m lv)
244 :			(* handle e as M.IntmapF =>
245 :			(say "\nlooking up unbound ";
246 :			say (!PP.LVarString lv);
247 :			raise e) *)
248 :
249 :			fun sval2val sv =
250 :			case sv
251 :	monnier	159	of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} | Decon{1=lv,...}
252 :	monnier	121	| Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
253 :			| Val v => v
254 :
255 :	monnier	163	fun val2sval m (F.VAR ov) =
256 :	monnier	186	((lookup m ov) handle x => ((* PP.printSval(F.VAR ov); *) raise x))
257 :	monnier	121	| val2sval m v = Val v
258 :
259 :			fun bugsv (msg,sv) = bugval(msg, sval2val sv)
260 :
261 :			fun subst m ov = sval2val (lookup m ov)
262 :			val substval = sval2val o (val2sval m)
263 :			fun substvar lv =
264 :			case substval(F.VAR lv)
265 :			of F.VAR lv => lv
266 :			| v => bugval ("unexpected val", v)
267 :
268 :	monnier	186	fun unuseval f (F.VAR lv) = ignore((C.unuse f false lv) handle x => raise x)
269 :	monnier	121	| unuseval f _ = ()
270 :
271 :			(* called when a variable becomes dead.
272 :			* it simply adjusts the use-counts *)
273 :			fun undertake m lv =
274 :			let val undertake = undertake m
275 :			in case lookup m lv
276 :	monnier	186	of Var {1=nlv,...} => ()
277 :	monnier	121	| Val v => ()
278 :			| Fun (lv,le,args,_,_) =>
279 :	monnier	159	(#2 (C.unuselexp undertake)) (lv, map #1 args, le)
280 :			| TFun{1=lv,2=le,...} => (#2 (C.unuselexp undertake)) (lv, [], le)
281 :	monnier	121	| (Select {2=v,...} | Con {2=v,...}) => unuseval undertake v
282 :			| Record {2=vs,...} => app (unuseval undertake) vs
283 :	monnier	159	(* decon's are implicit so we can't get rid of them *)
284 :			| Decon _ => ()
285 :	monnier	121	end
286 :			handle M.IntmapF =>
287 :	monnier	186	(say("Unable to undertake "^(C.LVarString lv)^"\n"))
288 :	monnier	121	| x =>
289 :	monnier	186	(say("while undertaking "^(C.LVarString lv)^"\n"); raise x)
290 :	monnier	121
291 :			fun addbind (m,lv,sv) = M.add(m, lv, sv)
292 :
293 :	monnier	164	(* substitute a value sv for a variable lv and unuse value v. *)
294 :	monnier	121	fun substitute (m, lv1, sv, v) =
295 :			(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
296 :			unuseval (undertake m) v;
297 :			addbind(m, lv1, sv)) handle x =>
298 :	monnier	186	(say ("while substituting "^
299 :	monnier	164	(C.LVarString lv1)^
300 :			" -> ");
301 :	monnier	121	PP.printSval (sval2val sv);
302 :			raise x)
303 :
304 :			(* common code for primops *)
305 :			fun cpo (SOME{default,table},po,lty,tycs) =
306 :			(SOME{default=substvar default,
307 :			table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
308 :			po,lty,tycs)
309 :			| cpo po = po
310 :
311 :			fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
312 :			(s, Access.EXN(Access.LVAR(substvar lv)), lty)
313 :			| cdcon dc = dc
314 :
315 :	monnier	184	fun zip ([],[]) = []
316 :			| zip (x::xs,y::ys) = (x,y)::(zip(xs,ys))
317 :			| zip _ = bug "bad zip"
318 :	monnier	163
319 :	monnier	159	(* F.APP inlining (if any)
320 :			* `ifs' is the set of function we are currently inlining
321 :			* `f' is the function, `vs' its arguments.
322 :			* return either (NONE, ifs) if inlining cannot be done or
323 :			* (SOME lexp, nifs) where `lexp' is the expansion of APP(f,vs) and
324 :			* `nifs' is the new set of functions we are currently inlining.
325 :			*)
326 :			fun inline ifs (f,vs) =
327 :	monnier	121	case ((val2sval m f) handle x => raise x)
328 :	monnier	184	of Fun(g,body,args,{inline,...},od) =>
329 :	monnier	164	(ASSERT(used g, "used "^(C.LVarString g));
330 :	monnier	184	if d <> od then (NONE, ifs)
331 :	monnier	186	else if ((C.usenb(C.get g))handle x => raise x) = 1 andalso not(S.member ifs g) then
332 :	monnier	121
333 :	monnier	184	(* simple inlining: we should copy the body and then
334 :			* kill the function, but instead we just move the body
335 :			* and kill only the function name. This inlining strategy
336 :			* looks inoffensive enough, but still requires some care:
337 :			* see comments at the begining of this file and in cfun *)
338 :	monnier	185	(inlineWitness := true;
339 :			C.unuse (fn _ => ()) true g;
340 :	monnier	184	ASSERT(not (used g), "killed");
341 :			(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
342 :	monnier	121
343 :			(* aggressive inlining (but hopefully safe). We allow
344 :			* inlining for mutually recursive functions (isrec)
345 :			* despite the potential risk. The reason is that it can
346 :			* happen that a wrapper (that should be inlined) has to be made
347 :			* mutually recursive with its main function. On another hand,
348 :			* self recursion (C.recursive) is too dangerous to be inlined
349 :	monnier	184	* except for loop unrolling *)
350 :			else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) orelse
351 :			(inline = F.IH_UNROLL andalso (S.member ifs g)) then
352 :	monnier	163	let val nle =
353 :	monnier	164	C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
354 :	monnier	184	in
355 :	monnier	185	inlineWitness := true;
356 :	monnier	184	(* say ("\nInlining "^(C.LVarString g)); *)
357 :	monnier	164	(app (unuseval (undertake m)) vs) handle x => raise x;
358 :			(C.unuse (undertake m) true g) handle x => raise x;
359 :	monnier	184	(SOME(nle, od),
360 :			(* gross hack: to prevent further unrolling,
361 :			* I pretend that the rest is not inside the body *)
362 :			if inline = F.IH_UNROLL then S.rmv(g, ifs) else S.add(g, ifs))
363 :	monnier	121	end
364 :	monnier	159	else (NONE, ifs))
365 :			| sv => (NONE, ifs)
366 :	monnier	121	in
367 :			case le
368 :	monnier	184	of F.RET vs => cont(m, F.RET(map substval vs) handle x => raise x)
369 :	monnier	121
370 :			| F.LET (lvs,le,body) =>
371 :	monnier	184	let fun clet () =
372 :			loop m le
373 :			(fn (m,F.RET vs) =>
374 :			let fun simplesubst ((lv,v),m) =
375 :			let val sv = (val2sval m v) handle x => raise x
376 :			in substitute(m, lv, sv, sval2val sv)
377 :			end
378 :			val nm = (foldl simplesubst m (zip(lvs, vs)))
379 :			in loop nm body cont
380 :			end
381 :			| (m,nle) =>
382 :			let val nm = (foldl (fn (lv,m) =>
383 :			addbind(m, lv, Var(lv, NONE)))
384 :			m lvs)
385 :			in case loop nm body cont
386 :			of F.RET vs => if vs = (map F.VAR lvs) then nle
387 :			else F.LET(lvs, nle, F.RET vs)
388 :			| nbody => F.LET(lvs, nle, nbody)
389 :			end)
390 :	monnier	121	in case le
391 :	monnier	184	of F.BRANCH (po,vs,le1,le2) =>
392 :			(* this is a hack originally meant to cleanup the BRANCH mess
393 :			* introduced in flintnm (where each branch returns just true or
394 :			* false which is generally only used as input to a SWITCH).
395 :			* The present code does slightly more than clean up this case *)
396 :	monnier	121	let fun known (F.RECORD(_,_,_,le)) = known le
397 :			| known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')
398 :			| known (F.RET[F.VAR v]) = false
399 :			| known (F.RET[_]) = true
400 :			| known _ = false
401 :	monnier	184	fun cassoc (lv,v,body,wrap) =
402 :	monnier	186	if lv = v andalso ((C.usenb(C.get lv)) handle x=> raise x) = 1 andalso
403 :	monnier	121	known le1 andalso known le2 then
404 :			(* here I should also check that le1 != le2 *)
405 :			let val nle1 = F.LET([lv], le1, body)
406 :	monnier	159	val nlv = cplv lv
407 :	monnier	164	val _ = C.new NONE nlv
408 :			val body2 = C.copylexp (M.add(M.empty, lv, nlv))
409 :			body
410 :	monnier	121	val nle2 = F.LET([nlv], le2, body2)
411 :	monnier	164	in
412 :	monnier	184	loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont
413 :	monnier	121	end
414 :			else
415 :			clet()
416 :			in case (lvs,body)
417 :			of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
418 :	monnier	184	cassoc(lv, v, le, OU.id)
419 :	monnier	121	| ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
420 :	monnier	184	cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))
421 :	monnier	121	| _ => clet()
422 :			end
423 :	monnier	184	| _ => clet()
424 :	monnier	121	end
425 :	monnier	184
426 :	monnier	121	| F.FIX (fs,le) =>
427 :	monnier	164	let (* register dump bindings *)
428 :			val m = foldl (fn (fdec as (_,f,_,_),m) =>
429 :			addbind(m, f, Var(f,NONE)))
430 :			m fs
431 :
432 :			(* The actual function contraction *)
433 :			fun cfun (m,[]:F.fundec list,acc) = acc
434 :	monnier	184	| cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
435 :	monnier	121	if used f then
436 :	monnier	164	let (* val _ = say ("\nEntering "^(C.LVarString f)) *)
437 :	monnier	185	val oldWitness =
438 :			(!inlineWitness before inlineWitness := false)
439 :	monnier	164	(* make up the bindings for args inside the body *)
440 :	monnier	121	fun addnobind ((lv,lty),m) =
441 :			addbind(m, lv, Var(lv, SOME lty))
442 :			val nm = foldl addnobind m args
443 :			(* contract the body and create the resulting fundec *)
444 :	monnier	184	val nbody = cexp cfg (S.add(f, ifs)) nm body #2
445 :	monnier	185	(* if inlining took place, the body might be completely
446 :			* changed (read: bigger), so we have to reset the
447 :			* `inline' bit *)
448 :	monnier	184	val nfk = {isrec=isrec, cconv=cconv,
449 :	monnier	186	known=known orelse not(C.escaping(C.get f))handle x => raise x,
450 :	monnier	185	inline=if !inlineWitness
451 :			then F.IH_SAFE
452 :			else (inline before
453 :			inlineWitness := oldWitness)}
454 :	monnier	121	(* update the binding in the map. This step is not
455 :			* not just a mere optimization but is necessary
456 :			* because if we don't do it and the function
457 :			* gets inlined afterwards, the counts will reflect the
458 :			* new contracted code while we'll be working on the
459 :			* the old uncontracted code *)
460 :			val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))
461 :			in cfun(nm, fs, (nfk, f, args, nbody)::acc)
462 :	monnier	164	(* before say ("\nExiting "^(C.LVarString f)) *)
463 :	monnier	121	end
464 :			else cfun(m, fs, acc)
465 :
466 :			(* check for eta redex *)
467 :	monnier	186	fun ceta (fdec as (fk,f,args,F.APP(g,vs)):F.fundec,(m,fs,hs)) =
468 :	monnier	121	if vs = (map (F.VAR o #1) args) andalso
469 :			(* don't forget to check that g is not one of the args
470 :			* and not f itself either *)
471 :			(List.find (fn v => v = g) (F.VAR f::vs)) = NONE
472 :			then
473 :			let val svg = val2sval m g
474 :			val g = case sval2val svg
475 :			of F.VAR g => g
476 :			| v => bugval("not a variable", v)
477 :			(* NOTE: we don't want to turn a known function into an
478 :			* escaping one. It's dangerous for optimisations based
479 :			* on known functions (elimination of dead args, f.ex)
480 :			* and could generate cases where call>use in collect *)
481 :	monnier	186	in if not (((C.escaping(C.get f))handle x => raise x) andalso not (C.escaping(C.get g))handle x => raise x)
482 :	monnier	121	then let
483 :			(* if an earlier function h has been eta-reduced
484 :			* to f, we have to be careful to update its
485 :			* binding to not refer to f any more since f
486 :			* will disappear *)
487 :			val nm = foldl (fn (h,m) =>
488 :			if sval2val(lookup m h) = F.VAR f
489 :			then addbind(m, h, svg) else m)
490 :			m hs
491 :	monnier	164	in
492 :			(* I could almost reuse `substitute' but the
493 :			* unuse in substitute assumes the val is escaping *)
494 :			C.transfer(f, g);
495 :			C.unuse (undertake m) true g;
496 :	monnier	186	(addbind(m, f, svg), fs, f::hs)
497 :	monnier	121	end
498 :	monnier	163	(* the default case could ensure the inline *)
499 :	monnier	186	else (m, fdec::fs, hs)
500 :	monnier	121	end
501 :	monnier	186	else (m, fdec::fs, hs)
502 :			| ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
503 :	monnier	121
504 :	monnier	164	(* drop constant arguments if possible *)
505 :	monnier	184	fun cstargs (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec) = f
506 :			| cstargs (f as (fk,g,args,body):F.fundec) =
507 :	monnier	186	let val actuals = (C.actuals (C.get g)) handle x => raise x
508 :			val cst =
509 :	monnier	184	ListPair.map
510 :			(fn (NONE,_) => false
511 :	monnier	186	| (SOME v,(a,_)) =>
512 :			((case substval v
513 :			of F.VAR lv =>
514 :			if used a andalso used lv then
515 :			(C.use NONE (C.get lv); true)
516 :			else false
517 :			| _ => false)
518 :			handle M.IntmapF => false))
519 :			(actuals, args)
520 :	monnier	184	(* if all args are used, there's nothing we can do *)
521 :			in if List.all not cst then f else
522 :			let fun newarg lv =
523 :			let val nlv = cplv lv in C.new NONE nlv; nlv end
524 :			fun filter xs = OU.filter(cst, xs)
525 :			(* construct the new arg list *)
526 :			val nargs = ListPair.map
527 :			(fn ((a,t),true) => (newarg a,t)
528 :			| ((a,t),false) => (a,t))
529 :			(args, cst)
530 :			(* construct the new body *)
531 :			val nbody =
532 :			F.LET(map #1 (filter args),
533 :	monnier	186	F.RET(map O.valOf (filter actuals)),
534 :	monnier	184	body)
535 :			in (fk, g, nargs, nbody)
536 :	monnier	164	end
537 :	monnier	184	end
538 :	monnier	164
539 :	monnier	184	(* add wrapper for various purposes *)
540 :			fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
541 :			| wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
542 :			let fun dropargs filter =
543 :			let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
544 :	monnier	164	val args' = filter args
545 :	monnier	163	val ng = cplv g
546 :			val nargs = map (fn (v,t) => (cplv v, t)) args
547 :	monnier	164	val nargs' = map #1 (filter nargs)
548 :			val appargs = (map F.VAR nargs')
549 :	monnier	184	val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))
550 :	monnier	164	val nf' = (nfk', ng, args', body)
551 :	monnier	186
552 :			val ngi = C.new (SOME(map #1 args')) ng
553 :			val nargsi = map ((C.new NONE) o #1) nargs
554 :	monnier	184	in
555 :	monnier	186	C.use (SOME appargs) ngi;
556 :			app (C.use NONE) nargsi;
557 :	monnier	184	nf'::nf::fs
558 :	monnier	163	end
559 :	monnier	184	val used = map (used o #1) args
560 :			in
561 :			(* if some args are not used, let's drop them *)
562 :			if not (List.all OU.id used) then
563 :			dropargs (fn xs => OU.filter(used, xs))
564 :	monnier	163
565 :	monnier	184	(* eta-split: add a wrapper for escaping uses *)
566 :	monnier	186	else
567 :			let val gi = C.get g
568 :			in if ((C.escaping gi)handle x => raise x) andalso ((C.called gi)handle x => raise x) then
569 :			(* like dropargs but keeping all args *)
570 :			dropargs OU.id
571 :	monnier	121
572 :	monnier	186	else f::fs
573 :			end
574 :	monnier	184	end
575 :	monnier	163
576 :	monnier	186	(* junk unused funs *)
577 :			val fs = List.filter (used o #2) fs
578 :
579 :	monnier	184	(* redirect cst args to their source value *)
580 :			val fs = map cstargs fs
581 :
582 :			(* add various wrappers *)
583 :			val fs = foldl wrap [] fs
584 :
585 :	monnier	121	(* register the new bindings (uncontracted for now) *)
586 :			val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
587 :			addbind(m, f, Fun(f, body, args, fk, od)))
588 :			m fs
589 :			(* check for eta redexes *)
590 :	monnier	186	val (nm,fs,_) = foldl ceta (nm,[],[]) fs
591 :	monnier	121
592 :			(* move the inlinable functions to the end of the list *)
593 :			val (f1s,f2s) =
594 :	monnier	184	List.partition (fn ({inline=F.IH_ALWAYS,...},_,_,_) => true
595 :	monnier	121	| _ => false) fs
596 :			val fs = f2s @ f1s
597 :
598 :			(* contract the main body *)
599 :	monnier	184	val nle = loop nm le cont
600 :	monnier	121	(* contract the functions *)
601 :			val fs = cfun(nm, fs, [])
602 :			(* junk newly unused funs *)
603 :			val fs = List.filter (used o #2) fs
604 :			in
605 :	monnier	163	case fs
606 :			of [] => nle
607 :	monnier	184	| [f1 as ({isrec=NONE,...},_,_,_),f2] =>
608 :	monnier	186	(* gross hack: `wrap' might have added a second
609 :	monnier	163	* non-recursive function. we need to split them into
610 :	monnier	184	* 2 FIXes. This is _very_ ad-hoc *)
611 :	monnier	163	F.FIX([f2], F.FIX([f1], nle))
612 :			| _ => F.FIX(fs, nle)
613 :	monnier	121	end
614 :
615 :			| F.APP (f,vs) =>
616 :			let val nvs = ((map substval vs) handle x => raise x)
617 :	monnier	159	in case inline ifs (f, nvs)
618 :	monnier	184	of (SOME(le,od),nifs) => cexp (d,od) ifs m le cont
619 :			| (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))
620 :	monnier	121	end
621 :
622 :			| F.TFN ((f,args,body),le) =>
623 :	monnier	186	if used f then
624 :			let val nbody = cexp (DI.next d, DI.next od) ifs m body #2
625 :			val nm = addbind(m, f, TFun(f, nbody, args, od))
626 :			val nle = loop nm le cont
627 :			in
628 :			if used f then F.TFN((f, args, nbody), nle) else nle
629 :			end
630 :			else loop m le cont
631 :	monnier	121
632 :	monnier	184	| F.TAPP(f,tycs) =>
633 :			cont(m, F.TAPP((substval f) handle x => raise x, tycs))
634 :	monnier	121
635 :			| F.SWITCH (v,ac,arms,def) =>
636 :			(case ((val2sval m v) handle x => raise x)
637 :	monnier	185	of sv as Con (lvc,v,dc1,tycs1) =>
638 :	monnier	164	let fun killle le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
639 :	monnier	159	fun kill lv le =
640 :	monnier	164	((#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le) handle x => raise x
641 :	monnier	159	fun killarm (F.DATAcon(_,_,lv),le) = kill lv le
642 :			| killarm _ = buglexp("bad arm in switch(con)", le)
643 :
644 :			fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) =
645 :	monnier	185	(* sometimes lty1 <> lty2 :-( so this doesn't work:
646 :			* FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) *)
647 :			if #2 dc1 = #2 (cdcon dc2) then
648 :	monnier	159	(map killarm tl; (* kill the rest *)
649 :	monnier	185	O.map killle def; (* and the default case *)
650 :	monnier	184	loop (substitute(m, lv, val2sval m v, F.VAR lvc))
651 :			le cont)
652 :	monnier	159	else
653 :			(* kill this arm and continue with the rest *)
654 :			(kill lv le; carm tl)
655 :	monnier	185	| carm [] = loop m (O.valOf def) cont
656 :	monnier	121	| carm _ = buglexp("unexpected arm in switch(con,...)", le)
657 :			in carm arms
658 :			end
659 :
660 :	monnier	185	| sv as Val v =>
661 :	monnier	164	let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
662 :	monnier	159	fun carm ((con,le)::tl) =
663 :			if eqConV(con, v) then
664 :	monnier	184	(map (kill o #2) tl;
665 :	monnier	185	O.map kill def;
666 :	monnier	184	loop m le cont)
667 :	monnier	159	else (kill le; carm tl)
668 :	monnier	185	| carm [] = loop m (O.valOf def) cont
669 :	monnier	121	in carm arms
670 :			end
671 :	monnier	185
672 :			| sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
673 :			| (* will probably never happen *) Record{1=lvc,...}) =>
674 :			(case (arms,def)
675 :			of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>
676 :			(* this is a mere DECON, so we can push the let binding
677 :			* (hidden in cont) inside and maybe even drop the DECON *)
678 :			let val ndc = cdcon dc
679 :			val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs))
680 :			(* see below *)
681 :			val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))
682 :			val nle = loop nm le cont
683 :			val nv = sval2val sv
684 :			in
685 :			if used lv then
686 :			F.SWITCH(nv,ac,[(F.DATAcon(ndc,tycs,lv),nle)],NONE)
687 :			else (unuseval (undertake m) nv; nle)
688 :			end
689 :			| (([(_,le)],NONE) | ([],SOME le)) =>
690 :			(* This should never happen, but we can optimize it away *)
691 :			(unuseval (undertake m) (sval2val sv); loop m le cont)
692 :			| _ =>
693 :			let fun carm (F.DATAcon(dc,tycs,lv),le) =
694 :			let val ndc = cdcon dc
695 :			val nm = addbind(m, lv,
696 :			Decon(lv, F.VAR lvc, ndc, tycs))
697 :			(* we can rebind lv to a more precise value
698 :			* !!BEWARE!! This rebinding is misleading:
699 :			* - it gives the impression that `lvc' is built
700 :			* from`lv' although the reverse is true:
701 :			* if `lvc' is undertaken, `lv's count should
702 :			* *not* be updated!
703 :			* Luckily, `lvc' will not become dead while
704 :			* rebound to Con(lv) because it's used by the
705 :			* SWITCH. All in all, it works fine, but it's
706 :			* not as straightforward as it seems.
707 :			* - it seems to be a good idea, but it can hide
708 :			* other opt-opportunities since it hides the
709 :			* previous binding. *)
710 :			val nm = addbind(nm, lvc,
711 :			Con(lvc, F.VAR lv, ndc, tycs))
712 :			in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
713 :			end
714 :			| carm (con,le) = (con, loop m le #2)
715 :			val narms = map carm arms
716 :			val ndef = Option.map (fn le => loop m le #2) def
717 :			in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
718 :			end)
719 :
720 :	monnier	121	| sv as (Fun _ | TFun _) =>
721 :			bugval("unexpected switch arg", sval2val sv))
722 :
723 :	monnier	159	| F.CON (dc1,tycs1,v,lv,le) =>
724 :	monnier	186	if used lv then
725 :			let val ndc = cdcon dc1
726 :			fun ccon sv =
727 :			let val nv = sval2val sv
728 :			val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))
729 :			val nle = loop nm le cont
730 :			in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle
731 :			end
732 :			in case ((val2sval m v) handle x => raise x)
733 :			of sv as (Decon (lvd,vc,dc2,tycs2)) =>
734 :			if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
735 :			let val sv = (val2sval m vc) handle x => raise x
736 :			in loop (substitute(m, lv, sv, F.VAR lvd)) le cont
737 :			end
738 :			else ccon sv
739 :			| sv => ccon sv
740 :			end
741 :			else loop m le cont
742 :	monnier	121
743 :			| F.RECORD (rk,vs,lv,le) =>
744 :	monnier	164	(* g: check whether the record already exists *)
745 :	monnier	186	if used lv then
746 :			let fun g (n,Select(_,v1,i)::ss) =
747 :			if n = i then
748 :			(case ss
749 :			of Select(_,v2,_)::_ =>
750 :			if v1 = v2 then g(n+1, ss) else NONE
751 :			| [] =>
752 :			(case sval2lty (val2sval m v1)
753 :			of SOME lty =>
754 :			let val ltd = case rk
755 :			of F.RK_STRUCT => LT.ltd_str
756 :			| F.RK_TUPLE _ => LT.ltd_tuple
757 :			| _ => buglexp("bogus rk",le)
758 :			in if length(ltd lty) = n+1
759 :			then SOME v1 else NONE
760 :			end
761 :			| _ => NONE) (* sad case *)
762 :			| _ => NONE)
763 :			else NONE
764 :			| g _ = NONE
765 :			val svs = ((map (val2sval m) vs) handle x => raise x)
766 :			in case g (0,svs)
767 :			of SOME v =>
768 :			let val sv = (val2sval m v) handle x => raise x
769 :			in loop (substitute(m, lv, sv, F.INT 0)) le cont
770 :			before app (unuseval (undertake m)) vs
771 :			end
772 :			| _ =>
773 :			let val nvs = map sval2val svs
774 :			val nm = addbind(m, lv, Record(lv, nvs))
775 :			val nle = loop nm le cont
776 :			in if used lv then F.RECORD(rk, nvs, lv, nle) else nle
777 :			end
778 :			end
779 :			else loop m le cont
780 :	monnier	121
781 :			| F.SELECT (v,i,lv,le) =>
782 :	monnier	186	if used lv then
783 :			(case ((val2sval m v) handle x => raise x)
784 :			of Record (lvr,vs) =>
785 :			let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x
786 :			in loop (substitute(m, lv, sv, F.VAR lvr)) le cont
787 :			end
788 :			| sv =>
789 :			let val nv = sval2val sv
790 :			val nm = addbind (m, lv, Select(lv, nv, i))
791 :			val nle = loop nm le cont
792 :			in if used lv then F.SELECT(nv, i, lv, nle) else nle
793 :			end)
794 :			else loop m le cont
795 :	monnier	121
796 :	monnier	184	| F.RAISE (v,ltys) =>
797 :			cont(m, F.RAISE((substval v) handle x => raise x, ltys))
798 :	monnier	121
799 :	monnier	184	| F.HANDLE (le,v) =>
800 :			cont(m, F.HANDLE(loop m le #2, (substval v) handle x => raise x))
801 :	monnier	121
802 :			| F.BRANCH (po,vs,le1,le2) =>
803 :			let val nvs = ((map substval vs) handle x => raise x)
804 :			val npo = cpo po
805 :	monnier	184	val nle1 = loop m le1 #2
806 :			val nle2 = loop m le2 #2
807 :			in cont(m, F.BRANCH(npo, nvs, nle1, nle2))
808 :	monnier	121	end
809 :
810 :			| F.PRIMOP (po,vs,lv,le) =>
811 :			let val impure = impurePO po
812 :	monnier	186	in if impure orelse used lv then
813 :			let val nvs = ((map substval vs) handle x => raise x)
814 :			val npo = cpo po
815 :			val nm = addbind(m, lv, Var(lv,NONE))
816 :			val nle = loop nm le cont
817 :			in
818 :			if impure orelse used lv
819 :			then F.PRIMOP(npo, nvs, lv, nle)
820 :			else nle
821 :			end
822 :			else loop m le cont
823 :	monnier	121	end
824 :			end
825 :
826 :	monnier	185	in
827 :			(* C.collect fdec; *)
828 :			case cexp (DI.top,DI.top) S.empty
829 :			M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
830 :			of F.FIX([fdec], F.RET[F.VAR f]) => fdec
831 :			| fdec => bug "invalid return fundec"
832 :			end
833 :	monnier	121
834 :			end
835 :			end

---

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