Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/opt/collect.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


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

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