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