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

Parent Directory | Revision Log

---

Revision 121 - (view) (download)

1 :	monnier	121	(* copyright 1998 YALE FLINT PROJECT *)
2 :
3 :			signature COLLECT =
4 :			sig
5 :
6 :			(* Collect information about variables and function uses
7 :			* the info is accumulated in the map `m' *)
8 :			val collect : FLINT.fundec -> unit
9 :
10 :			(* query functions *)
11 :			val recursive : FLINT.lvar -> bool
12 :			val escaping : FLINT.lvar -> bool (* non-call uses *)
13 :			val usenb : FLINT.lvar -> int (* nb of non-recursive uses *)
14 :			(* val callnb : FLINT.lvar -> int *)
15 :
16 :			(* inc the "true=call,false=use" count *)
17 :			val use : bool -> FLINT.lvar -> unit
18 :			(* dec the "true=call,false=use" count and call the function if zero *)
19 :			val unuse : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> unit
20 :			(* transfer the counts of var1 to var2 *)
21 :			val transfer : FLINT.lvar * FLINT.lvar -> unit
22 :			(* add the counts of var1 to var2 *)
23 :			val addto : FLINT.lvar * FLINT.lvar -> unit
24 :			(* delete the last reference to a variable *)
25 :			val kill : FLINT.lvar -> unit
26 :			(* create a new var entry (true=fun, false=other) initialized to zero *)
27 :			val new : bool -> FLINT.lvar -> unit
28 :
29 :			(* when creating a new var. Used when alpha-renaming *)
30 :			(* val copy : FLINT.lvar * FLINT.lvar -> unit *)
31 :
32 :			(* fix up function to keep counts up-to-date when getting rid of a function.
33 :			* the fun arg is only called for free variables becoming dead. *)
34 :			val unusefdec : (FLINT.lvar -> unit) -> (FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit
35 :			(* function to collect info about a newly created lexp *)
36 :			val uselexp : FLINT.lexp -> unit
37 :
38 :			(* This allows to execute some code and have all the resulting
39 :			* changes made to the internal (for recursion) counters instead
40 :			* of the external ones. For instance:
41 :			* inside f (fn () => call ~1 f)
42 :			* would decrement the count of recursive function calls of f *)
43 :			val inside : FLINT.lvar -> (unit -> 'a) -> 'a
44 :
45 :			(* mostly useful for PPFlint *)
46 :			val LVarString : FLINT.lvar -> string
47 :			end
48 :
49 :			structure Collect :> COLLECT =
50 :			struct
51 :			local
52 :			structure F = FLINT
53 :			structure M = Intmap
54 :			structure LV = LambdaVar
55 :			structure PP = PPFlint
56 :			in
57 :
58 :			val say = Control.Print.say
59 :			fun bug msg = ErrorMsg.impossible ("Collect: "^msg)
60 :			fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
61 :			fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
62 :			fun ASSERT (true,_) = ()
63 :			| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
64 :
65 :
66 :			datatype info
67 :			(* for functions we keep track of calls and escaping uses
68 :			* and separately for external and internal (recursive) references *)
69 :			= Fun of {ecalls: int ref, euses: int ref,
70 :			inside: bool ref,
71 :			icalls: int ref, iuses: int ref}
72 :			| Var of int ref (* for other vars, a simple use count is kept *)
73 :			| Transfer of FLINT.lvar (* for vars who have been transfered *)
74 :
75 :			exception NotFound
76 :
77 :			val m : info M.intmap = M.new(128, NotFound)
78 :
79 :			(* map related helper functions *)
80 :			fun get lv = (M.map m lv)
81 :			(* handle x as NotFound =>
82 :			(say "\nCollect:get unknown var ";
83 :			PP.printSval (F.VAR lv);
84 :			say ". Assuming dead...";
85 :			raise x;
86 :			Var (ref 0)) *)
87 :
88 :			fun new true lv = M.add m (lv, Fun{ecalls=ref 0, euses=ref 0,
89 :			inside=ref false,
90 :			icalls=ref 0, iuses=ref 0})
91 :			| new false lv = M.add m (lv, Var(ref 0))
92 :
93 :			fun LVarString lv =
94 :			(LV.lvarName lv)^
95 :			((case get lv of
96 :			Var uses => "{"^(Int.toString (!uses))^"}"
97 :			| Fun {ecalls,euses,icalls,iuses,...} =>
98 :			concat
99 :			["{(", Int.toString (!ecalls), ",", Int.toString (!euses),
100 :			"),(", Int.toString (!icalls), ",", Int.toString (!iuses), ")}"]
101 :			| Transfer _ => "{-}")
102 :			handle NotFound => "{?}")
103 :
104 :			(* adds the counts of lv1 to those of lv2 *)
105 :			fun addto (lv1,lv2) =
106 :			let val info2 = get lv2
107 :			val info1 = get lv1
108 :			in case info1
109 :			of Var uses1 =>
110 :			(case info2
111 :			of Var uses2 => uses2 := !uses2 + !uses1
112 :			| Fun {euses=eu2,inside=i2,iuses=iu2,...} =>
113 :			if !i2 then iu2 := !iu2 + !uses1
114 :			else eu2 := !eu2 + !uses1
115 :			| Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
116 :			| Fun {inside=i1,euses=eu1,iuses=iu1,ecalls=ec1,icalls=ic1,...} =>
117 :			(ASSERT(!iu1 + !ic1 = 0 andalso not(!i1), "improper fun transfer");
118 :			case info2
119 :			of Fun {inside=i2,euses=eu2,iuses=iu2,ecalls=ec2,icalls=ic2,...} =>
120 :			if !i2 then (iu2 := !iu2 + !eu1; ic2 := !ic2 + !ec1)
121 :			else (eu2 := !eu2 + !eu1; ec2 := !ec2 + !ec1)
122 :			| Var uses => uses := !uses + !eu1
123 :			| Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
124 :			| Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)
125 :			end
126 :			fun transfer (lv1,lv2) =
127 :			(addto(lv1, lv2);
128 :			M.add m (lv1, Transfer lv2)) (* note the transfer *)
129 :
130 :			fun inc ri = (ri := !ri + 1)
131 :			fun dec ri = (ri := !ri - 1)
132 :
133 :			fun use call lv =
134 :			case get lv
135 :			of Var uses => inc uses
136 :			| (Fun {inside=ref true, iuses=uses,icalls=calls,...} |
137 :			Fun {inside=ref false,euses=uses,ecalls=calls,...} ) =>
138 :			(if call then inc calls else (); inc uses)
139 :			| Transfer lv => use call lv
140 :
141 :			fun unuse undertaker call lv =
142 :			let fun check uses =
143 :			if !uses < 0 then
144 :			bugval("decrementing too much", F.VAR lv)
145 :			else if !uses = 0 then
146 :			undertaker lv
147 :			else ()
148 :			in case get lv
149 :			of Var uses => (dec uses; check uses)
150 :			| Fun {inside=ref false,euses=uses,ecalls=calls,...} =>
151 :			(dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)
152 :			| Fun {inside=ref true, iuses=uses,icalls=calls,...} =>
153 :			(dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown rec-sanity"))
154 :			| Transfer lv => unuse undertaker call lv
155 :			end
156 :
157 :			fun usenb lv = case get lv of (Fun{euses=uses,...} | Var uses) => !uses
158 :			| Transfer _ => 0
159 :			fun used lv = usenb lv > 0
160 :			fun recursive lv = case get lv of (Fun{iuses=uses,...} | Var uses) => !uses > 0
161 :			| Transfer lv => (say "\nCollect:recursive on transfer"; recursive lv)
162 :			(* fun callnb lv = case get lv of Fun{ecalls,...} => !ecalls | Var us => !us *)
163 :			fun escaping lv =
164 :			case get lv
165 :			of Fun{iuses,euses,icalls,ecalls,...}
166 :			=> !euses + !iuses > !ecalls + !icalls
167 :			| Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)
168 :			| Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)
169 :
170 :			(* census of the internal part *)
171 :			fun inside f thunk =
172 :			case get f
173 :			of Fun{inside=inside as ref false,...} =>
174 :			(inside := true; thunk() before inside := false)
175 :			| Fun _ => (say "\nalready inside "; PP.printSval(F.VAR f); thunk())
176 :			| _ => bugval("trying to get inside a non-function", F.VAR f)
177 :
178 :			(* Ideally, we should check that usenb = 1, but we may have been a bit
179 :			* conservative when keeping the counts uptodate *)
180 :			fun kill lv = (ASSERT(usenb lv >= 1, concat ["usenb lv >= 1 ", !PP.LVarString lv]); M.rmv m lv)
181 :
182 :			fun census new use = let
183 :			(* val use = if inc then use else unuse *)
184 :			fun call lv = use true lv
185 :			val use = fn F.VAR lv => use false lv | _ => ()
186 :			val newv = new false
187 :			val newf = new true
188 :			fun id x = x
189 :
190 :			fun impurePO po = true (* if a PrimOP is pure or not *)
191 :
192 :			(* here, the use resembles a call, but it's safer to consider it as a use *)
193 :			fun cpo (NONE:F.dict option,po,lty,tycs) = ()
194 :			| cpo (SOME{default,table},po,lty,tycs) =
195 :			(use (F.VAR default); app (use o F.VAR o #2) table)
196 :			fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)
197 :			| cdcon _ = ()
198 :
199 :			(* the actual function:
200 :			* `uvs' is an optional list of booleans representing which of
201 :			* the return values are actually used *)
202 :			fun cexp uvs lexp =
203 :			case lexp
204 :			of F.RET vs => app use vs
205 :			(* (case uvs *)
206 :			(* of SOME uvs => (* only count vals that are actually used *) *)
207 :			(* app (fn(v,uv)=>if uv then use v else ()) (ListPair.zip(vs,uvs)) *)
208 :			(* | NONE => app use vs) *)
209 :
210 :			| F.LET (lvs,le1,le2) =>
211 :			(app newv lvs; cexp uvs le2; cexp (SOME(map used lvs)) le1)
212 :
213 :			| F.FIX (fs,le) =>
214 :			let fun cfun ((_,f,args,body):F.fundec) = (* census of a fundec *)
215 :			(app (newv o #1) args; inside f (fn()=> cexp NONE body))
216 :			fun cfix fs = let (* census of a list of fundecs *)
217 :			val (ufs,nfs) = List.partition (used o #2) fs
218 :			in if List.null ufs then ()
219 :			else (app cfun ufs; cfix nfs)
220 :			end
221 :			in app (newf o #2) fs; cexp uvs le; cfix fs
222 :			end
223 :
224 :			| F.APP (F.VAR f,vs) =>
225 :			(call f; app use vs)
226 :
227 :			| F.TFN ((tf,args,body),le) =>
228 :			(newf tf; cexp uvs le;
229 :			if used tf then inside tf (fn()=> cexp NONE body) else ())
230 :
231 :			| F.TAPP (F.VAR tf,tycs) => call tf
232 :
233 :			| F.SWITCH (v,cs,arms,def) =>
234 :			(use v; Option.map (cexp uvs) def;
235 :			(* here we don't absolutely have to keep track of vars bound within
236 :			* each arm since these vars can't be eliminated anyway *)
237 :			app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp uvs le)
238 :			| (_,le) => cexp uvs le)
239 :			arms)
240 :
241 :			| F.CON (dc,_,v,lv,le) =>
242 :			(cdcon dc; newv lv; cexp uvs le; if used lv then use v else ())
243 :
244 :			| F.RECORD (_,vs,lv,le) =>
245 :			(newv lv; cexp uvs le; if used lv then app use vs else ())
246 :
247 :			| F.SELECT (v,_,lv,le) =>
248 :			(newv lv; cexp uvs le; if used lv then use v else ())
249 :
250 :			| F.RAISE (v,_) => use v
251 :			| F.HANDLE (le,v) => (use v; cexp uvs le)
252 :
253 :			| F.BRANCH (po,vs,le1,le2) =>
254 :			(app use vs; cpo po; cexp uvs le1; cexp uvs le2)
255 :
256 :			| F.PRIMOP (po,vs,lv,le) =>
257 :			(newv lv; cexp uvs le;
258 :			if impurePO po orelse used lv then (cpo po; app use vs) else ())
259 :
260 :			| le => buglexp("unexpected lexp", le)
261 :			in
262 :			cexp
263 :			end
264 :
265 :			(* The code is almost the same for uncounting, except that calling
266 :			* undertaker should not be done for non-free variables. For that we
267 :			* artificially increase the usage count of each variable when it's defined
268 :			* (accomplished via the "def" calls)
269 :			* so that its counter never reaches 0 while processing its scope.
270 :			* Once its scope has been processed, we can completely get rid of
271 :			* the variable and corresponding info (after verifying that the count
272 :			* is indeed exactly 1 (accomplished by the "kill" calls) *)
273 :			fun unusefdec undertaker = let
274 :			(* val use = if inc then use else unuse *)
275 :			fun uncall lv = unuse undertaker true lv
276 :			val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()
277 :			val def = use false
278 :			fun id x = x
279 :
280 :			fun impurePO po = true (* if a PrimOP is pure or not *)
281 :
282 :			fun cpo (NONE:F.dict option,po,lty,tycs) = ()
283 :			| cpo (SOME{default,table},po,lty,tycs) =
284 :			(unuse(F.VAR default); app (unuse o F.VAR o #2) table)
285 :			fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = unuse(F.VAR lv)
286 :			| cdcon _ = ()
287 :
288 :			fun cfun (f,args,body) = (* census of a fundec *)
289 :			(app def args;
290 :			inside f (fn()=> cexp body);
291 :			app kill args)
292 :
293 :			and cexp lexp =
294 :			case lexp
295 :			of F.RET vs => app unuse vs
296 :
297 :			| F.LET (lvs,le1,le2) =>
298 :			(app def lvs; cexp le2; cexp le1; app kill lvs)
299 :
300 :			| F.FIX (fs,le) =>
301 :			let val usedfs = (List.filter (used o #2) fs)
302 :			in app (def o #2) fs;
303 :			cexp le;
304 :			app (fn (_,lv,args,le) => cfun(lv, map #1 args, le)) usedfs;
305 :			app (kill o #2) fs
306 :			end
307 :
308 :			| F.APP (F.VAR f,vs) =>
309 :			(uncall f; app unuse vs)
310 :
311 :			| F.TFN ((tf,args,body),le) =>
312 :			(if used tf then inside tf (fn()=> cexp body) else ();
313 :			def tf; cexp le; kill tf)
314 :
315 :			| F.TAPP (F.VAR tf,tycs) => uncall tf
316 :
317 :			| F.SWITCH (v,cs,arms,default) =>
318 :			(unuse v; Option.map cexp default;
319 :			(* here we don't absolutely have to keep track of vars bound within
320 :			* each arm since these vars can't be eliminated anyway *)
321 :			app (fn (F.DATAcon(dc,_,lv),le) =>
322 :			(cdcon dc; def lv; cexp le; kill lv)
323 :			| (_,le) => cexp le)
324 :			arms)
325 :
326 :			| F.CON (dc,_,v,lv,le) =>
327 :			(cdcon dc; if used lv then unuse v else ();
328 :			def lv; cexp le; kill lv)
329 :
330 :			| F.RECORD (_,vs,lv,le) =>
331 :			(if used lv then app unuse vs else ();
332 :			def lv; cexp le; kill lv)
333 :
334 :			| F.SELECT (v,_,lv,le) =>
335 :			(if used lv then unuse v else ();
336 :			def lv; cexp le; kill lv)
337 :
338 :			| F.RAISE (v,_) => unuse v
339 :			| F.HANDLE (le,v) => (unuse v; cexp le)
340 :
341 :			| F.BRANCH (po,vs,le1,le2) =>
342 :			(app unuse vs; cpo po; cexp le1; cexp le2)
343 :
344 :			| F.PRIMOP (po,vs,lv,le) =>
345 :			(if impurePO po orelse used lv then (cpo po; app unuse vs) else ();
346 :			def lv; cexp le; kill lv)
347 :
348 :			| le => buglexp("unexpected lexp", le)
349 :			in
350 :			cfun
351 :			end
352 :
353 :			val uselexp = census new use NONE
354 :
355 :			fun collect (fdec as (_,f,_,_)) =
356 :			(M.clear m; (* start from a fresh state *)
357 :			uselexp (F.FIX([fdec], F.RET[F.VAR f])))
358 :
359 :			end
360 :			end

---

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