Diff of /sml/trunk/src/compiler/FLINT/opt/fcontract.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 5	Line 5
5	sig	sig
6
7	(* needs Collect to be setup properly *)	(* needs Collect to be setup properly *)
8	val contract : FLINT.fundec -> FLINT.fundec	val contract : FLINT.fundec * Stats.counter -> FLINT.fundec
9
10	end	end
11
#	Line 197	Line 197
197	= Val    of F.value                   (* F.value should never be F.VAR lv *)	= Val    of F.value                   (* F.value should never be F.VAR lv *)
198	| 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
199	| 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
200	| Record of F.lvar * F.value list	| Record of F.lvar * sval list
201	| Con    of F.lvar * F.value * F.dcon * F.tyc list	| Con    of F.lvar * sval * F.dcon * F.tyc list
202	| Decon  of F.lvar * F.value * F.dcon * F.tyc list	| Decon  of F.lvar * sval * F.dcon * F.tyc list
203	| Select of F.lvar * F.value * int	| Select of F.lvar * sval * int
204	| Var    of F.lvar * F.lty option     (* cop out case *)	| Var    of F.lvar * F.lty option     (* cop out case *)
205
206	fun sval2lty (Var(_,x)) = x	fun sval2lty (Var(_,x)) = x
#	Line 213	Line 213
213	LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)	LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
214	| tycs_eq _ = false	| tycs_eq _ = false
215
216	fun contract (fdec as (_,f,_,_)) = let	fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)
217
218	val inlineWitness = ref false	(*  val c_inline         = Stats.newCounter[] *)
219		(*  val c_deadval        = Stats.newCounter[] *)
220		(*  val c_deadlexp       = Stats.newCounter[] *)
221		(*  val c_select         = Stats.newCounter[] *)
222		(*  val c_record         = Stats.newCounter[] *)
223		(*  val c_lacktype       = Stats.newCounter[] *)
224		(*  val c_con    = Stats.newCounter[] *)
225		(*  val c_switch         = Stats.newCounter[] *)
226		(*  val c_eta    = Stats.newCounter[] *)
227		(*  val c_etasplit       = Stats.newCounter[] *)
228		(*  val c_branch         = Stats.newCounter[] *)
229		(*  val c_cstargs        = Stats.newCounter[] *)
230		(*  val c_dropargs       = Stats.newCounter[] *)
231
232		fun contract (fdec as (_,f,_,_), counter) = let
233
234		val c_dummy = Stats.newCounter[]
235		val c_miss = Stats.newCounter[]
236
237		fun click_deadval  () = (click "d" counter)
238		fun click_deadlexp () = (click "D" counter)
239		fun click_select   () = (click "s" counter)
240		fun click_record   () = (click "r" counter)
241		fun click_con      () = (click "c" counter)
242		fun click_switch   () = (click "s" counter)
243		fun click_eta      () = (click "e" counter)
244		fun click_etasplit () = (click "E" counter)
245		fun click_branch   () = (click "b" counter)
246		fun click_cstargs  () = (click "A" counter)
247		fun click_dropargs () = (click "a" counter)
248
249		fun click_lacktype () = (click "t" c_miss)
250
251		(* this counters is actually *used* by fcontract.
252		* It's  not used just for statistics. *)
253		val c_inline         = Stats.newCounter[counter]
254		(*      val c_inline1    = Stats.newCounter[c_inline] *)
255		(*      val c_inline2    = Stats.newCounter[c_inline] *)
256		(*      val c_unroll     = Stats.newCounter[c_inline] *)
257		fun click_simpleinline () = (click "i" c_inline)
258		fun click_copyinline   () = (click "I" c_inline)
259		fun click_unroll       () = (click "u" c_inline)
260		fun inline_count () = Stats.getCounter c_inline
261
262	(* cfg: is used for deBruijn renumbering when inlining at different depths	(* cfg: is used for deBruijn renumbering when inlining at different depths
263	* ifs (inlined functions): records which functions we're currently inlining	* ifs (inlined functions): records which functions we're currently inlining
#	Line 253	Line 295
295	| Val v => v	| Val v => v
296
297	fun val2sval m (F.VAR ov) =	fun val2sval m (F.VAR ov) =
298	((lookup m ov) handle x => ((*  PP.printSval(F.VAR ov); *) raise x))	((lookup m ov) handle x =>
299		(say("val2sval "^(C.LVarString ov)^"\n"); raise x))
300	| val2sval m v = Val v	| val2sval m v = Val v
301
302	fun bugsv (msg,sv) = bugval(msg, sval2val sv)	fun bugsv (msg,sv) = bugval(msg, sval2val sv)
#	Line 279	Line 322
322	le))	le))
323	| TFun{1=lv,2=le,...} =>	| TFun{1=lv,2=le,...} =>
324	C.unuselexp undertake le	C.unuselexp undertake le
325	| (Select {2=v,...} | Con {2=v,...}) => unuseval m v	| (Select {2=sv,...} | Con {2=sv,...}) => unusesval m sv
326	| Record {2=vs,...} => app (unuseval m) vs	| Record {2=svs,...} => app (unusesval m) svs
327	(* decon's are implicit so we can't get rid of them *)	(* decon's are implicit so we can't get rid of them *)
328	| Decon _ => ()	| Decon _ => ()
329	end	end
#	Line 289	Line 332
332	| x =>	| x =>
333	(say("while undertaking "^(C.LVarString lv)^"\n"); raise x)	(say("while undertaking "^(C.LVarString lv)^"\n"); raise x)
334
335		and unusesval m sv = unuseval m (sval2val sv)
336	and unuseval m (F.VAR lv) =	and unuseval m (F.VAR lv) =
337	if (C.unuse false (C.get lv)) then undertake m lv else ()	if (C.unuse false (C.get lv)) then undertake m lv else ()
338	| unuseval f _ = ()	| unuseval f _ = ()
#	Line 343	Line 387
387	* and kill only the function name.  This inlining strategy	* and kill only the function name.  This inlining strategy
388	* looks inoffensive enough, but still requires some care:	* looks inoffensive enough, but still requires some care:
389	* see comments at the begining of this file and in cfun *)	* see comments at the begining of this file and in cfun *)
390	(inlineWitness := true;	(click_simpleinline();
391	ignore(C.unuse true (C.get g));	ignore(C.unuse true (C.get g));
392	ASSERT(not (used g), "killed");	ASSERT(not (used g), "killed");
393	(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))	(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
#	Line 360	Line 404
404	let val nle =	let val nle =
405	C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))	C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
406	in	in
	inlineWitness := true;
407	(*  say ("\nInlining "^(C.LVarString g)); *)	(*  say ("\nInlining "^(C.LVarString g)); *)
408	(app (unuseval m) vs) handle x => raise x;	(app (unuseval m) vs) handle x => raise x;
409	unusecall m g;	unusecall m g;
410	(SOME(nle, od),	(SOME(nle, od),
411	(* gross hack: to prevent further unrolling,	(* gross hack: to prevent further unrolling,
412	* I pretend that the rest is not inside the body *)	* I pretend that the rest is not inside the body *)
413	if inline = F.IH_UNROLL then S.rmv(g, ifs) else S.add(g, ifs))	if inline = F.IH_UNROLL
414		then (click_unroll(); S.rmv(g, ifs))
415		else (click_copyinline(); S.add(g, ifs)))
416	end	end
417	else (NONE, ifs))	else (NONE, ifs))
418	| sv => (NONE, ifs)	| sv => (NONE, ifs)
#	Line 417	Line 462
462	body	body
463	val nle2 = F.LET([nlv], le2, body2)	val nle2 = F.LET([nlv], le2, body2)
464	in	in
465		click_branch();
466	loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont	loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont
467	end	end
468	else	else
#	Line 432	Line 478
478	end	end
479
480	| F.FIX (fs,le) =>	| F.FIX (fs,le) =>
481	let (* register dump bindings *)	let (* The actual function contraction *)
	val m = foldl (fn (fdec as (_,f,_,_),m) =>
	addbind(m, f, Var(f,NONE)))
	m fs
	(* The actual function contraction *)
482	fun cfun (m,[]:F.fundec list,acc) = acc	fun cfun (m,[]:F.fundec list,acc) = acc
483	| cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =	| cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
484	if used f then	let val fi = C.get f
485		in if C.dead fi then cfun(m, fs, acc)
486		else if C.iusenb fi = C.usenb fi then
487		(* we need to be careful that undertake not be called
488		* recursively *)
489		(C.use NONE fi; undertake m f; cfun(m, fs, acc))
490		else
491	let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)	let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
492	val oldWitness =	val saved_ic = inline_count()
	(!inlineWitness before inlineWitness := false)
493	(* make up the bindings for args inside the body *)	(* make up the bindings for args inside the body *)
494	fun addnobind ((lv,lty),m) =	fun addnobind ((lv,lty),m) =
495	addbind(m, lv, Var(lv, SOME lty))	addbind(m, lv, Var(lv, SOME lty))
#	Line 454	Line 500
500	* changed (read: bigger), so we have to reset the	* changed (read: bigger), so we have to reset the
501	* `inline' bit *)	* `inline' bit *)
502	val nfk = {isrec=isrec, cconv=cconv,	val nfk = {isrec=isrec, cconv=cconv,
503	known=known orelse not(C.escaping(C.get f))handle x => raise x,	known=known orelse not(C.escaping fi),
504	inline=if !inlineWitness	inline=if inline_count() = saved_ic
505	then F.IH_SAFE	then inline
506	else (inline before	else F.IH_SAFE}
	inlineWitness := oldWitness)}
507	(* update the binding in the map.  This step is not	(* update the binding in the map.  This step is not
508	* not just a mere optimization but is necessary	* not just a mere optimization but is necessary
509	* because if we don't do it and the function	* because if we don't do it and the function
#	Line 469	Line 514
514	in cfun(nm, fs, (nfk, f, args, nbody)::acc)	in cfun(nm, fs, (nfk, f, args, nbody)::acc)
515	(*  before say ("\nExiting "^(C.LVarString f)) *)	(*  before say ("\nExiting "^(C.LVarString f)) *)
516	end	end
517	else cfun(m, fs, acc)	end
518
519	(* check for eta redex *)	(* check for eta redex *)
520	fun ceta (fdec as (fk,f,args,F.APP(g,vs)):F.fundec,(m,fs,hs)) =	fun ceta (fdec as (fk,f,args,F.APP(g,vs)):F.fundec,(m,fs,hs)) =
#	Line 486	Line 531
531	* escaping one.  It's dangerous for optimisations based	* escaping one.  It's dangerous for optimisations based
532	* on known functions (elimination of dead args, f.ex)	* on known functions (elimination of dead args, f.ex)
533	* and could generate cases where call>use in collect *)	* and could generate cases where call>use in collect *)
534	in if not (((C.escaping(C.get f))handle x => raise x) andalso not (C.escaping(C.get g))handle x => raise x)	in if (C.escaping(C.get f)) andalso not(C.escaping(C.get g))
535	then let	(* the default case could ensure the inline *)
536		then (m, fdec::fs, hs)
537		else let
538	(* if an earlier function h has been eta-reduced	(* if an earlier function h has been eta-reduced
539	* to f, we have to be careful to update its	* to f, we have to be careful to update its
540	* binding to not refer to f any more since f	* binding to not refer to f any more since f
#	Line 499	Line 546
546	in	in
547	(* I could almost reuse `substitute' but the	(* I could almost reuse `substitute' but the
548	* unuse in substitute assumes the val is escaping *)	* unuse in substitute assumes the val is escaping *)
549		click_eta();
550	C.transfer(f, g);	C.transfer(f, g);
551	unusecall m g;	unusecall m g;
552	(addbind(m, f, svg), fs, f::hs)	(addbind(m, f, svg), fs, f::hs)
553	end	end
	(* the default case could ensure the inline *)
	else (m, fdec::fs, hs)
554	end	end
555	else (m, fdec::fs, hs)	else (m, fdec::fs, hs)
556	| ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)	| ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
#	Line 516	Line 562
562	val cst =	val cst =
563	ListPair.map	ListPair.map
564	(fn (NONE,_) => false	(fn (NONE,_) => false
565	| (SOME v,(a,_)) =>	| (SOME(F.VAR lv),(a,_)) =>
566	((case substval v	((case sval2val(lookup m lv)
567	of F.VAR lv =>	of F.VAR lv =>
568	if used a andalso used lv then	if used a andalso used lv then
569	(C.use NONE (C.get lv); true)	(C.use NONE (C.get lv); true)
570	else false	else false
571	| _ => false)	| _ => true)
572	handle M.IntmapF => false))	handle M.IntmapF => false)
573		| (SOME v,(a,_)) => true)
574	(actuals, args)	(actuals, args)
575	(* if all args are used, there's nothing we can do *)	(* if all args are used, there's nothing we can do *)
576	in if List.all not cst then f else	in if List.all not cst then f else
#	Line 540	Line 587
587	F.LET(map #1 (filter args),	F.LET(map #1 (filter args),
588	F.RET(map O.valOf (filter actuals)),	F.RET(map O.valOf (filter actuals)),
589	body)	body)
590	in (fk, g, nargs, nbody)	in click_cstargs();
591		(fk, g, nargs, nbody)
592	end	end
593	end	end
594
595	(* add wrapper for various purposes *)	(* add wrapper for various purposes *)
596	fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs	fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
597	| wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =	| wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
598	let fun dropargs filter =	let val gi = C.get g
599		fun dropargs filter =
600	let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)	let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
601	val args' = filter args	val args' = filter args
602	val ng = cplv g	val ng = cplv g
#	Line 558	Line 607
607	val nf' = (nfk', ng, args', body)	val nf' = (nfk', ng, args', body)
608
609	val ngi = C.new (SOME(map #1 args')) ng	val ngi = C.new (SOME(map #1 args')) ng
	val nargsi = map ((C.new NONE) o #1) nargs
610	in	in
611		C.ireset gi;
612		app (ignore o (C.new NONE) o #1) nargs;
613	C.use (SOME appargs) ngi;	C.use (SOME appargs) ngi;
614	app (C.use NONE) nargsi;	app (C.use NONE o C.get) nargs';
615	nf'::nf::fs	nf'::nf::fs
616	end	end
617	val used = map (used o #1) args	val used = map (used o #1) args
618	in	in
619		(* Don't introduce wrappers for escaping-only functions.
620		* This is debatable since although wrappers are useless
621		* on escaping-only functions, some of the escaping uses
622		* might turn into calls in the course of fcontract, so
623		* by not introducing wrappers here, we avoid useless work
624		* but we also postpone useful work to later invocations. *)
625		if C.called gi then
626	(* if some args are not used, let's drop them *)	(* if some args are not used, let's drop them *)
627	if not (List.all OU.id used) then	if not (List.all OU.id used) then
628	dropargs (fn xs => OU.filter(used, xs))	(click_dropargs();
629		dropargs (fn xs => OU.filter(used, xs)))
630
631	(* eta-split: add a wrapper for escaping uses *)	(* eta-split: add a wrapper for escaping uses *)
632	else	else if C.escaping gi then
	let val gi = C.get g
	in if ((C.escaping gi)handle x => raise x) andalso ((C.called gi)handle x => raise x) then
633	(* like dropargs but keeping all args *)	(* like dropargs but keeping all args *)
634	dropargs OU.id	(click_etasplit(); dropargs OU.id)
635
636	else f::fs	else f::fs
637	end	else f::fs
638	end	end
639
640	(* junk unused funs *)	(* junk unused funs *)
641	val fs = List.filter (used o #2) fs	val fs = List.filter (fn (_,f,_,_) =>
642		used f orelse (click_deadlexp(); false))
643		fs
644
645	(* redirect cst args to their source value *)	(* redirect cst args to their source value *)
646	val fs = map cstargs fs	val fs = map cstargs fs
#	Line 628	Line 686
686	end	end
687
688	| F.TFN ((f,args,body),le) =>	| F.TFN ((f,args,body),le) =>
689	if used f then	let val fi = C.get f
690		in if C.dead fi then (click_deadlexp(); loop m le cont) else
691	let val nbody = cexp (DI.next d, DI.next od) ifs m body #2	let val nbody = cexp (DI.next d, DI.next od) ifs m body #2
692	val nm = addbind(m, f, TFun(f, nbody, args, od))	val nm = addbind(m, f, TFun(f, nbody, args, od))
693	val nle = loop nm le cont	val nle = loop nm le cont
694	in	in
695	if used f then F.TFN((f, args, nbody), nle) else nle	if C.dead fi then nle else F.TFN((f, args, nbody), nle)
696		end
697	end	end
	else loop m le cont
698
699	| F.TAPP(f,tycs) =>	| F.TAPP(f,tycs) =>
700		(* (case val2sval m f
701		of TFun(g,body,args,od) =>
702		if d = od andalso C.usenb(C.get g) = 1 then
703		let val (_,_,_,le) =
704		({inline=false,isrec=NONE,known=false,cconv=F.CC_FCT},
705		LV.mkLvar(),[],
706		F.TFN((g,args,body),TAPP(g,tycs)))
707		in
708		inlineWitness := true;
709		ignore(C.unuse true (C.get g));
710		end *)
711	cont(m, F.TAPP((substval f) handle x => raise x, tycs))	cont(m, F.TAPP((substval f) handle x => raise x, tycs))
712
713	| F.SWITCH (v,ac,arms,def) =>	| F.SWITCH (v,ac,arms,def) =>
714	(case ((val2sval m v) handle x => raise x)	(case ((val2sval m v) handle x => raise x)
715	of sv as Con (lvc,v,dc1,tycs1) =>	of sv as Con (lvc,svc,dc1,tycs1) =>
716	let fun killle le = C.unuselexp (undertake m) le	let fun killle le = C.unuselexp (undertake m) le
717	fun kill lv le =	fun kill lv le =
718	C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le	C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le
#	Line 655	Line 725
725	if #2 dc1 = #2 (cdcon dc2) then	if #2 dc1 = #2 (cdcon dc2) then
726	(map killarm tl; (* kill the rest *)	(map killarm tl; (* kill the rest *)
727	O.map killle def; (* and the default case *)	O.map killle def; (* and the default case *)
728	loop (substitute(m, lv, val2sval m v, F.VAR lvc))	loop (substitute(m, lv, svc, F.VAR lvc))
729	le cont)	le cont)
730	else	else
731	(* kill this arm and continue with the rest *)	(* kill this arm and continue with the rest *)
732	(kill lv le; carm tl)	(kill lv le; carm tl)
733	| carm [] = loop m (O.valOf def) cont	| carm [] = loop m (O.valOf def) cont
734	| carm _ = buglexp("unexpected arm in switch(con,...)", le)	| carm _ = buglexp("unexpected arm in switch(con,...)", le)
735	in carm arms	in click_switch(); carm arms
736	end	end
737
738	| sv as Val v =>	| sv as Val v =>
#	Line 674	Line 744
744	loop m le cont)	loop m le cont)
745	else (kill le; carm tl)	else (kill le; carm tl)
746	| carm [] = loop m (O.valOf def) cont	| carm [] = loop m (O.valOf def) cont
747	in carm arms	in click_switch(); carm arms
748	end	end
749
750	| sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}	| sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
#	Line 684	Line 754
754	(* this is a mere DECON, so we can push the let binding	(* this is a mere DECON, so we can push the let binding
755	* (hidden in cont) inside and maybe even drop the DECON *)	* (hidden in cont) inside and maybe even drop the DECON *)
756	let val ndc = cdcon dc	let val ndc = cdcon dc
757	val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs))	val slv = Decon(lv, sv, ndc, tycs)
758		val nm = addbind(m, lv, slv)
759	(* see below *)	(* see below *)
760	val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))	val nm = addbind(nm, lvc, Con(lvc, slv, ndc, tycs))
761	val nle = loop nm le cont	val nle = loop nm le cont
762	val nv = sval2val sv	val nv = sval2val sv
763	in	in
#	Line 700	Line 771
771	| _ =>	| _ =>
772	let fun carm (F.DATAcon(dc,tycs,lv),le) =	let fun carm (F.DATAcon(dc,tycs,lv),le) =
773	let val ndc = cdcon dc	let val ndc = cdcon dc
774	val nm = addbind(m, lv,	val slv = Decon(lv, sv, ndc, tycs)
775	Decon(lv, F.VAR lvc, ndc, tycs))	val nm = addbind(m, lv, slv)
776	(* we can rebind lv to a more precise value	(* we can rebind lv to a more precise value
777	* !!BEWARE!!  This rebinding is misleading:	* !!BEWARE!!  This rebinding is misleading:
778	* - it gives the impression that `lvc' is built	* - it gives the impression that `lvc' is built
#	Line 715	Line 786
786	* - it seems to be a good idea, but it can hide	* - it seems to be a good idea, but it can hide
787	*   other opt-opportunities since it hides the	*   other opt-opportunities since it hides the
788	*   previous binding. *)	*   previous binding. *)
789	val nm = addbind(nm, lvc,	val nm = addbind(nm, lvc, Con(lvc,slv,ndc,tycs))
	Con(lvc, F.VAR lv, ndc, tycs))
790	in (F.DATAcon(ndc, tycs, lv), loop nm le #2)	in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
791	end	end
792	| carm (con,le) = (con, loop m le #2)	| carm (con,le) = (con, loop m le #2)
#	Line 729	Line 799
799	bugval("unexpected switch arg", sval2val sv))	bugval("unexpected switch arg", sval2val sv))
800
801	| F.CON (dc1,tycs1,v,lv,le) =>	| F.CON (dc1,tycs1,v,lv,le) =>
802	if used lv then	let val lvi = C.get lv
803		in if C.dead lvi then (click_deadval(); loop m le cont) else
804	let val ndc = cdcon dc1	let val ndc = cdcon dc1
805	fun ccon sv =	fun ccon sv =
806	let val nv = sval2val sv	let val nm = addbind(m, lv, Con(lv, sv, ndc, tycs1))
	val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))
807	val nle = loop nm le cont	val nle = loop nm le cont
808	in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle	in if C.dead lvi then nle
809		else F.CON(ndc, tycs1, sval2val sv, lv, nle)
810	end	end
811	in case ((val2sval m v) handle x => raise x)	in case ((val2sval m v) handle x => raise x)
812	of sv as (Decon (lvd,vc,dc2,tycs2)) =>	of sv as (Decon (lvd,sv',dc2,tycs2)) =>
813	if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then	if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
814	let val sv = (val2sval m vc) handle x => raise x	(click_con();
815	in loop (substitute(m, lv, sv, F.VAR lvd)) le cont	loop (substitute(m, lv, sv', F.VAR lvd)) le cont)
	end
816	else ccon sv	else ccon sv
817	| sv => ccon sv	| sv => ccon sv
818	end	end
819	else loop m le cont	end
820
821	| F.RECORD (rk,vs,lv,le) =>	| F.RECORD (rk,vs,lv,le) =>
822	(* g: check whether the record already exists *)	(* g: check whether the record already exists *)
823	if used lv then	let val lvi = C.get lv
824	let fun g (n,Select(_,v1,i)::ss) =	in if C.dead lvi then (click_deadval(); loop m le cont) else
825	if n = i then	let fun g (Select(_,sv,0)::ss) =
826	(case ss	let fun g' (n,Select(_,sv',i)::ss) =
827	of Select(_,v2,_)::_ =>	if n = i andalso (sval2val sv) = (sval2val sv')
828	if v1 = v2 then g(n+1, ss) else NONE	then g'(n+1,ss) else NONE
829	| [] =>	| g' (n,[]) =
830	(case sval2lty (val2sval m v1)	(case sval2lty sv
831	of SOME lty =>	of SOME lty =>
832	let val ltd = case rk	let val ltd = case rk
833	of F.RK_STRUCT => LT.ltd_str	of F.RK_STRUCT => LT.ltd_str
834	| F.RK_TUPLE _ => LT.ltd_tuple	| F.RK_TUPLE _ => LT.ltd_tuple
835	| _ => buglexp("bogus rk",le)	| _ => buglexp("bogus rk",le)
836	in if length(ltd lty) = n+1	in if length(ltd lty) = n
837	then SOME v1 else NONE	then SOME sv else NONE
838		end
839		| _ => (click_lacktype(); NONE)) (* sad *)
840		| g' _ = NONE
841		in g'(1,ss)
842	end	end
	| _ => NONE) (* sad case *)
	| _ => NONE)
	else NONE
843	| g _ = NONE	| g _ = NONE
844	val svs = ((map (val2sval m) vs) handle x => raise x)	val svs = ((map (val2sval m) vs) handle x => raise x)
845	in case g (0,svs)	in case g svs
846	of SOME v =>	of SOME sv => (click_record();
847	let val sv = (val2sval m v) handle x => raise x	loop (substitute(m, lv, sv, F.INT 0)) le cont
848	in loop (substitute(m, lv, sv, F.INT 0)) le cont	before app (unuseval m) vs)
	before app (unuseval m) vs
	end
849	| _ =>	| _ =>
850	let val nvs = map sval2val svs	let val nm = addbind(m, lv, Record(lv, svs))
	val nm = addbind(m, lv, Record(lv, nvs))
851	val nle = loop nm le cont	val nle = loop nm le cont
852	in if used lv then F.RECORD(rk, nvs, lv, nle) else nle	in if C.dead lvi then nle
853		else F.RECORD(rk, map sval2val svs, lv, nle)
854		end
855	end	end
856	end	end
	else loop m le cont
857
858	| F.SELECT (v,i,lv,le) =>	| F.SELECT (v,i,lv,le) =>
859	if used lv then	let val lvi = C.get lv
860		in if C.dead lvi then (click_deadval(); loop m le cont) else
861	(case ((val2sval m v) handle x => raise x)	(case ((val2sval m v) handle x => raise x)
862	of Record (lvr,vs) =>	of Record (lvr,svs) =>
863	let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x	let val sv = List.nth(svs, i)
864	in loop (substitute(m, lv, sv, F.VAR lvr)) le cont	in click_select();
865		loop (substitute(m, lv, sv, F.VAR lvr)) le cont
866	end	end
867	| sv =>	| sv =>
868	let val nv = sval2val sv	let val nm = addbind (m, lv, Select(lv, sv, i))
	val nm = addbind (m, lv, Select(lv, nv, i))
869	val nle = loop nm le cont	val nle = loop nm le cont
870	in if used lv then F.SELECT(nv, i, lv, nle) else nle	in if C.dead lvi then nle
871		else F.SELECT(sval2val sv, i, lv, nle)
872	end)	end)
873	else loop m le cont	end
874
875	| F.RAISE (v,ltys) =>	| F.RAISE (v,ltys) =>
876	cont(m, F.RAISE((substval v) handle x => raise x, ltys))	cont(m, F.RAISE((substval v) handle x => raise x, ltys))
#	Line 816	Line 887
887	end	end
888
889	| F.PRIMOP (po,vs,lv,le) =>	| F.PRIMOP (po,vs,lv,le) =>
890	let val impure = impurePO po	let val lvi = C.get lv
891	in if impure orelse used lv then	val pure = not(impurePO po)
892		in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else
893	let val nvs = ((map substval vs) handle x => raise x)	let val nvs = ((map substval vs) handle x => raise x)
894	val npo = cpo po	val npo = cpo po
895	val nm = addbind(m, lv, Var(lv,NONE))	val nm = addbind(m, lv, Var(lv,NONE))
896	val nle = loop nm le cont	val nle = loop nm le cont
897	in	in
898	if impure orelse used lv	if pure andalso C.dead lvi then nle
899	then F.PRIMOP(npo, nvs, lv, nle)	else F.PRIMOP(npo, nvs, lv, nle)
	else nle
900	end	end
	else loop m le cont
901	end	end
902	end	end
903

---

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