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

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