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

Parent Directory | Revision Log

---

Revision 190 - (view) (download)

1 :	monnier	121	(* copyright 1998 YALE FLINT PROJECT *)
2 :	monnier	159	(* monnier@cs.yale.edu *)
3 :	monnier	121
4 :			signature COLLECT =
5 :			sig
6 :	monnier	185	type info
7 :	monnier	121
8 :	monnier	159	(* Collect information about variables and function uses.
9 :			* The info is accumulated in the map `m' *)
10 :	monnier	164	val collect : FLINT.fundec -> FLINT.fundec
11 :	monnier	121
12 :	monnier	186	val get : FLINT.lvar -> info
13 :	monnier	185
14 :	monnier	121	(* query functions *)
15 :	monnier	186	val escaping : info -> bool (* non-call uses *)
16 :			val called : info -> bool (* known call uses *)
17 :	monnier	189	val dead : info -> bool (* usenb = 0 ? *)
18 :			val usenb : info -> int (* total nb of uses *)
19 :	monnier	190	val callnb : info -> int (* total nb of calls *)
20 :	monnier	121
21 :	monnier	189	(* self-referential (i.e. internal) uses *)
22 :			val iusenb : info -> int
23 :			val icallnb : info -> int
24 :			(* reset to safe values (0 and 0) *)
25 :			val ireset : info -> unit
26 :
27 :	monnier	121	(* inc the "true=call,false=use" count *)
28 :	monnier	186	val use : FLINT.value list option -> info -> unit
29 :	monnier	187	(* dec the "true=call,false=use" count and return true if zero *)
30 :			val unuse : bool -> info -> bool
31 :	monnier	121	(* transfer the counts of var1 to var2 *)
32 :			val transfer : FLINT.lvar * FLINT.lvar -> unit
33 :			(* add the counts of var1 to var2 *)
34 :	monnier	186	(* val addto : info * info -> unit *)
35 :	monnier	121	(* delete the last reference to a variable *)
36 :	monnier	187	(* val kill : FLINT.lvar -> unit *)
37 :	monnier	164	(* create a new var entry (SOME arg list if fun) initialized to zero *)
38 :	monnier	186	val new : FLINT.lvar list option -> FLINT.lvar -> info
39 :	monnier	121
40 :			(* when creating a new var. Used when alpha-renaming *)
41 :			(* val copy : FLINT.lvar * FLINT.lvar -> unit *)
42 :
43 :	monnier	159	(* fix up function to keep counts up-to-date when getting rid of code.
44 :	monnier	187	* the arg is called for *free* variables becoming dead. *)
45 :			val unuselexp : (FLINT.lvar -> unit) -> FLINT.lexp -> unit
46 :	monnier	121	(* function to collect info about a newly created lexp *)
47 :	monnier	186	val uselexp : FLINT.lexp -> unit
48 :			(* function to copy (and collect info) a lexp *)
49 :	monnier	164	val copylexp : FLINT.lvar IntmapF.intmap -> FLINT.lexp -> FLINT.lexp
50 :	monnier	121
51 :			(* mostly useful for PPFlint *)
52 :			val LVarString : FLINT.lvar -> string
53 :			end
54 :
55 :	monnier	164	(* Internal vs External references:
56 :			* I started with a version that kept track separately of internal and external
57 :			* uses. This has the advantage that if the extuses count goes to zero, we can
58 :			* consider the function as dead. Without this, recursive functions can never
59 :			* be recognized as dead during fcontract (they are still eliminated at the
60 :			* beginning, tho). This looks nice at first, but poses problems:
61 :			* - when you do simple inlining (just moving the body of the procedure), you
62 :			* may inadvertently turn ext-uses into int-uses. This only happens when
63 :	monnier	189	* inlining mutually recursive function, but this can be commen (think of
64 :			* when fcontract undoes a useless uncurrying of a recursive function). This
65 :	monnier	164	* can be readily overcome by not using the `move body' optimization in
66 :			* dangerous cases and do the full copy+kill instead.
67 :			* - you have to keep track of what is inside what. The way I did it was to
68 :			* have an 'inside' ref cell in each fun. That was a bad idea. The problem
69 :			* stems from the fact that when you detect that a function becomes dead,
70 :			* you have to somehow reset those `inside' ref cells to reflect the location
71 :			* of the function before you can uncount its references. In most cases, this
72 :			* is unnecessary, but it is necessary when undertaking a function mutually
73 :			* recursive with a function in which you currently are when you detect the
74 :			* function's death.
75 :	monnier	189	* rather than fix this last point, I decided to give up on keeping internal
76 :			* counts up-to-date. Instead, I just compute them once during collect and
77 :			* never touch them again: this means that they should not be relied on in
78 :			* general. More specifically, they become potentially invalid as soon as
79 :			* the body of the function is changed. This still allows their use in
80 :			* many cases.
81 :	monnier	164	*)
82 :
83 :	monnier	121	structure Collect :> COLLECT =
84 :			struct
85 :			local
86 :			structure F = FLINT
87 :			structure M = Intmap
88 :	monnier	186	structure FU = FlintUtil
89 :	monnier	121	structure LV = LambdaVar
90 :			structure PP = PPFlint
91 :			in
92 :
93 :			val say = Control.Print.say
94 :			fun bug msg = ErrorMsg.impossible ("Collect: "^msg)
95 :			fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
96 :			fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
97 :			fun ASSERT (true,_) = ()
98 :			| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
99 :
100 :	monnier	189	datatype info
101 :	monnier	187	(* we keep track of calls and escaping uses *)
102 :	monnier	190	= Info of {calls: int ref, uses: int ref, int: (int * int) ref}
103 :	monnier	121
104 :			exception NotFound
105 :
106 :	monnier	186	val m : info M.intmap = M.new(128, NotFound)
107 :	monnier	121
108 :	monnier	189	fun new args lv =
109 :	monnier	190	let val i = Info{uses=ref 0, calls=ref 0, int=ref(0,0)}
110 :	monnier	189	in M.add m (lv, i); i
111 :			end
112 :
113 :	monnier	121	(* map related helper functions *)
114 :			fun get lv = (M.map m lv)
115 :	monnier	186	handle x as NotFound =>
116 :			(say ("Collect: ERROR: get unknown var "^
117 :			(LV.lvarName lv)^
118 :			". Pretending dead...\n");
119 :			(* raise x; *)
120 :	monnier	189	new NONE lv)
121 :	monnier	121
122 :			fun LVarString lv =
123 :	monnier	189	let val Info{uses=ref uses,calls=ref calls,...} = get lv
124 :	monnier	187	in (LV.lvarName lv)^
125 :			"{"^(Int.toString uses)^
126 :			(if calls > 0 then ","^(Int.toString calls) else "")^"}"
127 :			end
128 :
129 :	monnier	121	(* adds the counts of lv1 to those of lv2 *)
130 :	monnier	189	fun addto (Info{uses=uses1,calls=calls1,...},Info{uses=uses2,calls=calls2,...}) =
131 :	monnier	187	(uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
132 :
133 :	monnier	121	fun transfer (lv1,lv2) =
134 :	monnier	187	let val i1 = get lv1
135 :			val i2 = get lv2
136 :			in addto(i1, i2);
137 :			(* note the transfer by redirecting the map *)
138 :			M.add m (lv1, i2)
139 :			end
140 :	monnier	121
141 :			fun inc ri = (ri := !ri + 1)
142 :			fun dec ri = (ri := !ri - 1)
143 :
144 :	monnier	164	(* - first list is list of formal args
145 :			* - second is list of `up to know known arg'
146 :			* - third is args of the current call. *)
147 :			fun mergearg (NONE,a) = NONE
148 :			| mergearg (SOME(fv,NONE),a) =
149 :			if a = F.VAR fv then SOME(fv,NONE) else SOME(fv,SOME a)
150 :			| mergearg (SOME(fv,SOME b),a) =
151 :			if a = b orelse a = F.VAR fv then SOME(fv,SOME b) else NONE
152 :
153 :	monnier	190	fun use call (Info{uses,calls,...}) =
154 :	monnier	187	(inc uses;
155 :			case call
156 :	monnier	190	of NONE => ()
157 :	monnier	187	| SOME vals =>
158 :	monnier	190	inc calls)
159 :	monnier	121
160 :	monnier	189	fun unuse call (Info{uses,calls,...}) =
161 :	monnier	187	(* notice the calls could be dec'd to negative values because a
162 :			* use might be turned from escaping to known between the census
163 :			* and the unuse. We can't easily detect such changes, but
164 :			* we can detect it happened when we try to go below zero. *)
165 :			(dec uses;
166 :	monnier	189	if (call (* andalso !calls > 0 *)) then dec calls
167 :	monnier	187	else ASSERT(!uses >= !calls, "unknown sanity");
168 :			if !uses < 0 then bug "decrementing too much" (* F.VAR lv) *)
169 :			else !uses = 0)
170 :	monnier	121
171 :	monnier	189	fun usenb (Info{uses=ref uses,...}) = uses
172 :	monnier	190	fun callnb (Info{calls=ref calls,...}) = calls
173 :	monnier	189	fun used (Info{uses,...}) = !uses > 0
174 :			fun dead (Info{uses,...}) = !uses = 0
175 :			fun escaping (Info{uses,calls,...}) = !uses > !calls
176 :			fun called (Info{calls,...}) = !calls > 0
177 :			fun iusenb (Info{int=ref(u,_),...}) = u
178 :			fun icallnb (Info{int=ref(_,c),...}) = c
179 :			fun ireset (Info{int,...}) = int := (0,0)
180 :	monnier	164
181 :	monnier	121	(* Ideally, we should check that usenb = 1, but we may have been a bit
182 :			* conservative when keeping the counts uptodate *)
183 :	monnier	187	fun kill lv = (ASSERT(usenb(get lv) >= 1, "usenb "^(LVarString lv)^" >= 1 ");
184 :	monnier	186	M.rmv m lv)
185 :	monnier	121
186 :	monnier	164	(* ********************************************************************** *)
187 :			(* ********************************************************************** *)
188 :	monnier	121
189 :	monnier	164	datatype usage
190 :			= All
191 :			| None
192 :			| Some of bool list
193 :	monnier	121
194 :	monnier	164	fun usage bs =
195 :			let fun ua [] = All
196 :			| ua (false::_) = Some bs
197 :			| ua (true::bs) = ua bs
198 :			fun un [] = None
199 :			| un (true::_) = Some bs
200 :			| un (false::bs) = un bs
201 :			in case bs
202 :			of true::bs => ua bs
203 :			| false::bs => un bs
204 :			| [] => None
205 :			end
206 :	monnier	121
207 :	monnier	164	fun impurePO po = true (* if a PrimOP is pure or not *)
208 :	monnier	121
209 :	monnier	186	val census = let
210 :			(* val use = if inc then use else unuse *)
211 :	monnier	187	fun call args lv = use args (get lv)
212 :			val use = fn F.VAR lv => use NONE (get lv) | _ => ()
213 :	monnier	186	fun newv lv = new NONE lv
214 :			fun newf args lv = new args lv
215 :			fun id x = x
216 :	monnier	121
217 :	monnier	186	fun impurePO po = true (* if a PrimOP is pure or not *)
218 :	monnier	121
219 :	monnier	186	(* here, the use resembles a call, but it's safer to consider it as a use *)
220 :			fun cpo (NONE:F.dict option,po,lty,tycs) = ()
221 :			| cpo (SOME{default,table},po,lty,tycs) =
222 :			(use (F.VAR default); app (use o F.VAR o #2) table)
223 :			fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)
224 :			| cdcon _ = ()
225 :	monnier	121
226 :	monnier	186	(* the actual function:
227 :			* `uvs' is an optional list of booleans representing which of
228 :			* the return values are actually used *)
229 :	monnier	189	fun cexp lexp =
230 :	monnier	186	(case lexp
231 :			of F.RET vs => app use vs
232 :	monnier	121
233 :	monnier	186	| F.LET (lvs,le1,le2) =>
234 :			let val lvsi = map newv lvs
235 :	monnier	189	in cexp le2; cexp le1
236 :	monnier	186	end
237 :	monnier	121
238 :	monnier	186	| F.FIX (fs,le) =>
239 :			let val fs = map (fn (_,f,args,body) =>
240 :			(newf (SOME(map #1 args)) f,args,body))
241 :			fs
242 :	monnier	189	fun cfun (Info{uses,calls, int, ...}, args,body) =
243 :			(* census of a fundec. We get the internal counts
244 :			* by examining the count difference between before
245 :			* and after census of the body. *)
246 :			let val (euses,ecalls) = (!uses,!calls)
247 :			in
248 :			app (fn (v,t) => ignore(newv v)) args;
249 :			cexp body;
250 :			int := (!uses - euses, !calls - ecalls)
251 :			end
252 :	monnier	186	fun cfix fs = (* census of a list of fundecs *)
253 :			let val (ufs,nfs) = List.partition (used o #1) fs
254 :			in if List.null ufs then ()
255 :			else (app cfun ufs; cfix nfs)
256 :			end
257 :	monnier	189	in cexp le; cfix fs
258 :	monnier	186	end
259 :
260 :			| F.APP (F.VAR f,vs) =>
261 :			(call (SOME vs) f; app use vs)
262 :	monnier	121
263 :	monnier	186	| F.TFN ((tf,args,body),le) =>
264 :			let val tfi = newf NONE tf
265 :	monnier	189	in cexp le; if used tfi then cexp body else ()
266 :	monnier	186	end
267 :	monnier	164
268 :	monnier	186	| F.TAPP (F.VAR tf,tycs) => call NONE tf
269 :	monnier	164
270 :	monnier	186	| F.SWITCH (v,cs,arms,def) =>
271 :	monnier	189	(use v; Option.map cexp def;
272 :			app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp le)
273 :			| (_,le) => cexp le)
274 :	monnier	186	arms)
275 :
276 :			| F.CON (dc,_,v,lv,le) =>
277 :			let val lvi = newv lv
278 :	monnier	189	in cdcon dc; cexp le; if used lvi then use v else ()
279 :	monnier	186	end
280 :	monnier	164
281 :	monnier	186	| F.RECORD (_,vs,lv,le) =>
282 :			let val lvi = newv lv
283 :	monnier	189	in cexp le; if used lvi then app use vs else ()
284 :	monnier	186	end
285 :	monnier	164
286 :	monnier	186	| F.SELECT (v,_,lv,le) =>
287 :			let val lvi = newv lv
288 :	monnier	189	in cexp le; if used lvi then use v else ()
289 :	monnier	186	end
290 :	monnier	164
291 :	monnier	186	| F.RAISE (v,_) => use v
292 :	monnier	189	| F.HANDLE (le,v) => (use v; cexp le)
293 :	monnier	186
294 :			| F.BRANCH (po,vs,le1,le2) =>
295 :	monnier	189	(app use vs; cpo po; cexp le1; cexp le2)
296 :	monnier	186
297 :			| F.PRIMOP (po,vs,lv,le) =>
298 :			let val lvi = newv lv
299 :	monnier	189	in cexp le;
300 :	monnier	186	if impurePO po orelse used lvi then (cpo po; app use vs) else ()
301 :			end
302 :
303 :			| le => buglexp("unexpected lexp", le)) handle x => raise x
304 :			in
305 :			cexp
306 :	monnier	121	end
307 :
308 :			(* The code is almost the same for uncounting, except that calling
309 :			* undertaker should not be done for non-free variables. For that we
310 :			* artificially increase the usage count of each variable when it's defined
311 :			* (accomplished via the "def" calls)
312 :			* so that its counter never reaches 0 while processing its scope.
313 :			* Once its scope has been processed, we can completely get rid of
314 :			* the variable and corresponding info (after verifying that the count
315 :			* is indeed exactly 1 (accomplished by the "kill" calls) *)
316 :	monnier	159	fun unuselexp undertaker = let
317 :	monnier	121	(* val use = if inc then use else unuse *)
318 :	monnier	187	fun uncall lv = if unuse true (get lv) then undertaker lv else ()
319 :			val unuse = fn F.VAR lv => if unuse false (get lv) then undertaker lv else ()
320 :			| _ => ()
321 :			fun def i = (use NONE i)
322 :	monnier	121	fun id x = x
323 :
324 :			fun cpo (NONE:F.dict option,po,lty,tycs) = ()
325 :			| cpo (SOME{default,table},po,lty,tycs) =
326 :			(unuse(F.VAR default); app (unuse o F.VAR o #2) table)
327 :			fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = unuse(F.VAR lv)
328 :			| cdcon _ = ()
329 :
330 :	monnier	187	fun cfun (args,body) = (* census of a fundec *)
331 :			(app (def o get) args; cexp body; app kill args) handle x => raise x
332 :	monnier	121
333 :			and cexp lexp =
334 :	monnier	186	(case lexp
335 :	monnier	121	of F.RET vs => app unuse vs
336 :
337 :			| F.LET (lvs,le1,le2) =>
338 :	monnier	187	(app (def o get) lvs; cexp le2; cexp le1; app kill lvs)
339 :	monnier	121
340 :			| F.FIX (fs,le) =>
341 :	monnier	187	let val fs = map (fn (_,f,args,body) => (get f, f, args, body)) fs
342 :			val usedfs = (List.filter (used o #1) fs)
343 :			in app (def o #1) fs;
344 :	monnier	121	cexp le;
345 :	monnier	187	app (fn (_,_,args,le) => cfun(map #1 args, le)) usedfs;
346 :	monnier	121	app (kill o #2) fs
347 :			end
348 :
349 :			| F.APP (F.VAR f,vs) =>
350 :			(uncall f; app unuse vs)
351 :
352 :			| F.TFN ((tf,args,body),le) =>
353 :	monnier	187	let val tfi = get tf
354 :			in if used tfi then cexp body else ();
355 :			def tfi; cexp le; kill tf
356 :			end
357 :	monnier	121
358 :			| F.TAPP (F.VAR tf,tycs) => uncall tf
359 :
360 :			| F.SWITCH (v,cs,arms,default) =>
361 :			(unuse v; Option.map cexp default;
362 :			(* here we don't absolutely have to keep track of vars bound within
363 :			* each arm since these vars can't be eliminated anyway *)
364 :			app (fn (F.DATAcon(dc,_,lv),le) =>
365 :	monnier	187	(cdcon dc; def(get lv); cexp le; kill lv)
366 :	monnier	121	| (_,le) => cexp le)
367 :			arms)
368 :
369 :			| F.CON (dc,_,v,lv,le) =>
370 :	monnier	187	let val lvi = get lv
371 :			in cdcon dc; if used lvi then unuse v else ();
372 :			def lvi; cexp le; kill lv
373 :			end
374 :	monnier	121
375 :			| F.RECORD (_,vs,lv,le) =>
376 :	monnier	187	let val lvi = get lv
377 :			in if used lvi then app unuse vs else ();
378 :			def lvi; cexp le; kill lv
379 :			end
380 :	monnier	121
381 :			| F.SELECT (v,_,lv,le) =>
382 :	monnier	187	let val lvi = get lv
383 :			in if used lvi then unuse v else ();
384 :			def lvi; cexp le; kill lv
385 :			end
386 :	monnier	121
387 :			| F.RAISE (v,_) => unuse v
388 :			| F.HANDLE (le,v) => (unuse v; cexp le)
389 :
390 :			| F.BRANCH (po,vs,le1,le2) =>
391 :			(app unuse vs; cpo po; cexp le1; cexp le2)
392 :
393 :			| F.PRIMOP (po,vs,lv,le) =>
394 :	monnier	187	let val lvi = get lv
395 :			in if impurePO po orelse used lvi
396 :			then (cpo po; app unuse vs)
397 :			else ();
398 :			def lvi; cexp le; kill lv
399 :			end
400 :	monnier	121
401 :	monnier	186	| le => buglexp("unexpected lexp", le)) handle x => raise x
402 :	monnier	121	in
403 :	monnier	187	cexp
404 :	monnier	121	end
405 :
406 :	monnier	189	val uselexp = census
407 :	monnier	164	fun copylexp alpha le =
408 :	monnier	186	let val nle = FU.copy alpha le
409 :			in uselexp nle; nle
410 :	monnier	164	end
411 :
412 :	monnier	121	fun collect (fdec as (_,f,_,_)) =
413 :	monnier	186	((* say "Entering Collect...\n"; *)
414 :			M.clear m; (* start from a fresh state *)
415 :			PP.LVarString := LVarString;
416 :			uselexp (F.FIX([fdec], F.RET[F.VAR f]));
417 :			(* say "...Collect Done.\n"; *)
418 :			fdec)
419 :	monnier	121
420 :			end
421 :			end

---

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