Diff of /sml/trunk/src/compiler/FLINT/opt/collect.sml

Parent Directory | Revision Log | Patch

	revision 188, Thu Nov 12 00:24:58 1998 UTC	revision 189, Sun Nov 15 22:29:42 1998 UTC
#	Line 14	Line 14
14	(* query functions *)	(* query functions *)
15	val escaping  : info -> bool        (* non-call uses *)	val escaping  : info -> bool        (* non-call uses *)
16	val called    : info -> bool        (* known call uses *)	val called    : info -> bool        (* known call uses *)
17	val usenb     : info -> int (* nb of non-recursive uses *)	val dead      : info -> bool        (* usenb = 0 ? *)
18		val usenb     : info -> int         (* total nb of uses *)
19	val actuals   : info -> (FLINT.value option list) (* constant args *)	val actuals   : info -> (FLINT.value option list) (* constant args *)
20
21		(* 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	(* inc the "true=call,false=use" count *)	(* inc the "true=call,false=use" count *)
28	val use    : FLINT.value list option -> info -> unit	val use    : FLINT.value list option -> info -> unit
29	(* dec the "true=call,false=use" count and return true if zero *)	(* dec the "true=call,false=use" count and return true if zero *)
#	Line 53	Line 60
60	* beginning, tho).  This looks nice at first, but poses problems:	* beginning, tho).  This looks nice at first, but poses problems:
61	* - when you do simple inlining (just moving the body of the procedure), you	* - 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	*   may inadvertently turn ext-uses into int-uses.  This only happens when
63	*   inlining mutually recursive function, but this can be commen (thing of	*   inlining mutually recursive function, but this can be commen (think of
64	*   when fcontract undoes a useless uncurrying or a recursive function).  This	*   when fcontract undoes a useless uncurrying of a recursive function).  This
65	*   can be readily overcome by not using the `move body' optimization in	*   can be readily overcome by not using the `move body' optimization in
66	*   dangerous cases and do the full copy+kill instead.	*   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	* - you have to keep track of what is inside what.  The way I did it was to
#	Line 65	Line 72
72	*   is unnecessary, but it is necessary when undertaking a function mutually	*   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	*   recursive with a function in which you currently are when you detect the
74	*   function's death.	*   function's death.
75	* rather than fix this last point, I decided to get rid of the distinction.	* rather than fix this last point, I decided to give up on keeping internal
76	* This makes the code simpler and less bug-prone at the cost of slightly	* counts up-to-date.  Instead, I just compute them once during collect and
77	* increasing the number of fcontract passes required.	* 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	*)	*)
82
83	structure Collect :> COLLECT =	structure Collect :> COLLECT =
#	Line 87	Line 97
97	fun ASSERT (true,_) = ()	fun ASSERT (true,_) = ()
98	| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")	| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
99
100	type info	datatype info
101	(* we keep track of calls and escaping uses *)	(* we keep track of calls and escaping uses *)
102	= {calls: int ref, uses: int ref,	= Info of {calls: int ref, uses: int ref, int: (int * int) ref,
103	args: (FLINT.lvar * (FLINT.value option)) option list ref option}	args: (FLINT.lvar * (FLINT.value option)) option list ref option}
104
105	exception NotFound	exception NotFound
106
107	val m : info M.intmap = M.new(128, NotFound)	val m : info M.intmap = M.new(128, NotFound)
108
109		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	(* map related helper functions *)	(* map related helper functions *)
119	fun get lv = (M.map m lv)	fun get lv = (M.map m lv)
120	handle x as NotFound =>	handle x as NotFound =>
#	Line 103	Line 122
122	(LV.lvarName lv)^	(LV.lvarName lv)^
123	". Pretending dead...\n");	". Pretending dead...\n");
124	(*  raise x; *)	(*  raise x; *)
125	{uses=ref 0, calls=ref 0, args=NONE})	new NONE lv)
126
127	fun LVarString lv =	fun LVarString lv =
128	let val {uses=ref uses,calls=ref calls,...} = get lv	let val Info{uses=ref uses,calls=ref calls,...} = get lv
129	in (LV.lvarName lv)^	in (LV.lvarName lv)^
130	"{"^(Int.toString uses)^	"{"^(Int.toString uses)^
131	(if calls > 0 then ","^(Int.toString calls) else "")^"}"	(if calls > 0 then ","^(Int.toString calls) else "")^"}"
132	end	end
133
	fun new args lv =
	let val i = {uses=ref 0, calls=ref 0,
	args=case args
	of SOME args => SOME(ref(map (fn a => SOME(a, NONE)) args))
	| NONE => NONE}
	in M.add m (lv, i); i
	end
134	(* adds the counts of lv1 to those of lv2 *)	(* adds the counts of lv1 to those of lv2 *)
135	fun addto ({uses=uses1,calls=calls1,...}:info,{uses=uses2,calls=calls2,...}:info) =	fun addto (Info{uses=uses1,calls=calls1,...},Info{uses=uses2,calls=calls2,...}) =
136	(uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)	(uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
137
138	fun transfer (lv1,lv2) =	fun transfer (lv1,lv2) =
#	Line 144	Line 155
155	| mergearg (SOME(fv,SOME b),a) =	| mergearg (SOME(fv,SOME b),a) =
156	if a = b orelse a = F.VAR fv then SOME(fv,SOME b) else NONE	if a = b orelse a = F.VAR fv then SOME(fv,SOME b) else NONE
157
158	fun actuals ({args=NONE,...}:info) = bug "can't query actuals of a var"	fun actuals (Info{args=NONE,...}) = bug "no actuals (maybe a var?)"
159	| actuals {args=SOME args,...} = map (fn SOME(_,v) => v | _ => NONE) (!args)	| actuals (Info{args=SOME args,...}) = map (fn SOME(_,v) => v | _ => NONE) (!args)
160
161	fun use call ({uses,calls,args,...}:info) =	fun use call (Info{uses,calls,args,...}) =
162	(inc uses;	(inc uses;
163	case call	case call
164	of NONE => (case args of SOME args => args := map (fn _ => NONE) (!args)	of NONE => (case args of SOME args => args := map (fn _ => NONE) (!args)
#	Line 157	Line 168
168	case args of SOME args => args := ListPair.map mergearg (!args, vals)	case args of SOME args => args := ListPair.map mergearg (!args, vals)
169	| _ => ()))	| _ => ()))
170
171	fun unuse call ({uses,calls,...}:info) =	fun unuse call (Info{uses,calls,...}) =
172	(* notice the calls could be dec'd to negative values because a	(* notice the calls could be dec'd to negative values because a
173	* use might be turned from escaping to known between the census	* use might be turned from escaping to known between the census
174	* and the unuse.  We can't easily detect such changes, but	* and the unuse.  We can't easily detect such changes, but
175	* we can detect it happened when we try to go below zero. *)	* we can detect it happened when we try to go below zero. *)
176	(dec uses;	(dec uses;
177	if (call andalso !calls > 0) then dec calls	if (call (*  andalso !calls > 0 *)) then dec calls
178	else ASSERT(!uses >= !calls, "unknown sanity");	else ASSERT(!uses >= !calls, "unknown sanity");
179	if !uses < 0 then bug "decrementing too much" (* F.VAR lv) *)	if !uses < 0 then bug "decrementing too much" (* F.VAR lv) *)
180	else !uses = 0)	else !uses = 0)
181
182	fun usenb ({uses=ref uses,...}:info) = uses	fun usenb (Info{uses=ref uses,...}) = uses
183	fun used ({uses,...}:info) = !uses > 0	fun used (Info{uses,...}) = !uses > 0
184	fun escaping ({uses,calls,...}:info) = !uses > !calls	fun dead (Info{uses,...}) = !uses = 0
185	fun called ({calls,...}:info) = !calls > 0	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
191	(* Ideally, we should check that usenb = 1, but we may have been a bit	(* Ideally, we should check that usenb = 1, but we may have been a bit
192	* conservative when keeping the counts uptodate *)	* conservative when keeping the counts uptodate *)
#	Line 221	Line 236
236	(* the actual function:	(* the actual function:
237	* `uvs' is an optional list of booleans representing which of	* `uvs' is an optional list of booleans representing which of
238	* the return values are actually used *)	* the return values are actually used *)
239	fun cexp uvs lexp =	fun cexp lexp =
240	(case lexp	(case lexp
241	of F.RET vs => app use vs	of F.RET vs => app use vs
	(*          (case uvs *)
	(*            of SOME uvs => (* only count vals that are actually used *) *)
	(*               app (fn(v,uv)=>if uv then use v else ()) (ListPair.zip(vs,uvs)) *)
	(*             | NONE => app use vs) *)
242
243	| F.LET (lvs,le1,le2) =>	| F.LET (lvs,le1,le2) =>
244	let val lvsi = map newv lvs	let val lvsi = map newv lvs
245	in cexp uvs le2; cexp (usage(map used lvsi)) le1	in cexp le2; cexp le1
246	end	end
247
248	| F.FIX (fs,le) =>	| F.FIX (fs,le) =>
249	let val fs = map (fn (_,f,args,body) =>	let val fs = map (fn (_,f,args,body) =>
250	(newf (SOME(map #1 args)) f,args,body))	(newf (SOME(map #1 args)) f,args,body))
251	fs	fs
252	fun cfun (_,args,body) = (* census of a fundec *)	fun cfun (Info{uses,calls, int, ...}, args,body) =
253	(app (fn (v,t) => ignore(newv v)) args; cexp All body)	(* 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	fun cfix fs =   (* census of a list of fundecs *)	fun cfix fs =   (* census of a list of fundecs *)
263	let val (ufs,nfs) = List.partition (used o #1) fs	let val (ufs,nfs) = List.partition (used o #1) fs
264	in if List.null ufs then ()	in if List.null ufs then ()
265	else (app cfun ufs; cfix nfs)	else (app cfun ufs; cfix nfs)
266	end	end
267	in cexp uvs le; cfix fs	in cexp le; cfix fs
268	end	end
269
270	| F.APP (F.VAR f,vs) =>	| F.APP (F.VAR f,vs) =>
#	Line 253	Line 272
272
273	| F.TFN ((tf,args,body),le) =>	| F.TFN ((tf,args,body),le) =>
274	let val tfi = newf NONE tf	let val tfi = newf NONE tf
275	in cexp uvs le;	in cexp le; if used tfi then cexp body else ()
	if used tfi then cexp All body else ()
276	end	end
277
278	| F.TAPP (F.VAR tf,tycs) => call NONE tf	| F.TAPP (F.VAR tf,tycs) => call NONE tf
279
280	| F.SWITCH (v,cs,arms,def) =>	| F.SWITCH (v,cs,arms,def) =>
281	(use v; Option.map (cexp uvs) def;	(use v; Option.map cexp def;
282	app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp uvs le)	app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp le)
283	| (_,le) => cexp uvs le)	| (_,le) => cexp le)
284	arms)	arms)
285
286	| F.CON (dc,_,v,lv,le) =>	| F.CON (dc,_,v,lv,le) =>
287	let val lvi = newv lv	let val lvi = newv lv
288	in cdcon dc; cexp uvs le; if used lvi then use v else ()	in cdcon dc; cexp le; if used lvi then use v else ()
289	end	end
290
291	| F.RECORD (_,vs,lv,le) =>	| F.RECORD (_,vs,lv,le) =>
292	let val lvi = newv lv	let val lvi = newv lv
293	in cexp uvs le; if used lvi then app use vs else ()	in cexp le; if used lvi then app use vs else ()
294	end	end
295
296	| F.SELECT (v,_,lv,le) =>	| F.SELECT (v,_,lv,le) =>
297	let val lvi = newv lv	let val lvi = newv lv
298	in cexp uvs le; if used lvi then use v else ()	in cexp le; if used lvi then use v else ()
299	end	end
300
301	| F.RAISE (v,_) => use v	| F.RAISE (v,_) => use v
302	| F.HANDLE (le,v) => (use v; cexp uvs le)	| F.HANDLE (le,v) => (use v; cexp le)
303
304	| F.BRANCH (po,vs,le1,le2) =>	| F.BRANCH (po,vs,le1,le2) =>
305	(app use vs; cpo po; cexp uvs le1; cexp uvs le2)	(app use vs; cpo po; cexp le1; cexp le2)
306
307	| F.PRIMOP (po,vs,lv,le) =>	| F.PRIMOP (po,vs,lv,le) =>
308	let val lvi = newv lv	let val lvi = newv lv
309	in cexp uvs le;	in cexp le;
310	if impurePO po orelse used lvi then (cpo po; app use vs) else ()	if impurePO po orelse used lvi then (cpo po; app use vs) else ()
311	end	end
312
#	Line 395	Line 413
413	cexp	cexp
414	end	end
415
416	val uselexp = census All	val uselexp = census
417	fun copylexp alpha le =	fun copylexp alpha le =
418	let val nle = FU.copy alpha le	let val nle = FU.copy alpha le
419	in uselexp nle; nle	in uselexp nle; nle

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.188   changed lines   Added in v.189

---

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