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

Parent Directory | Revision Log | Patch

	revision 163, Thu Oct 29 21:00:27 1998 UTC	revision 164, Sat Oct 31 01:03:30 1998 UTC
#	Line 6	Line 6
6
7	(* Collect information about variables and function uses.	(* Collect information about variables and function uses.
8	* The info is accumulated in the map `m' *)	* The info is accumulated in the map `m' *)
9	val collect : FLINT.fundec -> unit	val collect : FLINT.fundec -> FLINT.fundec
10
11	(* query functions *)	(* query functions *)
12	val escaping  : FLINT.lvar -> bool  (* non-call uses *)	val escaping  : FLINT.lvar -> bool  (* non-call uses *)
13	val usenb     : FLINT.lvar -> int   (* nb of non-recursive uses *)	val usenb     : FLINT.lvar -> int   (* nb of non-recursive uses *)
14	val called    : FLINT.lvar -> bool  (* known call uses *)	val called    : FLINT.lvar -> bool  (* known call uses *)
15	val insidep   : FLINT.lvar -> bool  (* are we inside f right now ? *)	val actuals   : FLINT.lvar -> (FLINT.value option list) (* constant args *)
	val recursive : FLINT.lvar -> bool  (* self-recursion test *)
16
17	(* inc the "true=call,false=use" count *)	(* inc the "true=call,false=use" count *)
18	val use    : bool -> FLINT.lvar -> unit	val use    : FLINT.value list option -> FLINT.lvar -> unit
19	(* dec the "true=call,false=use" count and call the function if zero *)	(* dec the "true=call,false=use" count and call the function if zero *)
20	val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> unit	val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> unit
21	(* transfer the counts of var1 to var2 *)	(* transfer the counts of var1 to var2 *)
#	Line 25	Line 24
24	val addto  : FLINT.lvar * FLINT.lvar -> unit	val addto  : FLINT.lvar * FLINT.lvar -> unit
25	(* delete the last reference to a variable *)	(* delete the last reference to a variable *)
26	val kill   : FLINT.lvar -> unit	val kill   : FLINT.lvar -> unit
27	(* create a new var entry (true=fun, false=other) initialized to zero *)	(* create a new var entry (SOME arg list if fun) initialized to zero *)
28	val new    : bool -> FLINT.lvar -> unit	val new    : FLINT.lvar list option -> FLINT.lvar -> unit
	(* move all the internal counts to external *)
	val extcounts : FLINT.lvar -> unit
29
30	(* when creating a new var.  Used when alpha-renaming *)	(* when creating a new var.  Used when alpha-renaming *)
31	(* val copy   : FLINT.lvar * FLINT.lvar -> unit *)	(* val copy   : FLINT.lvar * FLINT.lvar -> unit *)
#	Line 41	Line 38
38	((FLINT.lexp -> unit) *	((FLINT.lexp -> unit) *
39	((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))	((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))
40	(* function to collect info about a newly created lexp *)	(* function to collect info about a newly created lexp *)
41	val uselexp : FLINT.lexp -> unit	(*     val uselexp : FLINT.lexp -> unit *)
42		(* function to collect info about a newly created lexp *)
43	(* This allows to execute some code and have all the resulting	val copylexp : FLINT.lvar IntmapF.intmap  -> FLINT.lexp -> FLINT.lexp
	* changes made to the internal (for recursion) counters instead
	* of the external ones. For instance:
	*     inside f (fn () => call ~1 f)
	* would decrement the count of recursive function calls of f *)
	val inside : FLINT.lvar -> (unit -> 'a) -> 'a
44
45	(* mostly useful for PPFlint *)	(* mostly useful for PPFlint *)
46	val LVarString : FLINT.lvar -> string	val LVarString : FLINT.lvar -> string
47	end	end
48
49		(* 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	structure Collect :> COLLECT =	structure Collect :> COLLECT =
75	struct	struct
76	local	local
77	structure F  = FLINT	structure F  = FLINT
78	structure M  = Intmap	structure M  = Intmap
79		structure FM = IntmapF
80	structure LV = LambdaVar	structure LV = LambdaVar
81	structure PP = PPFlint	structure PP = PPFlint
82	in	in
#	Line 71	Line 89
89	| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")	| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
90
91	datatype info	datatype info
92	(* for functions we keep track of calls and escaping uses	(* for functions we keep track of calls and escaping uses *)
93	* and separately for external and internal (recursive) references *)	= Fun of {calls: int ref, uses: int ref, int: int ref,
94	= Fun of {ecalls: int ref, euses: int ref,	args: (FLINT.lvar * (FLINT.value option)) option list ref}
	inside: bool ref,
	icalls: int ref, iuses: int ref}
95	| Var of int ref      (* for other vars, a simple use count is kept *)	| Var of int ref      (* for other vars, a simple use count is kept *)
96	| Transfer of FLINT.lvar      (* for vars who have been transfered *)	| Transfer of FLINT.lvar      (* for vars which have been transfered *)
97
98	exception NotFound	exception NotFound
99
#	Line 92	Line 108
108	raise x;	raise x;
109	Var (ref 0)) *)	Var (ref 0)) *)
110
111	fun new true lv = M.add m (lv, Fun{ecalls=ref 0, euses=ref 0,	fun new (SOME args) lv =
112	inside=ref false,	M.add m (lv, Fun{calls=ref 0, uses=ref 0, int=ref 0,
113	icalls=ref 0, iuses=ref 0})	args=ref (map (fn a => SOME(a, NONE)) args)})
114	| new false lv = M.add m (lv, Var(ref 0))	| new NONE lv = M.add m (lv, Var(ref 0))
115
116	fun LVarString lv =	fun LVarString lv =
117	(LV.lvarName lv)^	(LV.lvarName lv)^
118	((case get lv of	((case get lv of
119	Var uses => "{"^(Int.toString (!uses))^"}"	Var uses => "{"^(Int.toString (!uses))^"}"
120	| Fun {ecalls,euses,icalls,iuses,...} =>	| Fun {calls,uses,...} =>
121	concat	concat ["{", Int.toString (!calls), ",", Int.toString (!uses), "}"]
	["{(", Int.toString (!ecalls), ",", Int.toString (!euses),
	"),(", Int.toString (!icalls), ",", Int.toString (!iuses), ")}"]
122	| Transfer _ => "{-}")	| Transfer _ => "{-}")
123	handle NotFound => "{?}")	handle NotFound => "{?}")
124
#	Line 116	Line 130
130	of Var uses1 =>	of Var uses1 =>
131	(case info2	(case info2
132	of Var uses2 => uses2 := !uses2 + !uses1	of Var uses2 => uses2 := !uses2 + !uses1
133	| Fun {euses=eu2,inside=i2,iuses=iu2,...} =>	| Fun {uses=uses2,...} => uses2 := !uses2 + !uses1
	if !i2 then iu2 := !iu2 + !uses1
	else eu2 := !eu2 + !uses1
134	| Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))	| Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
135	| Fun {inside=i1,euses=eu1,iuses=iu1,ecalls=ec1,icalls=ic1,...} =>	| Fun {uses=uses1,calls=calls1,...} =>
136	(ASSERT(!iu1 + !ic1 = 0 andalso not(!i1), "improper fun transfer");	(case info2
137	case info2	of Fun {uses=uses2,calls=calls2,...} =>
138	of Fun {inside=i2,euses=eu2,iuses=iu2,ecalls=ec2,icalls=ic2,...} =>	(uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
139	if !i2 then (iu2 := !iu2 + !eu1; ic2 := !ic2 + !ec1)	| Var uses2 => uses2 := !uses2 + !uses1
	else (eu2 := !eu2 + !eu1; ec2 := !ec2 + !ec1)
	| Var uses => uses := !uses + !eu1
140	| Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))	| Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))
141	| Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)	| Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)
142	end	end
143	fun transfer (lv1,lv2) =	fun transfer (lv1,lv2) =
144	(addto(lv1, lv2);	(addto(lv1, lv2); M.add m (lv1, Transfer lv2))      (* note the transfer *)
	M.add m (lv1, Transfer lv2))       (* note the transfer *)
145
146	fun inc ri = (ri := !ri + 1)	fun inc ri = (ri := !ri + 1)
147	fun dec ri = (ri := !ri - 1)	fun dec ri = (ri := !ri - 1)
148
149		(* - 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	fun use call lv =	fun use call lv =
165	case get lv	case get lv
166	of Var uses => inc uses	of Var uses => inc uses
	| (Fun {inside=ref true, iuses=uses,icalls=calls,...} |
	Fun {inside=ref false,euses=uses,ecalls=calls,...} ) =>
	(if call then inc calls else (); inc uses)
167	| Transfer lv => use call lv	| Transfer lv => use call lv
168		| 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
174	fun unuse undertaker call lv =	fun unuse undertaker call lv =
175	let fun check uses =	let fun check uses =
176	if !uses < 0 then	if !uses < 0 then
177	bugval("decrementing too much", F.VAR lv)	bugval("decrementing too much", F.VAR lv)
178	else if !uses = 0 then	else if !uses = 0 then
179	undertaker lv	(*  if lv = 1294 then bug "here it is !!" else *) undertaker lv
180	else ()	else ()
181	in case get lv	in case get lv
182	of Var uses => (dec uses; check uses)	of Var uses => (dec uses; check uses)
183	| Fun {inside=ref false,euses=uses,ecalls=calls,...} =>	| Fun {uses,calls,...} =>
184	(dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)	(dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)
	| Fun {inside=ref true, iuses=uses,icalls=calls,...} =>
	(dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown rec-sanity"))
185	| Transfer lv => unuse undertaker call lv	| Transfer lv => unuse undertaker call lv
186	end	end
187
188	fun insidep lv =	fun usenb lv     = case get lv of (Fun{uses=uses,...} | Var uses) => !uses
	case get lv
	of Fun{inside=ref x,...} => x
	| Var us => false
	| Transfer lv => (say "\nCollect insidep on transfer"; insidep lv)
	(* move internal counts to external *)
	fun extcounts lv =
	case get lv
	of Fun{iuses,euses,icalls,ecalls,...}
	=> (euses := !euses + !iuses; iuses := 0;
	ecalls := !ecalls + !icalls; icalls := 0)
	| Var us => ()
	| Transfer lv => (say "\nCollect extcounts on transfer"; extcounts lv)
	fun usenb lv     = case get lv of (Fun{euses=uses,...} | Var uses) => !uses
189	| Transfer _ => 0	| Transfer _ => 0
190	fun used lv      = usenb lv > 0	fun used lv      = usenb lv > 0
191	fun recursive lv = case get lv of (Fun{iuses=uses,...} | Var uses) => !uses > 0
	| Transfer lv => (say "\nCollect:recursive on transfer"; recursive lv)
	(* fun callnb lv    = case get lv of Fun{ecalls,...} => !ecalls | Var us => !us *)
192	fun escaping lv =	fun escaping lv =
193	case get lv	case get lv
194	of Fun{iuses,euses,icalls,ecalls,...}	of Fun{uses,calls,...} => !uses > !calls
	=> !euses + !iuses > !ecalls + !icalls
195	| Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)	| Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)
196	| Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)	| Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)
197
198	fun called lv =	fun called lv =
199	case get lv	case get lv
200	of Fun{icalls,ecalls,...} => !ecalls + !icalls > 0	of Fun{calls,...} => !calls > 0
201	| Var us => false (* arbitrary, but consistent with escaping *)	| Var us => false (* arbitrary, but consistent with escaping *)
202	| Transfer lv => (say "\nCollect escaping on transfer"; called lv)	| Transfer lv => (say "\nCollect escaping on transfer"; called lv)
203
	(* census of the internal part *)
	fun inside f thunk =
	case get f
	of Fun{inside=inside as ref false,...} =>
	(inside := true; thunk() before inside := false)
	| Fun _ => (say "\nalready inside "; PP.printSval(F.VAR f); thunk())
	| _ => bugval("trying to get inside a non-function", F.VAR f)
204	(* 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
205	* conservative when keeping the counts uptodate *)	* 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)	fun kill lv = (ASSERT(usenb lv >= 1, concat ["usenb lv >= 1 ", !PP.LVarString lv]); M.rmv m lv)
207
208	fun census new use = let	(* ********************************************************************** *)
209	(* val use = if inc then use else unuse *)	(* ********************************************************************** *)
210	fun call lv = use true lv
211	val use = fn F.VAR lv => use false lv | _ => ()	datatype usage
212	val newv = new false	= All
213	val newf = new true	| None
214	fun id x = x	| Some of bool list
215
216		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
229		val cplv = LambdaVar.dupLvar
230
231	fun impurePO po = true              (* if a PrimOP is pure or not *)	fun impurePO po = true              (* if a PrimOP is pure or not *)
232
233	(* here, the use resembles a call, but it's safer to consider it as a use *)	fun census newv substvar alpha uvs le = let
234	fun cpo (NONE:F.dict option,po,lty,tycs) = ()	val cexp = census newv substvar
235	| cpo (SOME{default,table},po,lty,tycs) =	val usevar = substvar NONE alpha
236	(use (F.VAR default); app (use o F.VAR o #2) table)	fun callvar args lv = substvar (SOME args) alpha lv
237	fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)	fun use (F.VAR lv) = F.VAR(usevar lv) | use v = v
238	| cdcon _ = ()	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
260		| 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
268	(* the actual function:	| F.FIX (fdecs,le) =>
269	* `uvs' is an optional list of booleans representing which of	let val (nfs, nalpha) = newfs(fdecs, alpha)
	* the return values are actually used *)
	fun cexp uvs lexp =
	case lexp
	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) *)
270
271	| F.LET (lvs,le1,le2) =>	(* census of a function *)
272	(app newv lvs; cexp uvs le2; cexp (SOME(map used lvs)) le1)	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
278	| F.FIX (fs,le) =>	(* some sort of tracing GC on functions *)
279	let fun cfun ((_,f,args,body):F.fundec) = (* census of a fundec *)	fun cfix fs = let
	(app (newv o #1) args; inside f (fn()=> cexp NONE body))
	fun cfix fs = let       (* census of a list of fundecs *)
280	val (ufs,nfs) = List.partition (used o #2) fs	val (ufs,nfs) = List.partition (used o #2) fs
281	in if List.null ufs then ()	in if List.null ufs then []
282	else (app cfun ufs; cfix nfs)	else (map cfun ufs) @ (cfix nfs)
283	end	end
284	in app (newf o #2) fs; cexp uvs le; cfix fs
285		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	end
290
291	| F.APP (F.VAR f,vs) =>	| F.APP (f,args) => F.APP(call args f, map use args)
	(call f; app use vs)
292
293	| F.TFN ((tf,args,body),le) =>	| F.TFN ((lv,args,body),le) =>
294	(newf tf; cexp uvs le;	(* don't forget to rename the tvar also *)
295	if used tf then inside tf (fn()=> cexp NONE body) else ())	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.VAR tf,tycs) => call tf	| F.TAPP (f,tycs) => F.TAPP(call [] f, tycs)
308
309	| F.SWITCH (v,cs,arms,def) =>	| F.SWITCH (v,ac,arms,def) =>
310	(use v; Option.map (cexp uvs) def;	let fun carm (F.DATAcon(dc,tycs,lv),le) =
311	(* here we don't absolutely have to keep track of vars bound within	let val (nlv,nalpha) = newv NONE (lv, alpha)
312	* each arm since these vars can't be eliminated anyway *)	in (F.DATAcon(cdcon dc, tycs, nlv), cexp nalpha uvs le)
313	app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp uvs le)	end
314	| (_,le) => cexp uvs le)	| carm (con,le) = (con, cexp alpha uvs le)
315	arms)	in F.SWITCH(use v, ac, map carm arms, Option.map (cexp alpha uvs) def)
316		end
317
318	| F.CON (dc,_,v,lv,le) =>	| F.CON (dc,tycs,v,lv,le) =>
319	(cdcon dc; newv lv; cexp uvs le; if used lv then use v else ())	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 (_,vs,lv,le) =>	| F.RECORD (rk,vs,lv,le) =>
327	(newv lv; cexp uvs le; if used lv then app use vs else ())	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,_,lv,le) =>	| F.SELECT (v,i,lv,le) =>
335	(newv lv; cexp uvs le; if used lv then use v else ())	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,_) => use v	| F.RAISE (v,ltys) => F.RAISE(use v, ltys)
343	| F.HANDLE (le,v) => (use v; cexp uvs le)
344		| F.HANDLE (le,v) => F.HANDLE(cexp alpha uvs le, use v)
345
346	| F.BRANCH (po,vs,le1,le2) =>	| F.BRANCH (po,vs,le1,le2) =>
347	(app use vs; cpo po; cexp uvs le1; cexp uvs le2)	F.BRANCH(cpo po, map use vs, cexp alpha uvs le1, cexp alpha uvs le2)
348
349	| F.PRIMOP (po,vs,lv,le) =>	| F.PRIMOP (po,vs,lv,le) =>
350	(newv lv; cexp uvs le;	let val (nlv,nalpha) = newv NONE (lv, alpha)
351	if impurePO po orelse used lv then (cpo po; app use vs) else ())	val nle = cexp nalpha uvs le
352		in if impurePO po orelse used nlv
353	| le => buglexp("unexpected lexp", le)	then F.PRIMOP(cpo po, map use vs, nlv, nle)
354	in	else nle
355	cexp	end
356	end	end
357
358	(* The code is almost the same for uncounting, except that calling	(* The code is almost the same for uncounting, except that calling
#	Line 302	Line 367
367	(* val use = if inc then use else unuse *)	(* val use = if inc then use else unuse *)
368	fun uncall lv = unuse undertaker true lv	fun uncall lv = unuse undertaker true lv
369	val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()	val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()
370	val def = use false	val def = use NONE
371	fun id x = x	fun id x = x
372
	fun impurePO po = true              (* if a PrimOP is pure or not *)
373	fun cpo (NONE:F.dict option,po,lty,tycs) = ()	fun cpo (NONE:F.dict option,po,lty,tycs) = ()
374	| cpo (SOME{default,table},po,lty,tycs) =	| cpo (SOME{default,table},po,lty,tycs) =
375	(unuse(F.VAR default); app (unuse o F.VAR o #2) table)	(unuse(F.VAR default); app (unuse o F.VAR o #2) table)
#	Line 314	Line 377
377	| cdcon _ = ()	| cdcon _ = ()
378
379	fun cfun (f,args,body) = (* census of a fundec *)	fun cfun (f,args,body) = (* census of a fundec *)
380	(app def args;	(app def args; cexp body; app kill args)
	inside f (fn()=> cexp body);
	app kill args)
381
382	and cexp lexp =	and cexp lexp =
383	case lexp	case lexp
#	Line 337	Line 398
398	(uncall f; app unuse vs)	(uncall f; app unuse vs)
399
400	| F.TFN ((tf,args,body),le) =>	| F.TFN ((tf,args,body),le) =>
401	(if used tf then inside tf (fn()=> cexp body) else ();	(if used tf then cexp body else ();
402	def tf; cexp le; kill tf)	def tf; cexp le; kill tf)
403
404	| F.TAPP (F.VAR tf,tycs) => uncall tf	| F.TAPP (F.VAR tf,tycs) => uncall tf
#	Line 378	Line 439
439	(cexp, cfun)	(cexp, cfun)
440	end	end
441
442	val uselexp = census new use NONE	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
448		(*  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	fun collect (fdec as (_,f,_,_)) =	fun collect (fdec as (_,f,_,_)) =
463	(M.clear m;                         (* start from a fresh state *)	let val _ = M.clear m               (* start from a fresh state *)
464	uselexp (F.FIX([fdec], F.RET[F.VAR f])))	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
470	end	end
471	end	end

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.163   changed lines   Added in v.164

---

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