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 189 - (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 186 val actuals : info -> (FLINT.value option list) (* constant args *)
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 189 = Info of {calls: int ref, uses: int ref, int: (int * int) ref,
103 :     args: (FLINT.lvar * (FLINT.value option)) option list ref option}
104 : monnier 121
105 :     exception NotFound
106 :    
107 : monnier 186 val m : info M.intmap = M.new(128, NotFound)
108 : monnier 121
109 : monnier 189 fun new args lv =
110 :     let val i = Info{uses=ref 0, calls=ref 0, int=ref(0,0),
111 :     args=case args
112 :     of SOME args =>
113 :     SOME(ref(map (fn a => SOME(a, NONE)) args))
114 :     | NONE => NONE}
115 :     in M.add m (lv, i); i
116 :     end
117 :    
118 : monnier 121 (* map related helper functions *)
119 :     fun get lv = (M.map m lv)
120 : monnier 186 handle x as NotFound =>
121 :     (say ("Collect: ERROR: get unknown var "^
122 :     (LV.lvarName lv)^
123 :     ". Pretending dead...\n");
124 :     (* raise x; *)
125 : monnier 189 new NONE lv)
126 : monnier 121
127 :     fun LVarString lv =
128 : monnier 189 let val Info{uses=ref uses,calls=ref calls,...} = get lv
129 : monnier 187 in (LV.lvarName lv)^
130 :     "{"^(Int.toString uses)^
131 :     (if calls > 0 then ","^(Int.toString calls) else "")^"}"
132 :     end
133 :    
134 : monnier 121 (* adds the counts of lv1 to those of lv2 *)
135 : monnier 189 fun addto (Info{uses=uses1,calls=calls1,...},Info{uses=uses2,calls=calls2,...}) =
136 : monnier 187 (uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
137 :    
138 : monnier 121 fun transfer (lv1,lv2) =
139 : monnier 187 let val i1 = get lv1
140 :     val i2 = get lv2
141 :     in addto(i1, i2);
142 :     (* note the transfer by redirecting the map *)
143 :     M.add m (lv1, i2)
144 :     end
145 : monnier 121
146 :     fun inc ri = (ri := !ri + 1)
147 :     fun dec ri = (ri := !ri - 1)
148 :    
149 : monnier 164 (* - first list is list of formal args
150 :     * - second is list of `up to know known arg'
151 :     * - third is args of the current call. *)
152 :     fun mergearg (NONE,a) = NONE
153 :     | mergearg (SOME(fv,NONE),a) =
154 :     if a = F.VAR fv then SOME(fv,NONE) else SOME(fv,SOME a)
155 :     | mergearg (SOME(fv,SOME b),a) =
156 :     if a = b orelse a = F.VAR fv then SOME(fv,SOME b) else NONE
157 :    
158 : monnier 189 fun actuals (Info{args=NONE,...}) = bug "no actuals (maybe a var?)"
159 :     | actuals (Info{args=SOME args,...}) = map (fn SOME(_,v) => v | _ => NONE) (!args)
160 : monnier 164
161 : monnier 189 fun use call (Info{uses,calls,args,...}) =
162 : monnier 187 (inc uses;
163 :     case call
164 :     of NONE => (case args of SOME args => args := map (fn _ => NONE) (!args)
165 :     | _ => ())
166 :     | SOME vals =>
167 :     (inc calls;
168 :     case args of SOME args => args := ListPair.map mergearg (!args, vals)
169 :     | _ => ()))
170 : monnier 121
171 : monnier 189 fun unuse call (Info{uses,calls,...}) =
172 : monnier 187 (* notice the calls could be dec'd to negative values because a
173 :     * use might be turned from escaping to known between the census
174 :     * and the unuse. We can't easily detect such changes, but
175 :     * we can detect it happened when we try to go below zero. *)
176 :     (dec uses;
177 : monnier 189 if (call (* andalso !calls > 0 *)) then dec calls
178 : monnier 187 else ASSERT(!uses >= !calls, "unknown sanity");
179 :     if !uses < 0 then bug "decrementing too much" (* F.VAR lv) *)
180 :     else !uses = 0)
181 : monnier 121
182 : monnier 189 fun usenb (Info{uses=ref uses,...}) = uses
183 :     fun used (Info{uses,...}) = !uses > 0
184 :     fun dead (Info{uses,...}) = !uses = 0
185 :     fun escaping (Info{uses,calls,...}) = !uses > !calls
186 :     fun called (Info{calls,...}) = !calls > 0
187 :     fun iusenb (Info{int=ref(u,_),...}) = u
188 :     fun icallnb (Info{int=ref(_,c),...}) = c
189 :     fun ireset (Info{int,...}) = int := (0,0)
190 : monnier 164
191 : monnier 121 (* Ideally, we should check that usenb = 1, but we may have been a bit
192 :     * conservative when keeping the counts uptodate *)
193 : monnier 187 fun kill lv = (ASSERT(usenb(get lv) >= 1, "usenb "^(LVarString lv)^" >= 1 ");
194 : monnier 186 M.rmv m lv)
195 : monnier 121
196 : monnier 164 (* ********************************************************************** *)
197 :     (* ********************************************************************** *)
198 : monnier 121
199 : monnier 164 datatype usage
200 :     = All
201 :     | None
202 :     | Some of bool list
203 : monnier 121
204 : monnier 164 fun usage bs =
205 :     let fun ua [] = All
206 :     | ua (false::_) = Some bs
207 :     | ua (true::bs) = ua bs
208 :     fun un [] = None
209 :     | un (true::_) = Some bs
210 :     | un (false::bs) = un bs
211 :     in case bs
212 :     of true::bs => ua bs
213 :     | false::bs => un bs
214 :     | [] => None
215 :     end
216 : monnier 121
217 : monnier 164 fun impurePO po = true (* if a PrimOP is pure or not *)
218 : monnier 121
219 : monnier 186 val census = let
220 :     (* val use = if inc then use else unuse *)
221 : monnier 187 fun call args lv = use args (get lv)
222 :     val use = fn F.VAR lv => use NONE (get lv) | _ => ()
223 : monnier 186 fun newv lv = new NONE lv
224 :     fun newf args lv = new args lv
225 :     fun id x = x
226 : monnier 121
227 : monnier 186 fun impurePO po = true (* if a PrimOP is pure or not *)
228 : monnier 121
229 : monnier 186 (* here, the use resembles a call, but it's safer to consider it as a use *)
230 :     fun cpo (NONE:F.dict option,po,lty,tycs) = ()
231 :     | cpo (SOME{default,table},po,lty,tycs) =
232 :     (use (F.VAR default); app (use o F.VAR o #2) table)
233 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)
234 :     | cdcon _ = ()
235 : monnier 121
236 : monnier 186 (* the actual function:
237 :     * `uvs' is an optional list of booleans representing which of
238 :     * the return values are actually used *)
239 : monnier 189 fun cexp lexp =
240 : monnier 186 (case lexp
241 :     of F.RET vs => app use vs
242 : monnier 121
243 : monnier 186 | F.LET (lvs,le1,le2) =>
244 :     let val lvsi = map newv lvs
245 : monnier 189 in cexp le2; cexp le1
246 : monnier 186 end
247 : monnier 121
248 : monnier 186 | F.FIX (fs,le) =>
249 :     let val fs = map (fn (_,f,args,body) =>
250 :     (newf (SOME(map #1 args)) f,args,body))
251 :     fs
252 : monnier 189 fun cfun (Info{uses,calls, int, ...}, args,body) =
253 :     (* census of a fundec. We get the internal counts
254 :     * by examining the count difference between before
255 :     * and after census of the body. *)
256 :     let val (euses,ecalls) = (!uses,!calls)
257 :     in
258 :     app (fn (v,t) => ignore(newv v)) args;
259 :     cexp body;
260 :     int := (!uses - euses, !calls - ecalls)
261 :     end
262 : monnier 186 fun cfix fs = (* census of a list of fundecs *)
263 :     let val (ufs,nfs) = List.partition (used o #1) fs
264 :     in if List.null ufs then ()
265 :     else (app cfun ufs; cfix nfs)
266 :     end
267 : monnier 189 in cexp le; cfix fs
268 : monnier 186 end
269 :    
270 :     | F.APP (F.VAR f,vs) =>
271 :     (call (SOME vs) f; app use vs)
272 : monnier 121
273 : monnier 186 | F.TFN ((tf,args,body),le) =>
274 :     let val tfi = newf NONE tf
275 : monnier 189 in cexp le; if used tfi then cexp body else ()
276 : monnier 186 end
277 : monnier 164
278 : monnier 186 | F.TAPP (F.VAR tf,tycs) => call NONE tf
279 : monnier 164
280 : monnier 186 | F.SWITCH (v,cs,arms,def) =>
281 : monnier 189 (use v; Option.map cexp def;
282 :     app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp le)
283 :     | (_,le) => cexp le)
284 : monnier 186 arms)
285 :    
286 :     | F.CON (dc,_,v,lv,le) =>
287 :     let val lvi = newv lv
288 : monnier 189 in cdcon dc; cexp le; if used lvi then use v else ()
289 : monnier 186 end
290 : monnier 164
291 : monnier 186 | F.RECORD (_,vs,lv,le) =>
292 :     let val lvi = newv lv
293 : monnier 189 in cexp le; if used lvi then app use vs else ()
294 : monnier 186 end
295 : monnier 164
296 : monnier 186 | F.SELECT (v,_,lv,le) =>
297 :     let val lvi = newv lv
298 : monnier 189 in cexp le; if used lvi then use v else ()
299 : monnier 186 end
300 : monnier 164
301 : monnier 186 | F.RAISE (v,_) => use v
302 : monnier 189 | F.HANDLE (le,v) => (use v; cexp le)
303 : monnier 186
304 :     | F.BRANCH (po,vs,le1,le2) =>
305 : monnier 189 (app use vs; cpo po; cexp le1; cexp le2)
306 : monnier 186
307 :     | F.PRIMOP (po,vs,lv,le) =>
308 :     let val lvi = newv lv
309 : monnier 189 in cexp le;
310 : monnier 186 if impurePO po orelse used lvi then (cpo po; app use vs) else ()
311 :     end
312 :    
313 :     | le => buglexp("unexpected lexp", le)) handle x => raise x
314 :     in
315 :     cexp
316 : monnier 121 end
317 :    
318 :     (* The code is almost the same for uncounting, except that calling
319 :     * undertaker should not be done for non-free variables. For that we
320 :     * artificially increase the usage count of each variable when it's defined
321 :     * (accomplished via the "def" calls)
322 :     * so that its counter never reaches 0 while processing its scope.
323 :     * Once its scope has been processed, we can completely get rid of
324 :     * the variable and corresponding info (after verifying that the count
325 :     * is indeed exactly 1 (accomplished by the "kill" calls) *)
326 : monnier 159 fun unuselexp undertaker = let
327 : monnier 121 (* val use = if inc then use else unuse *)
328 : monnier 187 fun uncall lv = if unuse true (get lv) then undertaker lv else ()
329 :     val unuse = fn F.VAR lv => if unuse false (get lv) then undertaker lv else ()
330 :     | _ => ()
331 :     fun def i = (use NONE i)
332 : monnier 121 fun id x = x
333 :    
334 :     fun cpo (NONE:F.dict option,po,lty,tycs) = ()
335 :     | cpo (SOME{default,table},po,lty,tycs) =
336 :     (unuse(F.VAR default); app (unuse o F.VAR o #2) table)
337 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = unuse(F.VAR lv)
338 :     | cdcon _ = ()
339 :    
340 : monnier 187 fun cfun (args,body) = (* census of a fundec *)
341 :     (app (def o get) args; cexp body; app kill args) handle x => raise x
342 : monnier 121
343 :     and cexp lexp =
344 : monnier 186 (case lexp
345 : monnier 121 of F.RET vs => app unuse vs
346 :    
347 :     | F.LET (lvs,le1,le2) =>
348 : monnier 187 (app (def o get) lvs; cexp le2; cexp le1; app kill lvs)
349 : monnier 121
350 :     | F.FIX (fs,le) =>
351 : monnier 187 let val fs = map (fn (_,f,args,body) => (get f, f, args, body)) fs
352 :     val usedfs = (List.filter (used o #1) fs)
353 :     in app (def o #1) fs;
354 : monnier 121 cexp le;
355 : monnier 187 app (fn (_,_,args,le) => cfun(map #1 args, le)) usedfs;
356 : monnier 121 app (kill o #2) fs
357 :     end
358 :    
359 :     | F.APP (F.VAR f,vs) =>
360 :     (uncall f; app unuse vs)
361 :    
362 :     | F.TFN ((tf,args,body),le) =>
363 : monnier 187 let val tfi = get tf
364 :     in if used tfi then cexp body else ();
365 :     def tfi; cexp le; kill tf
366 :     end
367 : monnier 121
368 :     | F.TAPP (F.VAR tf,tycs) => uncall tf
369 :    
370 :     | F.SWITCH (v,cs,arms,default) =>
371 :     (unuse v; Option.map cexp default;
372 :     (* here we don't absolutely have to keep track of vars bound within
373 :     * each arm since these vars can't be eliminated anyway *)
374 :     app (fn (F.DATAcon(dc,_,lv),le) =>
375 : monnier 187 (cdcon dc; def(get lv); cexp le; kill lv)
376 : monnier 121 | (_,le) => cexp le)
377 :     arms)
378 :    
379 :     | F.CON (dc,_,v,lv,le) =>
380 : monnier 187 let val lvi = get lv
381 :     in cdcon dc; if used lvi then unuse v else ();
382 :     def lvi; cexp le; kill lv
383 :     end
384 : monnier 121
385 :     | F.RECORD (_,vs,lv,le) =>
386 : monnier 187 let val lvi = get lv
387 :     in if used lvi then app unuse vs else ();
388 :     def lvi; cexp le; kill lv
389 :     end
390 : monnier 121
391 :     | F.SELECT (v,_,lv,le) =>
392 : monnier 187 let val lvi = get lv
393 :     in if used lvi then unuse v else ();
394 :     def lvi; cexp le; kill lv
395 :     end
396 : monnier 121
397 :     | F.RAISE (v,_) => unuse v
398 :     | F.HANDLE (le,v) => (unuse v; cexp le)
399 :    
400 :     | F.BRANCH (po,vs,le1,le2) =>
401 :     (app unuse vs; cpo po; cexp le1; cexp le2)
402 :    
403 :     | F.PRIMOP (po,vs,lv,le) =>
404 : monnier 187 let val lvi = get lv
405 :     in if impurePO po orelse used lvi
406 :     then (cpo po; app unuse vs)
407 :     else ();
408 :     def lvi; cexp le; kill lv
409 :     end
410 : monnier 121
411 : monnier 186 | le => buglexp("unexpected lexp", le)) handle x => raise x
412 : monnier 121 in
413 : monnier 187 cexp
414 : monnier 121 end
415 :    
416 : monnier 189 val uselexp = census
417 : monnier 164 fun copylexp alpha le =
418 : monnier 186 let val nle = FU.copy alpha le
419 :     in uselexp nle; nle
420 : monnier 164 end
421 :    
422 : monnier 121 fun collect (fdec as (_,f,_,_)) =
423 : monnier 186 ((* say "Entering Collect...\n"; *)
424 :     M.clear m; (* start from a fresh state *)
425 :     PP.LVarString := LVarString;
426 :     uselexp (F.FIX([fdec], F.RET[F.VAR f]));
427 :     (* say "...Collect Done.\n"; *)
428 :     fdec)
429 : monnier 121
430 :     end
431 :     end

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