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

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