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

Parent Directory | Revision Log | Patch

	revision 62, Tue Mar 31 05:13:22 1998 UTC	revision 63, Tue Mar 31 05:26:42 1998 UTC
#	Line 19	Line 19
19	(* things that lcontract did that fcontract doesn't do (yet):	(* things that lcontract did that fcontract doesn't do (yet):
20	*	*
21	* - inline across DeBruijn depths	* - inline across DeBruijn depths
22	* - switch(con) concellation	* - elimination of let [dead-vs] = pure in body
23	* - elimination of let [dead-vs] = pure in body *)	*)
24
25	structure FContract :> FCONTRACT =	structure FContract :> FCONTRACT =
26	struct	struct
#	Line 44	Line 44
44
45	datatype sval	datatype sval
46	= Val    of F.value	= Val    of F.value
	| Var    of F.lvar
47	| Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth	| Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth
48	| TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth	| TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
49	| Record of F.lvar * F.value list	| Record of F.lvar * F.value list
#	Line 62	Line 61
61
62	fun impurePO po = true              (* if a PrimOP is pure or not *)	fun impurePO po = true              (* if a PrimOP is pure or not *)
63
64		fun eqConV (F.INTcon i1,    F.INT i2)       = i1 = i2
65		| eqConV (F.INT32con i1,  F.INT32 i2)     = i1 = i2
66		| eqConV (F.WORDcon i1,   F.WORD i2)      = i1 = i2
67		| eqConV (F.WORD32con i1, F.WORD32 i2)    = i1 = i2
68		| eqConV (F.REALcon r1,   F.REAL r2)      = r1 = r2
69		| eqConV (F.STRINGcon s1, F.STRING s2)    = s1 = s2
70		| eqConV (con,v) = bugval("unexpected comparison with val", v)
71
72	fun lookup lv = M.map m lv	fun lookup lv = M.map m lv
73	(*                      handle e as NotFound => *)	(*                      handle e as NotFound => *)
74	(*                      (say (concat ["\nlooking up unbound ", *)	(*                      (say (concat ["\nlooking up unbound ", *)
#	Line 70	Line 77
77
78	fun sval2val sv =	fun sval2val sv =
79	case sv	case sv
80	of (Var lv | Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}	of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}
81	| Select{1=lv,...} | Con{1=lv,...} | Val (F.VAR lv)) => F.VAR lv	| Select{1=lv,...} | Con{1=lv,...}) => F.VAR lv
82	| Val v => v	| Val v => v
83
84	fun val2sval (F.VAR ov) = ((lookup ov) handle x => raise x)	fun val2sval (F.VAR ov) = lookup ov
85	| val2sval v = Val v	| val2sval v = Val v
86
87	fun bugsv (msg,sv) = bugval(msg, sval2val sv)	fun bugsv (msg,sv) = bugval(msg, sval2val sv)
#	Line 92	Line 99
99	(* called when a variable becomes dead.	(* called when a variable becomes dead.
100	* it simply adjusts the use-counts *)	* it simply adjusts the use-counts *)
101	fun undertake lv =	fun undertake lv =
102	(case lookup lv	case lookup lv
103	of Val v               => unuseval undertake v	of Val (F.VAR nlv)     => ASSERT(nlv = lv, "nlv = lv")
104	| Var nlv             => ASSERT(nlv = lv, "nlv = lv")	| Val v               => unuseval undertake v
105	| ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) =>	| ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) =>
106	C.inside lv (fn()=> C.unuselexp undertake le)	C.inside lv (fn()=> C.unuselexp undertake le)
107	| ( Select {2=v,...} | Con {2=v,...} ) =>	| ( Select {2=v,...} | Con {2=v,...} ) =>
108	unuseval undertake v	unuseval undertake v
109	| Record {2=vs,...}   => app (unuseval undertake) vs)	| Record {2=vs,...}   => app (unuseval undertake) vs
	handle x =>
	(say "while undertaking "; PP.printSval(F.VAR lv); say "\n";
	raise x)
110
111	fun addbind (lv,sv) =	fun addbind (lv,sv) =
112	let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2)	let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2)
#	Line 119	Line 123
123	fun substitute (lv1, sv, v) =	fun substitute (lv1, sv, v) =
124	(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();	(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
125	unuseval undertake v;	unuseval undertake v;
126	addbind (lv1, sv)) handle x => raise x	addbind (lv1, sv))
127
128	(* common code for all the lexps "let v = <op>[v1,...] in ..." *)	(* common code for all the lexps "let v = <op>[v1,...] in ..." *)
129	fun clet1 (svcon,lecon) (lv,vs,le) =	fun clet1 (svcon,lecon) (lv,vs,le) =
#	Line 144	Line 148
148
149	in	in
150	case le	case le
151	of F.RET vs => (F.RET (map substval vs) handle x => raise x)	of F.RET vs => F.RET(map substval vs)
152
153	| F.LET (lvs,le,body) =>	| F.LET (lvs,le,body) =>
154	(let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)	let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)
155	(* let associativity	(* let associativity
156	* !!BEWARE!! applying the associativity rule might	* !!BEWARE!! applying the associativity rule might
157	* change the liveness of the bound variables *)	* change the liveness of the bound variables *)
#	Line 190	Line 194
194	(ListPair.zip(lvs, vs));	(ListPair.zip(lvs, vs));
195	loop body)	loop body)
196	| clet le =	| clet le =
197	(app (fn lv => addbind (lv, Var lv)) lvs;	(app (fn lv => addbind (lv, Val(F.VAR lv))) lvs;
198	case loop body	case loop body
199	of F.RET vs => if vs = (map F.VAR lvs) then le	of F.RET vs => if vs = (map F.VAR lvs) then le
200	else F.LET(lvs, le, F.RET vs)	else F.LET(lvs, le, F.RET vs)
201	| nbody => F.LET(lvs, le, nbody))	| nbody => F.LET(lvs, le, nbody))
202	in	in
203	clet (loop le)	clet (loop le)
204	end handle x => raise x)	end
205
206	| F.FIX (fs,le) =>	| F.FIX (fs,le) =>
207	(let fun cfun [] acc = rev acc	let fun cfun [] acc = rev acc
208	| cfun (fdec as (fk,f,args,body)::fs) acc =	| cfun (fdec as (fk,f,args,body)::fs) acc =
209	if used f then	if used f then
210	let (* make up the bindings for args inside the body *)	let (* make up the bindings for args inside the body *)
211	val _ = app (fn lv => addbind (lv, Var lv))	val _ = app (fn lv => addbind (lv, Val(F.VAR lv)))
212	(map #1 args)	(map #1 args)
213	(* contract the body and create the resulting fundec *)	(* contract the body and create the resulting fundec *)
214	val nbody = C.inside f (fn()=> loop body)	val nbody = C.inside f (fn()=> loop body)
#	Line 238	Line 242
242	if List.null fs	if List.null fs
243	then nle	then nle
244	else F.FIX(fs,nle)	else F.FIX(fs,nle)
245	end handle x => raise x)	end
246
247	| F.APP (f,vs) =>	| F.APP (f,vs) =>
248	(let val nvs = map substval vs	let val nvs = map substval vs
249	in case val2sval f	in case val2sval f
250	of Fun(g,body,args,fk,od) =>	of Fun(g,body,args,fk,od) =>
251	(ASSERT(C.usenb g > 0, "C.usenb g > 0");	(ASSERT(C.usenb g > 0, "C.usenb g > 0");
#	Line 257	Line 261
261	else F.APP(F.VAR g, nvs))	else F.APP(F.VAR g, nvs))
262
263	| sv => F.APP(sval2val sv, nvs)	| sv => F.APP(sval2val sv, nvs)
264	end handle x => raise x)	end
265
266	| F.TFN ((f,args,body),le) =>	| F.TFN ((f,args,body),le) =>
267	((if used f then	if used f then
268	let (* val _ = addbind (f, TFun(f, body, args, od)) *)	let (* val _ = addbind (f, TFun(f, body, args, od)) *)
269	val nbody = cexp (DI.next d, DI.next od) body	val nbody = cexp (DI.next d, DI.next od) body
270	val _ = addbind (f, TFun(f, nbody, args, od))	val _ = addbind (f, TFun(f, nbody, args, od))
#	Line 270	Line 274
274	then F.TFN((f, args, nbody), nle)	then F.TFN((f, args, nbody), nle)
275	else nle	else nle
276	end	end
277	else loop le) handle x => raise x)	else loop le
278
279	| F.TAPP(f,tycs) => F.TAPP(substval f, tycs)	| F.TAPP(f,tycs) => F.TAPP(substval f, tycs)
280
281	| F.SWITCH (v,ac,arms,def) =>	| F.SWITCH (v,ac,arms,def) =>
282	(let val nv = substval v	(case val2sval v
283	fun carm (F.DATAcon(dc,tycs,lv),le) =	of sv as (Val(F.VAR lv) | Select(lv,_,_)) =>
284	(addbind(lv, Var lv);	(let fun carm (F.DATAcon(dc,tycs,lv),le) =
285		(addbind(lv, Val(F.VAR lv));
286	(F.DATAcon(cdcon dc, tycs, lv), loop le))	(F.DATAcon(cdcon dc, tycs, lv), loop le))
287	| carm (con,le) = (con, loop le)	| carm (con,le) = (con, loop le)
288	val narms = map carm arms	val narms = map carm arms
289	val ndef = Option.map loop def	val ndef = Option.map loop def
290	in	in
291	F.SWITCH(nv,ac,narms,ndef)	F.SWITCH(sval2val sv, ac, narms, ndef)
292	end handle x => raise x)	end handle x => raise x)
293
294		| Con (lvc,v,(_,conrep,_)) =>
295		let fun carm ((F.DATAcon((_,crep,_),tycs,lv),le)::tl) =
296		if crep = conrep then
297		(substitute(lv, val2sval v, F.VAR lvc);
298		loop le)
299		else carm tl
300		| carm [] = loop (Option.valOf def)
301		| carm _ = buglexp("unexpected arm in switch(con,...)", le)
302		in carm arms
303		end
304
305		| Val v =>
306		let fun carm ((con,le)::tl) =
307		if eqConV(con, v) then loop le else carm tl
308		| carm [] = loop(Option.valOf def)
309		in carm arms
310		end
311		| sv => bugval("unexpected switch argument", sval2val sv))
312
313	| F.CON (dc,tycs,v,lv,le) =>	| F.CON (dc,tycs,v,lv,le) =>
314	let val ndc = cdcon dc	let val ndc = cdcon dc
315	in clet1 (fn [nv] => Con(lv, nv, ndc),	in clet1 (fn [nv] => Con(lv, nv, ndc),
#	Line 319	Line 343
343	| F.HANDLE (le,v) => F.HANDLE(loop le, substval v)	| F.HANDLE (le,v) => F.HANDLE(loop le, substval v)
344
345	| F.BRANCH (po,vs,le1,le2) =>	| F.BRANCH (po,vs,le1,le2) =>
346	(let val nvs = map substval vs	let val nvs = map substval vs
347	val npo = cpo po	val npo = cpo po
348	val nle1 = loop le1	val nle1 = loop le1
349	val nle2 = loop le2	val nle2 = loop le2
350	in F.BRANCH(npo, nvs, nle1, le2)	in F.BRANCH(npo, nvs, nle1, le2)
351	end handle x => raise x)	end
352
353	| F.PRIMOP (po,vs,lv,le) =>	| F.PRIMOP (po,vs,lv,le) =>
354	(let val nvs = map substval vs	let val nvs = map substval vs
355	val npo = cpo po	val npo = cpo po
356	val _ = addbind(lv, Var lv)	val _ = addbind(lv, Val(F.VAR lv))
357	val nle = loop le	val nle = loop le
358	in if impurePO po orelse used lv	in if impurePO po orelse used lv
359	then F.PRIMOP(npo, nvs, lv, nle)	then F.PRIMOP(npo, nvs, lv, nle)
360	else nle	else nle
361	end handle x => raise x)	end
362
363	end handle x => raise x	end
364
365	fun contract (fdec as (_,f,_,_)) =	fun contract (fdec as (_,f,_,_)) =
366	let val _ = M.clear m	let val _ = M.clear m

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.62   changed lines   Added in v.63

---

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