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

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