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

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