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

Parent Directory | Revision Log | Patch

	revision 185, Tue Nov 10 21:01:05 1998 UTC	revision 186, Wed Nov 11 05:24:43 1998 UTC
#	Line 9	Line 9
9	* The info is accumulated in the map `m' *)	* The info is accumulated in the map `m' *)
10	val collect : FLINT.fundec -> FLINT.fundec	val collect : FLINT.fundec -> FLINT.fundec
11
12	(*      val get : FLINT.lvar -> info *)	val get : FLINT.lvar -> info
13
14	(* query functions *)	(* query functions *)
15	val escaping  : FLINT.lvar -> bool  (* non-call uses *)	val escaping  : info -> bool        (* non-call uses *)
16	val called    : FLINT.lvar -> bool  (* known call uses *)	val called    : info -> bool        (* known call uses *)
17	val usenb     : FLINT.lvar -> int   (* nb of non-recursive uses *)	val usenb     : info -> int (* nb of non-recursive uses *)
18	val actuals   : FLINT.lvar -> (FLINT.value option list) (* constant args *)	val actuals   : info -> (FLINT.value option list) (* constant args *)
19
20	(* inc the "true=call,false=use" count *)	(* inc the "true=call,false=use" count *)
21	val use    : FLINT.value list option -> FLINT.lvar -> unit	val use    : FLINT.value list option -> info -> unit
22	(* dec the "true=call,false=use" count and call the function if zero *)	(* 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 -> unit	val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> bool
24	(* transfer the counts of var1 to var2 *)	(* transfer the counts of var1 to var2 *)
25	val transfer : FLINT.lvar * FLINT.lvar -> unit	val transfer : FLINT.lvar * FLINT.lvar -> unit
26	(* add the counts of var1 to var2 *)	(* add the counts of var1 to var2 *)
27	val addto  : FLINT.lvar * FLINT.lvar -> unit	(*  val addto  : info * info -> unit *)
28	(* delete the last reference to a variable *)	(* delete the last reference to a variable *)
29	val kill   : FLINT.lvar -> unit	val kill   : FLINT.lvar -> unit
30	(* create a new var entry (SOME arg list if fun) initialized to zero *)	(* create a new var entry (SOME arg list if fun) initialized to zero *)
31	val new    : FLINT.lvar list option -> FLINT.lvar -> unit	val new    : FLINT.lvar list option -> FLINT.lvar -> info
32
33	(* when creating a new var.  Used when alpha-renaming *)	(* when creating a new var.  Used when alpha-renaming *)
34	(* val copy   : FLINT.lvar * FLINT.lvar -> unit *)	(* val copy   : FLINT.lvar * FLINT.lvar -> unit *)
#	Line 41	Line 41
41	((FLINT.lexp -> unit) *	((FLINT.lexp -> unit) *
42	((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))	((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))
43	(* function to collect info about a newly created lexp *)	(* function to collect info about a newly created lexp *)
44	(*     val uselexp : FLINT.lexp -> unit *)	val uselexp : FLINT.lexp -> unit
45	(* function to collect info about a newly created lexp *)	(* function to copy (and collect info) a lexp *)
46	val copylexp : FLINT.lvar IntmapF.intmap  -> FLINT.lexp -> FLINT.lexp	val copylexp : FLINT.lvar IntmapF.intmap  -> FLINT.lexp -> FLINT.lexp
47
48	(* mostly useful for PPFlint *)	(* mostly useful for PPFlint *)
#	Line 79	Line 79
79	local	local
80	structure F  = FLINT	structure F  = FLINT
81	structure M  = Intmap	structure M  = Intmap
82	structure FM = IntmapF	structure FU = FlintUtil
83	structure LV = LambdaVar	structure LV = LambdaVar
84	structure PP = PPFlint	structure PP = PPFlint
85	in	in
#	Line 91	Line 91
91	fun ASSERT (true,_) = ()	fun ASSERT (true,_) = ()
92	| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")	| ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
93
94		exception UnexpectedTransfer
95
96	datatype info	datatype info
97	(* for functions we keep track of calls and escaping uses *)	(* for functions we keep track of calls and escaping uses *)
98	= Fun of {calls: int ref, uses: int ref, int: int ref,	= Fun of {calls: int ref, uses: int ref,
99	args: (FLINT.lvar * (FLINT.value option)) option list ref}	args: (FLINT.lvar * (FLINT.value option)) option list ref}
100	| 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 *)
101	| Transfer of FLINT.lvar      (* for vars which have been transfered *)	| Transfer of FLINT.lvar      (* for vars which have been transfered *)
102
103	exception NotFound	exception NotFound
104
105	val m : info M.intmap = M.new(1024, NotFound)	val m : info M.intmap = M.new(128, NotFound)
106
107	(* map related helper functions *)	(* map related helper functions *)
108	fun get lv = (M.map m lv)	fun get lv = (M.map m lv)
109	(* handle x as NotFound =>	handle x as NotFound =>
110	(say "\nCollect:get unknown var ";	(say ("Collect: ERROR: get unknown var "^
111	PP.printSval (F.VAR lv);	(LV.lvarName lv)^
112	say ". Assuming dead...";	". Pretending dead...\n");
113	raise x;	(*  raise x; *)
114	Var (ref 0)) *)	Var (ref 0))
	fun new (SOME args) lv =
	M.add m (lv, Fun{calls=ref 0, uses=ref 0, int=ref 0,
	args=ref (map (fn a => SOME(a, NONE)) args)})
	| 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 {calls,uses,...} =>	| Fun {calls,uses,...} =>
121	concat ["{", Int.toString (!calls), ",", Int.toString (!uses), "}"]	concat ["{", Int.toString (!uses), ",", Int.toString (!calls), "}"]
122	| Transfer _ => "{-}")	| Transfer lv => "{->"^(LVarString lv)^"}")
123	handle NotFound => "{?}")	handle NotFound => "{?}")
124
125		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	(* adds the counts of lv1 to those of lv2 *)	(* adds the counts of lv1 to those of lv2 *)
137	fun addto (lv1,lv2) =	fun addto (info1,info2) =
138	let val info2 = get lv2	case info1
	val info1 = get lv1
	in case info1
139	of Var uses1 =>	of Var uses1 =>
140	(case info2	(case info2
141	of Var uses2 => uses2 := !uses2 + !uses1	of Var uses2 => uses2 := !uses2 + !uses1
142	| Fun {uses=uses2,...} => uses2 := !uses2 + !uses1	| Fun {uses=uses2,...} => uses2 := !uses2 + !uses1
143	| Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))	| Transfer _ => raise UnexpectedTransfer)
144	| Fun {uses=uses1,calls=calls1,...} =>	| Fun {uses=uses1,calls=calls1,...} =>
145	(case info2	(case info2
146	of Fun {uses=uses2,calls=calls2,...} =>	of Fun {uses=uses2,calls=calls2,...} =>
147	(uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)	(uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
148	| Var uses2 => uses2 := !uses2 + !uses1	| Var uses2 => uses2 := !uses2 + !uses1
149	| Transfer _ => bugval("transfering to a Transfer", F.VAR lv2))	| Transfer _ => raise UnexpectedTransfer)
150	| Transfer _ => bugval("transfering from a Transfer", F.VAR lv1)	| Transfer _ => raise UnexpectedTransfer
151	end
152	fun transfer (lv1,lv2) =	fun transfer (lv1,lv2) =
153	(addto(lv1, lv2); M.add m (lv1, Transfer lv2))      (* note the transfer *)	(addto(get lv1, get lv2);
154		(* note the transfer *)
155		M.add m (lv1, Transfer lv2)) handle x => raise x
156
157	fun inc ri = (ri := !ri + 1)	fun inc ri = (ri := !ri + 1)
158	fun dec ri = (ri := !ri - 1)	fun dec ri = (ri := !ri - 1)
#	Line 158	Line 166
166	| mergearg (SOME(fv,SOME b),a) =	| mergearg (SOME(fv,SOME b),a) =
167	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
168
169	fun actuals lv =	fun actuals (Var _) = bug "can't query actuals of a var" (* (LVarString lv) *)
170	case get lv	| actuals (Transfer lv) = raise UnexpectedTransfer
171	of Var _ => bug ("can't query actuals of var "^(LVarString lv))	| actuals (Fun{args,...}) = map (fn SOME(_,v) => v | _ => NONE) (!args)
172	| Transfer lv => actuals lv
173	| Fun{args,...} => map (fn SOME(_,v) => v | _ => NONE) (!args)	fun use call (Var uses) = inc uses
174		| use call (Transfer lv) = raise UnexpectedTransfer
175	fun use call lv =	| use call (Fun {uses,calls,args,...}) =
	case get lv
	of Var uses => inc uses
	| Transfer lv => use call lv
	| Fun {uses,calls,args,...} =>
176	case call of	case call of
177	NONE => (inc uses; args := map (fn _ => NONE) (!args))	NONE => (inc uses; args := map (fn _ => NONE) (!args))
178	| SOME vals =>	| SOME vals =>
#	Line 179	Line 183
183	if !uses < 0 then	if !uses < 0 then
184	bugval("decrementing too much", F.VAR lv)	bugval("decrementing too much", F.VAR lv)
185	else if !uses = 0 then	else if !uses = 0 then
186	(*  if lv = 1294 then bug "here it is !!" else *) undertaker lv	(undertaker lv; true)
187	else ()	else false
188	in case get lv	in case get' lv
189	of Var uses => (dec uses; check uses)	of Var uses => (dec uses; check uses)
190	| Fun {uses,calls,...} =>	| Fun {uses,calls,...} =>
191	(dec uses; if call then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)	(dec uses; if (call andalso !calls > 0) then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)
192	| Transfer lv => unuse undertaker call lv	| Transfer lv => bug "transfer"
193	end	end handle x => raise x
194
195	fun usenb lv     = case get lv of (Fun{uses=uses,...} | Var uses) => !uses	fun usenb (Fun{uses=uses,...} | Var uses) = !uses
196	| Transfer _ => 0	| usenb (Transfer _) = (raise UnexpectedTransfer; 0)
197	fun used lv      = usenb lv > 0	fun used i      = usenb i > 0
198
199	fun escaping lv =	fun escaping (Fun{uses,calls,...}) = !uses > !calls
200	case get lv	| escaping (Var us) = !us > 0 (* arbitrary, but hopefully "safe" *)
201	of Fun{uses,calls,...} => !uses > !calls	| escaping (Transfer lv) = raise UnexpectedTransfer
202	| Var us => !us > 0 (* arbitrary, but I opted for the "safe" choice *)
203	| Transfer lv => (say "\nCollect escaping on transfer"; escaping lv)	fun called (Fun{calls,...}) = !calls > 0
204		| called (Var us) = false (* arbitrary, but consistent with escaping *)
205	fun called lv =	| called (Transfer lv) = raise UnexpectedTransfer
	case get lv
	of Fun{calls,...} => !calls > 0
	| Var us => false (* arbitrary, but consistent with escaping *)
	| Transfer lv => (say "\nCollect escaping on transfer"; called lv)
206
207	(* 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
208	* conservative when keeping the counts uptodate *)	* 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)	fun kill lv = (ASSERT(usenb(get' lv) >= 1, "usenb "^(LVarString lv)^" >= 1 ");
210		M.rmv m lv)
211
212	(* ********************************************************************** *)	(* ********************************************************************** *)
213	(* ********************************************************************** *)	(* ********************************************************************** *)
#	Line 229	Line 230
230	| [] => None	| [] => None
231	end	end
232
233	val cplv = LambdaVar.dupLvar	fun impurePO po = true          (* if a PrimOP is pure or not *)
234
235		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
243	fun impurePO po = true          (* if a PrimOP is pure or not *)	fun impurePO po = true          (* if a PrimOP is pure or not *)
244
245	fun census newv substvar alpha uvs le = let	(* here, the use resembles a call, but it's safer to consider it as a use *)
246	val cexp = census newv substvar	fun cpo (NONE:F.dict option,po,lty,tycs) = ()
247	val usevar = substvar NONE alpha	| cpo (SOME{default,table},po,lty,tycs) =
248	fun callvar args lv = substvar (SOME args) alpha lv	(use (F.VAR default); app (use o F.VAR o #2) table)
249	fun use (F.VAR lv) = F.VAR(usevar lv) | use v = v	fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)
250	fun call args (F.VAR lv) = F.VAR(callvar args lv) | call _ v = v	| cdcon _ = ()
	fun newvs (lvs,alpha) =
	foldr (fn (lv,(lvs,alpha)) =>
	let val (nlv,nalpha) = newv NONE (lv,alpha)
	in (nlv::lvs, nalpha) end)
	([],alpha) lvs
	fun newfs (fdecs,alpha) =
	foldr (fn ((_,lv,args,_):F.fundec,(lvs,alpha)) =>
	let val (nlv,nalpha) = newv (SOME(map #1 args)) (lv,alpha)
	in (nlv::lvs, nalpha) end)
	([],alpha) fdecs
	fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
	(s, Access.EXN(Access.LVAR(usevar lv)), lty)
	| cdcon dc = dc
	fun cpo (SOME{default,table},po,lty,tycs) =
	(SOME{default=usevar default,
	table=map (fn (tycs,lv) => (tycs, usevar lv)) table},
	po,lty,tycs)
	| cpo po = po
	in case le
	of F.RET vs => F.RET(map use vs)
	| F.LET (lvs,le,body) =>
	let val (nlvs,nalpha) = newvs (lvs,alpha)
	val nbody = cexp nalpha uvs body
	val nuvs = usage(map used nlvs)
	val nle = cexp alpha nuvs le
	in F.LET(nlvs, nle, nbody)
	end
	| F.FIX (fdecs,le) =>
	let val (nfs, nalpha) = newfs(fdecs, alpha)
	(* census of a function *)
	fun cfun ((fk,f,args,body):F.fundec,nf) =
	let val (nargs,ialpha) = newvs(map #1 args, nalpha)
	val nbody = cexp ialpha All body
	in (fk, nf, ListPair.zip(nargs, (map #2 args)), nbody)
	end
	(* some sort of tracing GC on functions *)
	fun cfix fs = let
	val (ufs,nfs) = List.partition (used o #2) fs
	in if List.null ufs then []
	else (map cfun ufs) @ (cfix nfs)
	end
251
252	val nle = cexp nalpha uvs le	(* the actual function:
253	val nfdecs = cfix(ListPair.zip(fdecs, nfs))	* `uvs' is an optional list of booleans representing which of
254	in	* the return values are actually used *)
255	if List.null nfdecs then nle else F.FIX(nfdecs, nle)	fun cexp uvs lexp =
256	end	(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
263	| F.APP (f,args) => F.APP(call args f, map use args)	| 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
268	| F.TFN ((lv,args,body),le) =>	| F.FIX (fs,le) =>
269	(* don't forget to rename the tvar also *)	let val fs = map (fn (_,f,args,body) =>
270	let val (nlv,nalpha) = newv (SOME[]) (lv,alpha)	(newf (SOME(map #1 args)) f,args,body))
271	val nle = cexp nalpha uvs le	fs
272	in	fun cfun (_,args,body) = (* census of a fundec *)
273	if used nlv then	(app (fn (v,t) => ignore(newv v)) args; cexp All body)
274	let val (nargs,ialpha) = newvs(map #1 args, alpha)	fun cfix fs =   (* census of a list of fundecs *)
275	val nbody = cexp ialpha All body	let val (ufs,nfs) = List.partition (used o #1) fs
276	in F.TFN((nlv, ListPair.zip(nargs, map #2 args), nbody), nle)	in if List.null ufs then ()
277		else (app cfun ufs; cfix nfs)
278	end	end
279	else	in cexp uvs le; cfix fs
	nle
280	end	end
281
282	| F.TAPP (f,tycs) => F.TAPP(call [] f, tycs)	| F.APP (F.VAR f,vs) =>
283		(call (SOME vs) f; app use vs)
284
285	| F.SWITCH (v,ac,arms,def) =>	| F.TFN ((tf,args,body),le) =>
286	let fun carm (F.DATAcon(dc,tycs,lv),le) =	let val tfi = newf NONE tf
287	let val (nlv,nalpha) = newv NONE (lv, alpha)	in cexp uvs le;
288	in (F.DATAcon(cdcon dc, tycs, nlv), cexp nalpha uvs le)	if used tfi then cexp All body else ()
	end
	| carm (con,le) = (con, cexp alpha uvs le)
	in F.SWITCH(use v, ac, map carm arms, Option.map (cexp alpha uvs) def)
289	end	end
290
291	| F.CON (dc,tycs,v,lv,le) =>	| F.TAPP (F.VAR tf,tycs) => call NONE tf
	let val (nlv,nalpha) = newv NONE (lv, alpha)
	val nle = cexp nalpha uvs le
	in if used nlv
	then F.CON(cdcon dc, tycs, use v, nlv, nle)
	else nle
	end
292
293	| F.RECORD (rk,vs,lv,le) =>	| F.SWITCH (v,cs,arms,def) =>
294	let val (nlv,nalpha) = newv NONE (lv, alpha)	(use v; Option.map (cexp uvs) def;
295	val nle = cexp nalpha uvs le	app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp uvs le)
296	in if used nlv	| (_,le) => cexp uvs le)
297	then F.RECORD(rk, map use vs, nlv, nle)	arms)
298	else nle
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	end
303
304	| F.SELECT (v,i,lv,le) =>	| F.RECORD (_,vs,lv,le) =>
305	let val (nlv,nalpha) = newv NONE (lv, alpha)	let val lvi = newv lv
306	val nle = cexp nalpha uvs le	in cexp uvs le; if used lvi then app use vs else ()
	in if used nlv
	then F.SELECT(use v, i, nlv, nle)
	else nle
307	end	end
308
309	| F.RAISE (v,ltys) => F.RAISE(use v, ltys)	| 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
314	| F.HANDLE (le,v) => F.HANDLE(cexp alpha uvs le, use v)	| F.RAISE (v,_) => use v
315		| F.HANDLE (le,v) => (use v; cexp uvs le)
316
317	| F.BRANCH (po,vs,le1,le2) =>	| F.BRANCH (po,vs,le1,le2) =>
318	F.BRANCH(cpo po, map use vs, cexp alpha uvs le1, cexp alpha uvs le2)	(app use vs; cpo po; cexp uvs le1; cexp uvs le2)
319
320	| F.PRIMOP (po,vs,lv,le) =>	| F.PRIMOP (po,vs,lv,le) =>
321	let val (nlv,nalpha) = newv NONE (lv, alpha)	let val lvi = newv lv
322	val nle = cexp nalpha uvs le	in cexp uvs le;
323	in if impurePO po orelse used nlv	if impurePO po orelse used lvi then (cpo po; app use vs) else ()
	then F.PRIMOP(cpo po, map use vs, nlv, nle)
	else nle
324	end	end
325
326		| le => buglexp("unexpected lexp", le)) handle x => raise x
327		in
328		cexp
329	end	end
330
331	(* The code is almost the same for uncounting, except that calling	(* The code is almost the same for uncounting, except that calling
#	Line 368	Line 338
338	* is indeed exactly 1 (accomplished by the "kill" calls) *)	* is indeed exactly 1 (accomplished by the "kill" calls) *)
339	fun unuselexp undertaker = let	fun unuselexp undertaker = let
340	(* val use = if inc then use else unuse *)	(* val use = if inc then use else unuse *)
341	fun uncall lv = unuse undertaker true lv	fun uncall lv = ignore(unuse undertaker true lv)
342	val unuse = fn F.VAR lv => unuse undertaker false lv | _ => ()	val unuse = fn F.VAR lv => ignore(unuse undertaker false lv) | _ => ()
343	val def = use NONE	fun def lv = (use NONE (get lv)) handle x => raise x
344	fun id x = x	fun id x = x
345
346	fun cpo (NONE:F.dict option,po,lty,tycs) = ()	fun cpo (NONE:F.dict option,po,lty,tycs) = ()
#	Line 380	Line 350
350	| cdcon _ = ()	| cdcon _ = ()
351
352	fun cfun (f,args,body) = (* census of a fundec *)	fun cfun (f,args,body) = (* census of a fundec *)
353	(app def args; cexp body; app kill args)	(app def args; cexp body; app kill args) handle x => raise x
354
355	and cexp lexp =	and cexp lexp =
356	case lexp	(case lexp
357	of F.RET vs => app unuse vs	of F.RET vs => app unuse vs
358
359	| F.LET (lvs,le1,le2) =>	| F.LET (lvs,le1,le2) =>
360	(app def lvs; cexp le2; cexp le1; app kill lvs)	(app def lvs; cexp le2; cexp le1; app kill lvs)
361
362	| F.FIX (fs,le) =>	| F.FIX (fs,le) =>
363	let val usedfs = (List.filter (used o #2) fs)	let val usedfs = (List.filter ((used o get o #2) handle x => raise x) fs)
364	in app (def o #2) fs;	in app (def o #2) fs;
365	cexp le;	cexp le;
366	app (fn (_,lv,args,le) => cfun(lv, map #1 args, le)) usedfs;	app (fn (_,lv,args,le) => cfun(lv, map #1 args, le)) usedfs;
#	Line 401	Line 371
371	(uncall f; app unuse vs)	(uncall f; app unuse vs)
372
373	| F.TFN ((tf,args,body),le) =>	| F.TFN ((tf,args,body),le) =>
374	(if used tf then cexp body else ();	(if used(get tf) then cexp body else ();
375	def tf; cexp le; kill tf)	def tf; cexp le; kill tf)
376
377	| F.TAPP (F.VAR tf,tycs) => uncall tf	| F.TAPP (F.VAR tf,tycs) => uncall tf
#	Line 416	Line 386
386	arms)	arms)
387
388	| F.CON (dc,_,v,lv,le) =>	| F.CON (dc,_,v,lv,le) =>
389	(cdcon dc; if used lv then unuse v else ();	(cdcon dc; if used(get lv) then unuse v else ();
390	def lv; cexp le; kill lv)	def lv; cexp le; kill lv)
391
392	| F.RECORD (_,vs,lv,le) =>	| F.RECORD (_,vs,lv,le) =>
393	(if used lv then app unuse vs else ();	(if used(get lv) then app unuse vs else ();
394	def lv; cexp le; kill lv)	def lv; cexp le; kill lv)
395
396	| F.SELECT (v,_,lv,le) =>	| F.SELECT (v,_,lv,le) =>
397	(if used lv then unuse v else ();	(if used(get lv) then unuse v else ();
398	def lv; cexp le; kill lv)	def lv; cexp le; kill lv)
399
400	| F.RAISE (v,_) => unuse v	| F.RAISE (v,_) => unuse v
#	Line 434	Line 404
404	(app unuse vs; cpo po; cexp le1; cexp le2)	(app unuse vs; cpo po; cexp le1; cexp le2)
405
406	| F.PRIMOP (po,vs,lv,le) =>	| F.PRIMOP (po,vs,lv,le) =>
407	(if impurePO po orelse used lv then (cpo po; app unuse vs) else ();	(if impurePO po orelse used(get lv) then
408		(cpo po; app unuse vs)
409		else ();
410	def lv; cexp le; kill lv)	def lv; cexp le; kill lv)
411
412	| le => buglexp("unexpected lexp", le)	| le => buglexp("unexpected lexp", le)) handle x => raise x
413	in	in
414	(cexp, cfun)	(cexp, cfun)
415	end	end
416
417	fun uselexp le =	val uselexp = census All
	let fun new' call (lv,alpha) = (new call lv; (lv,alpha))
	fun use' call alpha lv = (use call lv; lv)
	in census new' use' () All le
	end
	(*  fun uselexp le = (uselexp' le; ()) *)
418	fun copylexp alpha le =	fun copylexp alpha le =
419	let fun new' call (lv,alpha) =	let val nle = FU.copy alpha le
420	let val nlv = cplv lv	in uselexp nle; nle
	in new call nlv; (nlv, FM.add(alpha, lv, nlv))
	end
	fun use' call alpha lv =
	let val nlv = (FM.lookup alpha lv) handle FM.IntmapF => lv
	in use call nlv; nlv
	end
	in census new' use' alpha All le
421	end	end
422
423	fun collect (fdec as (_,f,_,_)) =	fun collect (fdec as (_,f,_,_)) =
424	let val _ = M.clear m               (* start from a fresh state *)	((*  say "Entering Collect...\n"; *)
425	val nle = uselexp (F.FIX([fdec], F.RET[F.VAR f]))	M.clear m;                         (* start from a fresh state *)
426	in case nle of	PP.LVarString := LVarString;
427	F.FIX([nfdec], F.RET[F.VAR g]) => (ASSERT(f = g, "f = g"); nfdec)	uselexp (F.FIX([fdec], F.RET[F.VAR f]));
428	| _ => bug "not an fdec anymore"	(*  say "...Collect Done.\n"; *)
429	end	fdec)
430
431	end	end
432	end	end

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.185   changed lines   Added in v.186

---

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