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 164 - (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 164 val collect : FLINT.fundec -> FLINT.fundec
10 : monnier 121
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 : monnier 164 val actuals : FLINT.lvar -> (FLINT.value option list) (* constant args *)
16 : monnier 121
17 :     (* inc the "true=call,false=use" count *)
18 : monnier 164 val use : FLINT.value list option -> FLINT.lvar -> unit
19 : monnier 121 (* 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 : monnier 164 (* create a new var entry (SOME arg list if fun) initialized to zero *)
28 :     val new : FLINT.lvar list option -> FLINT.lvar -> unit
29 : monnier 121
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 : monnier 164 (* val uselexp : FLINT.lexp -> unit *)
42 :     (* function to collect info about a newly created lexp *)
43 :     val copylexp : FLINT.lvar IntmapF.intmap -> FLINT.lexp -> FLINT.lexp
44 : monnier 121
45 :     (* mostly useful for PPFlint *)
46 :     val LVarString : FLINT.lvar -> string
47 :     end
48 :    
49 : monnier 164 (* Internal vs External references:
50 :     * I started with a version that kept track separately of internal and external
51 :     * uses. This has the advantage that if the extuses count goes to zero, we can
52 :     * consider the function as dead. Without this, recursive functions can never
53 :     * be recognized as dead during fcontract (they are still eliminated at the
54 :     * beginning, tho). This looks nice at first, but poses problems:
55 :     * - when you do simple inlining (just moving the body of the procedure), you
56 :     * may inadvertently turn ext-uses into int-uses. This only happens when
57 :     * inlining mutually recursive function, but this can be commen (thing of
58 :     * when fcontract undoes a useless uncurrying or a recursive function). This
59 :     * can be readily overcome by not using the `move body' optimization in
60 :     * dangerous cases and do the full copy+kill instead.
61 :     * - you have to keep track of what is inside what. The way I did it was to
62 :     * have an 'inside' ref cell in each fun. That was a bad idea. The problem
63 :     * stems from the fact that when you detect that a function becomes dead,
64 :     * you have to somehow reset those `inside' ref cells to reflect the location
65 :     * of the function before you can uncount its references. In most cases, this
66 :     * is unnecessary, but it is necessary when undertaking a function mutually
67 :     * recursive with a function in which you currently are when you detect the
68 :     * function's death.
69 :     * rather than fix this last point, I decided to get rid of the distinction.
70 :     * This makes the code simpler and less bug-prone at the cost of slightly
71 :     * increasing the number of fcontract passes required.
72 :     *)
73 :    
74 : monnier 121 structure Collect :> COLLECT =
75 :     struct
76 :     local
77 :     structure F = FLINT
78 :     structure M = Intmap
79 : monnier 164 structure FM = IntmapF
80 : monnier 121 structure LV = LambdaVar
81 :     structure PP = PPFlint
82 :     in
83 :    
84 :     val say = Control.Print.say
85 :     fun bug msg = ErrorMsg.impossible ("Collect: "^msg)
86 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
87 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
88 :     fun ASSERT (true,_) = ()
89 :     | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
90 :    
91 :     datatype info
92 : monnier 164 (* for functions we keep track of calls and escaping uses *)
93 :     = Fun of {calls: int ref, uses: int ref, int: int ref,
94 :     args: (FLINT.lvar * (FLINT.value option)) option list ref}
95 : monnier 121 | Var of int ref (* for other vars, a simple use count is kept *)
96 : monnier 164 | Transfer of FLINT.lvar (* for vars which have been transfered *)
97 : monnier 121
98 :     exception NotFound
99 :    
100 :     val m : info M.intmap = M.new(128, NotFound)
101 :    
102 :     (* map related helper functions *)
103 :     fun get lv = (M.map m lv)
104 :     (* handle x as NotFound =>
105 :     (say "\nCollect:get unknown var ";
106 :     PP.printSval (F.VAR lv);
107 :     say ". Assuming dead...";
108 :     raise x;
109 :     Var (ref 0)) *)
110 :    
111 : monnier 164 fun new (SOME args) lv =
112 :     M.add m (lv, Fun{calls=ref 0, uses=ref 0, int=ref 0,
113 :     args=ref (map (fn a => SOME(a, NONE)) args)})
114 :     | new NONE lv = M.add m (lv, Var(ref 0))
115 : monnier 121
116 :     fun LVarString lv =
117 :     (LV.lvarName lv)^
118 :     ((case get lv of
119 :     Var uses => "{"^(Int.toString (!uses))^"}"
120 : monnier 164 | Fun {calls,uses,...} =>
121 :     concat ["{", Int.toString (!calls), ",", Int.toString (!uses), "}"]
122 : monnier 121 | Transfer _ => "{-}")
123 :     handle NotFound => "{?}")
124 :    
125 :     (* adds the counts of lv1 to those of lv2 *)
126 :     fun addto (lv1,lv2) =
127 :     let val info2 = get lv2
128 :     val info1 = get lv1
129 :     in case info1
130 :     of Var uses1 =>
131 :     (case info2
132 :     of Var uses2 => uses2 := !uses2 + !uses1
133 : monnier 164 | Fun {uses=uses2,...} => uses2 := !uses2 + !uses1
134 : monnier 121 | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
135 : monnier 164 | Fun {uses=uses1,calls=calls1,...} =>
136 :     (case info2
137 :     of Fun {uses=uses2,calls=calls2,...} =>
138 :     (uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
139 :     | Var uses2 => uses2 := !uses2 + !uses1
140 : monnier 121 | Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
141 :     | Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)
142 :     end
143 :     fun transfer (lv1,lv2) =
144 : monnier 164 (addto(lv1, lv2); M.add m (lv1, Transfer lv2)) (* note the transfer *)
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 :     fun actuals lv =
159 :     case get lv
160 :     of Var _ => bug ("can't query actuals of var "^(LVarString lv))
161 :     | Transfer lv => actuals lv
162 :     | Fun{args,...} => map (fn SOME(_,v) => v | _ => NONE) (!args)
163 :    
164 : monnier 121 fun use call lv =
165 :     case get lv
166 :     of Var uses => inc uses
167 :     | Transfer lv => use call lv
168 : monnier 164 | Fun {uses,calls,args,...} =>
169 :     case call of
170 :     NONE => (inc uses; args := map (fn _ => NONE) (!args))
171 :     | SOME vals =>
172 :     (inc calls; inc uses; args := ListPair.map mergearg (!args, vals))
173 : monnier 121
174 :     fun unuse undertaker call lv =
175 :     let fun check uses =
176 :     if !uses < 0 then
177 :     bugval("decrementing too much", F.VAR lv)
178 :     else if !uses = 0 then
179 : monnier 164 (* if lv = 1294 then bug "here it is !!" else *) undertaker lv
180 : monnier 121 else ()
181 :     in case get lv
182 :     of Var uses => (dec uses; check uses)
183 : monnier 164 | Fun {uses,calls,...} =>
184 : monnier 121 (dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)
185 :     | Transfer lv => unuse undertaker call lv
186 :     end
187 :    
188 : monnier 164 fun usenb lv = case get lv of (Fun{uses=uses,...} | Var uses) => !uses
189 : monnier 121 | Transfer _ => 0
190 :     fun used lv = usenb lv > 0
191 : monnier 164
192 : monnier 121 fun escaping lv =
193 :     case get lv
194 : monnier 164 of Fun{uses,calls,...} => !uses > !calls
195 : monnier 121 | Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)
196 :     | Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)
197 :    
198 : monnier 163 fun called lv =
199 :     case get lv
200 : monnier 164 of Fun{calls,...} => !calls > 0
201 : monnier 163 | Var us => false (* arbitrary, but consistent with escaping *)
202 :     | Transfer lv => (say "\nCollect escaping on transfer"; called lv)
203 :    
204 : monnier 121 (* Ideally, we should check that usenb = 1, but we may have been a bit
205 :     * conservative when keeping the counts uptodate *)
206 :     fun kill lv = (ASSERT(usenb lv >= 1, concat ["usenb lv >= 1 ", !PP.LVarString lv]); M.rmv m lv)
207 :    
208 : monnier 164 (* ********************************************************************** *)
209 :     (* ********************************************************************** *)
210 : monnier 121
211 : monnier 164 datatype usage
212 :     = All
213 :     | None
214 :     | Some of bool list
215 : monnier 121
216 : monnier 164 fun usage bs =
217 :     let fun ua [] = All
218 :     | ua (false::_) = Some bs
219 :     | ua (true::bs) = ua bs
220 :     fun un [] = None
221 :     | un (true::_) = Some bs
222 :     | un (false::bs) = un bs
223 :     in case bs
224 :     of true::bs => ua bs
225 :     | false::bs => un bs
226 :     | [] => None
227 :     end
228 : monnier 121
229 : monnier 164 val cplv = LambdaVar.dupLvar
230 : monnier 121
231 : monnier 164 fun impurePO po = true (* if a PrimOP is pure or not *)
232 : monnier 121
233 : monnier 164 fun census newv substvar alpha uvs le = let
234 :     val cexp = census newv substvar
235 :     val usevar = substvar NONE alpha
236 :     fun callvar args lv = substvar (SOME args) alpha lv
237 :     fun use (F.VAR lv) = F.VAR(usevar lv) | use v = v
238 :     fun call args (F.VAR lv) = F.VAR(callvar args lv) | call _ v = v
239 :     fun newvs (lvs,alpha) =
240 :     foldr (fn (lv,(lvs,alpha)) =>
241 :     let val (nlv,nalpha) = newv NONE (lv,alpha)
242 :     in (nlv::lvs, nalpha) end)
243 :     ([],alpha) lvs
244 :     fun newfs (fdecs,alpha) =
245 :     foldr (fn ((_,lv,args,_):F.fundec,(lvs,alpha)) =>
246 :     let val (nlv,nalpha) = newv (SOME(map #1 args)) (lv,alpha)
247 :     in (nlv::lvs, nalpha) end)
248 :     ([],alpha) fdecs
249 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
250 :     (s, Access.EXN(Access.LVAR(usevar lv)), lty)
251 :     | cdcon dc = dc
252 :     fun cpo (SOME{default,table},po,lty,tycs) =
253 :     (SOME{default=usevar default,
254 :     table=map (fn (tycs,lv) => (tycs, usevar lv)) table},
255 :     po,lty,tycs)
256 :     | cpo po = po
257 :     in case le
258 :     of F.RET vs => F.RET(map use vs)
259 : monnier 121
260 : monnier 164 | F.LET (lvs,le,body) =>
261 :     let val (nlvs,nalpha) = newvs (lvs,alpha)
262 :     val nbody = cexp nalpha uvs body
263 :     val nuvs = usage(map used nlvs)
264 :     val nle = cexp alpha nuvs le
265 :     in F.LET(nlvs, nle, nbody)
266 :     end
267 : monnier 121
268 : monnier 164 | F.FIX (fdecs,le) =>
269 :     let val (nfs, nalpha) = newfs(fdecs, alpha)
270 : monnier 121
271 : monnier 164 (* census of a function *)
272 :     fun cfun ((fk,f,args,body):F.fundec,nf) =
273 :     let val (nargs,ialpha) = newvs(map #1 args, nalpha)
274 :     val nbody = cexp ialpha All body
275 :     in (fk, nf, ListPair.zip(nargs, (map #2 args)), nbody)
276 :     end
277 : monnier 121
278 : monnier 164 (* some sort of tracing GC on functions *)
279 :     fun cfix fs = let
280 :     val (ufs,nfs) = List.partition (used o #2) fs
281 :     in if List.null ufs then []
282 :     else (map cfun ufs) @ (cfix nfs)
283 :     end
284 : monnier 121
285 : monnier 164 val nle = cexp nalpha uvs le
286 :     val nfdecs = cfix(ListPair.zip(fdecs, nfs))
287 :     in
288 :     if List.null nfdecs then nle else F.FIX(nfdecs, nle)
289 :     end
290 : monnier 121
291 : monnier 164 | F.APP (f,args) => F.APP(call args f, map use args)
292 :    
293 :     | F.TFN ((lv,args,body),le) =>
294 :     (* don't forget to rename the tvar also *)
295 :     let val (nlv,nalpha) = newv (SOME[]) (lv,alpha)
296 :     val nle = cexp nalpha uvs le
297 :     in
298 :     if used nlv then
299 :     let val (nargs,ialpha) = newvs(map #1 args, alpha)
300 :     val nbody = cexp ialpha All body
301 :     in F.TFN((nlv, ListPair.zip(nargs, map #2 args), nbody), nle)
302 :     end
303 :     else
304 :     nle
305 :     end
306 :    
307 :     | F.TAPP (f,tycs) => F.TAPP(call [] f, tycs)
308 :    
309 :     | F.SWITCH (v,ac,arms,def) =>
310 :     let fun carm (F.DATAcon(dc,tycs,lv),le) =
311 :     let val (nlv,nalpha) = newv NONE (lv, alpha)
312 :     in (F.DATAcon(cdcon dc, tycs, nlv), cexp nalpha uvs le)
313 :     end
314 :     | carm (con,le) = (con, cexp alpha uvs le)
315 :     in F.SWITCH(use v, ac, map carm arms, Option.map (cexp alpha uvs) def)
316 :     end
317 :    
318 :     | F.CON (dc,tycs,v,lv,le) =>
319 :     let val (nlv,nalpha) = newv NONE (lv, alpha)
320 :     val nle = cexp nalpha uvs le
321 :     in if used nlv
322 :     then F.CON(cdcon dc, tycs, use v, nlv, nle)
323 :     else nle
324 :     end
325 :    
326 :     | F.RECORD (rk,vs,lv,le) =>
327 :     let val (nlv,nalpha) = newv NONE (lv, alpha)
328 :     val nle = cexp nalpha uvs le
329 :     in if used nlv
330 :     then F.RECORD(rk, map use vs, nlv, nle)
331 :     else nle
332 :     end
333 :    
334 :     | F.SELECT (v,i,lv,le) =>
335 :     let val (nlv,nalpha) = newv NONE (lv, alpha)
336 :     val nle = cexp nalpha uvs le
337 :     in if used nlv
338 :     then F.SELECT(use v, i, nlv, nle)
339 :     else nle
340 :     end
341 :    
342 :     | F.RAISE (v,ltys) => F.RAISE(use v, ltys)
343 :    
344 :     | F.HANDLE (le,v) => F.HANDLE(cexp alpha uvs le, use v)
345 :    
346 :     | F.BRANCH (po,vs,le1,le2) =>
347 :     F.BRANCH(cpo po, map use vs, cexp alpha uvs le1, cexp alpha uvs le2)
348 :    
349 :     | F.PRIMOP (po,vs,lv,le) =>
350 :     let val (nlv,nalpha) = newv NONE (lv, alpha)
351 :     val nle = cexp nalpha uvs le
352 :     in if impurePO po orelse used nlv
353 :     then F.PRIMOP(cpo po, map use vs, nlv, nle)
354 :     else nle
355 :     end
356 : monnier 121 end
357 :    
358 :     (* The code is almost the same for uncounting, except that calling
359 :     * undertaker should not be done for non-free variables. For that we
360 :     * artificially increase the usage count of each variable when it's defined
361 :     * (accomplished via the "def" calls)
362 :     * so that its counter never reaches 0 while processing its scope.
363 :     * Once its scope has been processed, we can completely get rid of
364 :     * the variable and corresponding info (after verifying that the count
365 :     * is indeed exactly 1 (accomplished by the "kill" calls) *)
366 : monnier 159 fun unuselexp undertaker = let
367 : monnier 121 (* val use = if inc then use else unuse *)
368 :     fun uncall lv = unuse undertaker true lv
369 :     val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()
370 : monnier 164 val def = use NONE
371 : monnier 121 fun id x = x
372 :    
373 :     fun cpo (NONE:F.dict option,po,lty,tycs) = ()
374 :     | cpo (SOME{default,table},po,lty,tycs) =
375 :     (unuse(F.VAR default); app (unuse o F.VAR o #2) table)
376 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = unuse(F.VAR lv)
377 :     | cdcon _ = ()
378 :    
379 :     fun cfun (f,args,body) = (* census of a fundec *)
380 : monnier 164 (app def args; cexp body; app kill args)
381 : monnier 121
382 :     and cexp lexp =
383 :     case lexp
384 :     of F.RET vs => app unuse vs
385 :    
386 :     | F.LET (lvs,le1,le2) =>
387 :     (app def lvs; cexp le2; cexp le1; app kill lvs)
388 :    
389 :     | F.FIX (fs,le) =>
390 :     let val usedfs = (List.filter (used o #2) fs)
391 :     in app (def o #2) fs;
392 :     cexp le;
393 :     app (fn (_,lv,args,le) => cfun(lv, map #1 args, le)) usedfs;
394 :     app (kill o #2) fs
395 :     end
396 :    
397 :     | F.APP (F.VAR f,vs) =>
398 :     (uncall f; app unuse vs)
399 :    
400 :     | F.TFN ((tf,args,body),le) =>
401 : monnier 164 (if used tf then cexp body else ();
402 : monnier 121 def tf; cexp le; kill tf)
403 :    
404 :     | F.TAPP (F.VAR tf,tycs) => uncall tf
405 :    
406 :     | F.SWITCH (v,cs,arms,default) =>
407 :     (unuse v; Option.map cexp default;
408 :     (* here we don't absolutely have to keep track of vars bound within
409 :     * each arm since these vars can't be eliminated anyway *)
410 :     app (fn (F.DATAcon(dc,_,lv),le) =>
411 :     (cdcon dc; def lv; cexp le; kill lv)
412 :     | (_,le) => cexp le)
413 :     arms)
414 :    
415 :     | F.CON (dc,_,v,lv,le) =>
416 :     (cdcon dc; if used lv then unuse v else ();
417 :     def lv; cexp le; kill lv)
418 :    
419 :     | F.RECORD (_,vs,lv,le) =>
420 :     (if used lv then app unuse vs else ();
421 :     def lv; cexp le; kill lv)
422 :    
423 :     | F.SELECT (v,_,lv,le) =>
424 :     (if used lv then unuse v else ();
425 :     def lv; cexp le; kill lv)
426 :    
427 :     | F.RAISE (v,_) => unuse v
428 :     | F.HANDLE (le,v) => (unuse v; cexp le)
429 :    
430 :     | F.BRANCH (po,vs,le1,le2) =>
431 :     (app unuse vs; cpo po; cexp le1; cexp le2)
432 :    
433 :     | F.PRIMOP (po,vs,lv,le) =>
434 :     (if impurePO po orelse used lv then (cpo po; app unuse vs) else ();
435 :     def lv; cexp le; kill lv)
436 :    
437 :     | le => buglexp("unexpected lexp", le)
438 :     in
439 : monnier 159 (cexp, cfun)
440 : monnier 121 end
441 :    
442 : monnier 164 fun uselexp le =
443 :     let fun new' call (lv,alpha) = (new call lv; (lv,alpha))
444 :     fun use' call alpha lv = (use call lv; lv)
445 :     in census new' use' () All le
446 :     end
447 : monnier 121
448 : monnier 164 (* fun uselexp le = (uselexp' le; ()) *)
449 :    
450 :     fun copylexp alpha le =
451 :     let fun new' call (lv,alpha) =
452 :     let val nlv = cplv lv
453 :     in new call nlv; (nlv, FM.add(alpha, lv, nlv))
454 :     end
455 :     fun use' call alpha lv =
456 :     let val nlv = (FM.lookup alpha lv) handle FM.IntmapF => lv
457 :     in use call nlv; nlv
458 :     end
459 :     in census new' use' alpha All le
460 :     end
461 :    
462 : monnier 121 fun collect (fdec as (_,f,_,_)) =
463 : monnier 164 let val _ = M.clear m (* start from a fresh state *)
464 :     val nle = uselexp (F.FIX([fdec], F.RET[F.VAR f]))
465 :     in case nle of
466 :     F.FIX([nfdec], F.RET[F.VAR g]) => (ASSERT(f = g, "f = g"); nfdec)
467 :     | _ => bug "not an fdec anymore"
468 :     end
469 : monnier 121
470 :     end
471 :     end

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