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 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