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

Parent Directory | Revision Log | Patch

	revision 200, Sat Nov 28 17:48:03 1998 UTC	revision 201, Sat Nov 28 23:32:48 1998 UTC
#	Line 250	Line 250
250	in l le	in l le
251	end	end
252
253		(* `extract' extracts the code of a switch arm into a function
254		* and replaces it with a call to that function *)
255		fun extract (con,le) =
256		let val f = mklv()
257		val fk = {isrec=NONE,known=true,inline=F.IH_SAFE,
258		cconv=F.CC_FUN(LK.FF_FIXED)}
259		in case con of
260		F.DATAcon(dc as (_,_,lty),tycs,lv) =>
261		let val nlv = cplv lv
262		val _ = C.new (SOME[lv]) f
263		val _ = C.use NONE (C.new NONE nlv)
264		val (lty,_) = LT.ltd_parrow(hd(LT.lt_inst(lty, tycs)))
265		in ((F.DATAcon(dc, tycs, nlv),
266		F.APP(F.VAR f, [F.VAR nlv])),
267		(fk, f, [(lv, lty)], le))
268		end
269		| con =>
270		let val _ = C.new (SOME[]) f
271		in ((con, F.APP(F.VAR f, [])),
272		(fk, f, [], le))
273		end
274		end
275
276	fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)	fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)
277
278	(*  val c_inline         = Stats.newCounter[] *)	(*  val c_inline         = Stats.newCounter[] *)
#	Line 391	Line 414
414	(s, Access.EXN(Access.LVAR(substvar m lv)), lty)	(s, Access.EXN(Access.LVAR(substvar m lv)), lty)
415	| cdcon _ dc = dc	| cdcon _ dc = dc
416
417	(* cfg: is used for deBruijn renumbering when inlining at different depths	(* ifs (inlined functions): records which functions we're currently inlining
	* ifs (inlined functions): records which functions we're currently inlining
418	*     in order to detect loops	*     in order to detect loops
419	* m: is a map lvars to their defining expressions (svals) *)	* m: is a map lvars to their defining expressions (svals) *)
420	fun cexp ifs m le cont = let	fun fcexp ifs m le cont = let
421	val loop = cexp ifs	val loop = fcexp ifs
422	val substval = substval m	val substval = substval m
423	val cdcon = cdcon m	val cdcon = cdcon m
424	val cpo = cpo m	val cpo = cpo m
	in case le
	of F.RET vs => cont(m, F.RET(map substval vs))
425
426	| F.LET (lvs,le,body) =>	fun fcLet (lvs,le,body) =
427	let fun k (nm,nle) =	loop m le
428		(fn (nm,nle) =>
429	let fun cbody () =	let fun cbody () =
430	let val nm = (foldl (fn (lv,m) =>	let val nm = (foldl (fn (lv,m) =>
431	addbind(m, lv, Var(lv, NONE)))	addbind(m, lv, Var(lv, NONE)))
#	Line 423	Line 444
444	val nm = (ListPair.foldl simplesubst nm (lvs, vs))	val nm = (ListPair.foldl simplesubst nm (lvs, vs))
445	in loop nm body cont	in loop nm body cont
446	end	end
447	| _ => cbody()	| F.TAPP _ =>
448	end	if List.all (C.dead o C.get) lvs
449	fun clet () = loop m le k	then loop nm body cont
450	in case le	else cbody()
451	of (F.BRANCH _ | F.SWITCH _) =>	| (F.BRANCH _ | F.SWITCH _) =>
452	(* this is a hack originally meant to cleanup the BRANCH mess	(* this is a hack originally meant to cleanup the BRANCH
453	* introduced in flintnm (where each branch returns just true or	* mess introduced in flintnm (where each branch returns
454	* false which is generally only used as input to a SWITCH).	* just true or false which is generally only used as
455	* The present code does slightly more than clean up this case *)	* input to a SWITCH).
456	(* As it stands, the code has at least 2 serious shortcomings:	* The present code does more than clean up this case.
457	* 1 - it applies to the code before fcontraction	* It has one serious shortcoming: it ends up making
458	* 2 - the SWITCH copied into each arm doesn't get reduced	* three fcontract passes through the same code (plus
459	*     early, so the inlining that should happen cannot	* one cheap traversal). *)
460	*     take place because by the time we know that the function	let fun cassoc (lv,F.SWITCH(F.VAR v,ac,arms,NONE),wrap) =
461	*     is a simple-inline candidate, fcontract already processed	if lv <> v orelse C.usenb(C.get lv) > 1
462	*     the call *)	then cbody() else
	(* `extract' extracts the code of a switch arm into a function
	* and replaces it with a call to that function *)
	let fun extract (con,le) =
	let val f = mklv()
	val fk = {isrec=NONE,known=true,inline=F.IH_SAFE,
	cconv=F.CC_FUN(LK.FF_FIXED)}
	in case con of
	F.DATAcon(dc as (_,_,lty),tycs,lv) =>
	let val nlv = cplv lv
	val _ = C.new (SOME[lv]) f
	val _ = C.use NONE (C.new NONE nlv)
	val (lty,_) = LT.ltd_parrow(hd(LT.lt_inst(lty, tycs)))
	in ((F.DATAcon(dc, tycs, nlv),
	F.APP(F.VAR f, [F.VAR nlv])),
	(fk, f, [(lv, lty)], le))
	end
	| con =>
	let val _ = C.new (SOME[]) f
	in ((con, F.APP(F.VAR f, [])),
	(fk, f, [], le))
	end
	end
	fun cassoc (lv,F.SWITCH(F.VAR v,ac,arms,NONE),wrap) =
	if lv <> v orelse C.usenb(C.get lv) > 1 then clet() else
463	let val (narms,fdecs) =	let val (narms,fdecs) =
464	ListPair.unzip (map extract arms)	ListPair.unzip (map extract arms)
465	fun addswitch [v] =	fun addswitch [v] =
466	C.copylexp IntmapF.empty	C.copylexp
467		IntmapF.empty
468	(F.SWITCH(v,ac,narms,NONE))	(F.SWITCH(v,ac,narms,NONE))
469	| addswitch _ = bug "Wrong number of values"	| addswitch _ = bug "prob in addswitch"
470	(* replace each leaf `ret' with a copy	(* replace each leaf `ret' with a copy
471	* of the switch *)	* of the switch *)
472	val nle = append [lv] addswitch le	val nle = append [lv] addswitch nle
473	(* decorate with the functions extracted out	(* decorate with the functions extracted
474	* of the switch arms *)	* from the switch arms *)
475	val nle = foldl (fn (f,le) => F.FIX([f],le))	val nle =
476		foldl (fn (f,le) => F.FIX([f],le))
477	(wrap nle) fdecs	(wrap nle) fdecs
478	(* Ugly hack to alleviate problem 2 mentioned	(* Ugly hack: force one more traversal *)
479	* above: we go through the code twice *)	val nle = loop nm nle #2
	val nle = loop m nle #2
480	in  click_branch();	in  click_branch();
481	loop m nle cont	loop nm nle cont
482	end	end
483		| cassoc _ = cbody()
484	in case (lvs,body)	in case (lvs,body)
485	of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>	of ([lv],le as F.SWITCH _) =>
486	cassoc(lv, le, fn x => x)	cassoc(lv, le, fn x => x)
487	| ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>	| ([lv],F.LET(lvs,le as F.SWITCH _,rest)) =>
488	cassoc(lv, le, fn le => F.LET(lvs,le,rest))	cassoc(lv, le, fn le => F.LET(lvs,le,rest))
489	| _ => clet()	| _ => cbody()
	end
	| _ => clet()
490	end	end
491		| _ => cbody()
492		end)
493
494	| F.FIX (fs,le) =>	fun fcFix (fs,le) =
495	let (* The actual function contraction *)	let (* The actual function contraction *)
496	fun cfun (m,[]:F.fundec list,acc) = acc	fun fcFun (m,[]:F.fundec list,acc) = acc
497	| cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =	| fcFun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
498	let val fi = C.get f	let val fi = C.get f
499	in if C.dead fi then cfun(m, fs, acc)	in if C.dead fi then fcFun(m, fs, acc)
500	else if C.iusenb fi = C.usenb fi then	else if C.iusenb fi = C.usenb fi then
501	(* we need to be careful that undertake not be called	(* we need to be careful that undertake not be called
502	* recursively *)	* recursively *)
503	(C.use NONE fi; undertake m f; cfun(m, fs, acc))	(C.use NONE fi; undertake m f; fcFun(m, fs, acc))
504	else	else
505	let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)	let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
506	val saved_ic = inline_count()	val saved_ic = inline_count()
#	Line 511	Line 509
509	addbind(m, lv, Var(lv, SOME lty))	addbind(m, lv, Var(lv, SOME lty))
510	val nm = foldl addnobind m args	val nm = foldl addnobind m args
511	(* contract the body and create the resulting fundec *)	(* contract the body and create the resulting fundec *)
512	val nbody = cexp (S.add(f, ifs)) nm body #2	val nbody = fcexp (S.add(f, ifs)) nm body #2
513	(* if inlining took place, the body might be completely	(* if inlining took place, the body might be completely
514	* changed (read: bigger), so we have to reset the	* changed (read: bigger), so we have to reset the
515	* `inline' bit *)	* `inline' bit *)
#	Line 527	Line 525
525	* new contracted code while we'll be working on the	* new contracted code while we'll be working on the
526	* the old uncontracted code *)	* the old uncontracted code *)
527	val nm = addbind(m, f, Fun(f, nbody, args, nfk))	val nm = addbind(m, f, Fun(f, nbody, args, nfk))
528	in cfun(nm, fs, (nfk, f, args, nbody)::acc)	in fcFun(nm, fs, (nfk, f, args, nbody)::acc)
529	(*  before say ("\nExiting "^(C.LVarString f)) *)	(*  before say ("\nExiting "^(C.LVarString f)) *)
530	end	end
531	end	end
532
533	(* check for eta redex *)	(* check for eta redex *)
534	fun ceta (fdec as (fk,f,args,F.APP(F.VAR g,vs)):F.fundec,	fun fcEta (fdec as (fk,f,args,F.APP(F.VAR g,vs)):F.fundec,
535	(m,fs,hs)) =	(m,fs,hs)) =
536	if List.length args = List.length vs andalso	if List.length args = List.length vs andalso
537	OU.ListPair_all (fn (v,(lv,t)) =>	OU.ListPair_all (fn (v,(lv,t)) =>
#	Line 571	Line 569
569	end	end
570	end	end
571	else (m, fdec::fs, hs)	else (m, fdec::fs, hs)
572	| ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)	| fcEta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
573
574	(* add wrapper for various purposes *)	(* add wrapper for various purposes *)
575	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
#	Line 628	Line 626
626	addbind(m, f, Fun(f, body, args, fk)))	addbind(m, f, Fun(f, body, args, fk)))
627	m fs	m fs
628	(* check for eta redexes *)	(* check for eta redexes *)
629	val (nm,fs,_) = foldl ceta (nm,[],[]) fs	val (nm,fs,_) = foldl fcEta (nm,[],[]) fs
630
631	(* move the inlinable functions to the end of the list *)	(* move the inlinable functions to the end of the list *)
632	val (f1s,f2s) =	val (f1s,f2s) =
#	Line 639	Line 637
637	(* contract the main body *)	(* contract the main body *)
638	val nle = loop nm le cont	val nle = loop nm le cont
639	(* contract the functions *)	(* contract the functions *)
640	val fs = cfun(nm, fs, [])	val fs = fcFun(nm, fs, [])
641	(* junk newly unused funs *)	(* junk newly unused funs *)
642	val fs = List.filter (used o #2) fs	val fs = List.filter (used o #2) fs
643	in	in
#	Line 653	Line 651
651	| _ => F.FIX(fs, nle)	| _ => F.FIX(fs, nle)
652	end	end
653
654	| F.APP (f,vs) =>	fun fcApp (f,vs) =
655	let val nvs = map substval vs	let val nvs = map substval vs
656	val svf = val2sval m f	val svf = val2sval m f
657	(* F.APP inlining (if any) *)	(* F.APP inlining (if any) *)
#	Line 671	Line 669
669	ignore(C.unuse true (C.get g));	ignore(C.unuse true (C.get g));
670	loop m (F.LET(map #1 args, F.RET vs, body)) cont)	loop m (F.LET(map #1 args, F.RET vs, body)) cont)
671
672	(* aggressive (but safe) inlining.  We allow pretty much	(* aggressive inlining.  We allow pretty much
673	* any inlinling, but we detect and reject inlining	* any inlinling, but we detect and reject inlining
674	* recursively which would else lead to infinite loop *)	* recursively which would else lead to infinite loop *)
675	(* unrolling is not as straightforward as it seems:	(* unrolling is not as straightforward as it seems:
#	Line 691	Line 689
689	click_copyinline();	click_copyinline();
690	(app (unuseval m) vs);	(app (unuseval m) vs);
691	unusecall m g;	unusecall m g;
692	cexp (S.add(g, ifs)) m nle cont	fcexp (S.add(g, ifs)) m nle cont
693	end	end
694	else cont(m,F.APP(sval2val svf, nvs))	else cont(m,F.APP(sval2val svf, nvs))
695	| sv => cont(m,F.APP(sval2val svf, nvs))	| sv => cont(m,F.APP(sval2val svf, nvs))
696	end	end
697
698	| F.TFN ((f,args,body),le) =>	fun fcTfn ((f,args,body),le) =
699	let val fi = C.get f	let val fi = C.get f
700	in if C.dead fi then (click_deadlexp(); loop m le cont) else	in if C.dead fi then (click_deadlexp(); loop m le cont) else
701	let val nbody = cexp ifs m body #2	let val nbody = fcexp ifs m body #2
702	val nm = addbind(m, f, TFun(f, nbody, args))	val nm = addbind(m, f, TFun(f, nbody, args))
703	val nle = loop nm le cont	val nle = loop nm le cont
704	in	in
#	Line 708	Line 706
706	end	end
707	end	end
708
709	| F.TAPP(f,tycs) =>	fun fcSwitch (v,ac,arms,def) =
710	(* (case val2sval m f	let fun fcsCon (lvc,svc,dc1:F.dcon,tycs1) =
	of TFun(g,body,args,od) =>
	if d = od andalso C.usenb(C.get g) = 1 then
	let val (_,_,_,le) =
	({inline=false,isrec=NONE,known=false,cconv=F.CC_FCT},
	LV.mkLvar(),[],
	F.TFN((g,args,body),TAPP(g,tycs)))
	in
	inlineWitness := true;
	ignore(C.unuse true (C.get g));
	end *)
	cont(m, F.TAPP(substval f, tycs))
	| F.SWITCH (v,ac,arms,def) =>
	(case val2sval m v
	of sv as Con (lvc,svc,dc1,tycs1) =>
711	let fun killle le = C.unuselexp (undertake m) le	let fun killle le = C.unuselexp (undertake m) le
712	fun kill lv le =	fun kill lv le =
713	C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le	C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le
#	Line 747	Line 730
730	in click_switch(); carm arms	in click_switch(); carm arms
731	end	end
732
733	| sv as Val v =>	fun fcsVal v =
734	let fun kill le = C.unuselexp (undertake m) le	let fun kill le = C.unuselexp (undertake m) le
735	fun carm ((con,le)::tl) =	fun carm ((con,le)::tl) =
736	if eqConV(con, v) then	if eqConV(con, v) then
#	Line 759	Line 742
742	in click_switch(); carm arms	in click_switch(); carm arms
743	end	end
744
745	| sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}	fun fcsDefault (sv,lvc) =
746	| (* will probably never happen *) Record{1=lvc,...}) =>	case (arms,def)
	(case (arms,def)
747	of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>	of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>
748	(* this is a mere DECON, so we can push the let binding	(* this is a mere DECON, so we can push the let binding
749	* (hidden in cont) inside and maybe even drop the DECON *)	* (hidden in cont) inside and maybe even drop the DECON *)
#	Line 805	Line 787
787	val narms = map carm arms	val narms = map carm arms
788	val ndef = Option.map (fn le => loop m le #2) def	val ndef = Option.map (fn le => loop m le #2) def
789	in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))	in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
790	end)	end
791
792		in case val2sval m v
793		of sv as Con x => fcsCon x
794		| sv as Val v => fcsVal v
795		| sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
796		| (* will probably never happen *) Record{1=lvc,...}) =>
797		fcsDefault(sv, lvc)
798	| sv as (Fun _ | TFun _) =>	| sv as (Fun _ | TFun _) =>
799	bugval("unexpected switch arg", sval2val sv))	bugval("unexpected switch arg", sval2val sv)
800		end
801
802	| F.CON (dc1,tycs1,v,lv,le) =>	fun fcCon (dc1,tycs1,v,lv,le) =
803	let val lvi = C.get lv	let val lvi = C.get lv
804	in if C.dead lvi then (click_deadval(); loop m le cont) else	in if C.dead lvi then (click_deadval(); loop m le cont) else
805	let val ndc = cdcon dc1	let val ndc = cdcon dc1
#	Line 830	Line 819
819	end	end
820	end	end
821
822	| F.RECORD (rk,vs,lv,le) =>	fun fcRecord (rk,vs,lv,le) =
823	(* g: check whether the record already exists *)	(* g: check whether the record already exists *)
824	let val lvi = C.get lv	let val lvi = C.get lv
825	in if C.dead lvi then (click_deadval(); loop m le cont) else	in if C.dead lvi then (click_deadval(); loop m le cont) else
#	Line 867	Line 856
856	end	end
857	end	end
858
859	| F.SELECT (v,i,lv,le) =>	fun fcSelect (v,i,lv,le) =
860	let val lvi = C.get lv	let val lvi = C.get lv
861	in if C.dead lvi then (click_deadval(); loop m le cont) else	in if C.dead lvi then (click_deadval(); loop m le cont) else
862	(case val2sval m v	(case val2sval m v
#	Line 884	Line 873
873	end)	end)
874	end	end
875
876	| F.RAISE (v,ltys) =>	fun fcBranch (po,vs,le1,le2) =
	cont(m, F.RAISE(substval v, ltys))
	| F.HANDLE (le,v) =>
	cont(m, F.HANDLE(loop m le #2, substval v))
	| F.BRANCH (po,vs,le1,le2) =>
877	let val nvs = map substval vs	let val nvs = map substval vs
878	val npo = cpo po	val npo = cpo po
879	val nle1 = loop m le1 #2	val nle1 = loop m le1 #2
#	Line 898	Line 881
881	in cont(m, F.BRANCH(npo, nvs, nle1, nle2))	in cont(m, F.BRANCH(npo, nvs, nle1, nle2))
882	end	end
883
884	| F.PRIMOP (po,vs,lv,le) =>	fun fcPrimop (po,vs,lv,le) =
885	let val lvi = C.get lv	let val lvi = C.get lv
886	val pure = not(impurePO po)	val pure = not(impurePO po)
887	in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else	in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else
#	Line 911	Line 894
894	else F.PRIMOP(npo, nvs, lv, nle)	else F.PRIMOP(npo, nvs, lv, nle)
895	end	end
896	end	end
897
898		in case le
899		of F.RET vs => cont(m, F.RET(map substval vs))
900		| F.LET x => fcLet x
901		| F.FIX x => fcFix x
902		| F.APP x => fcApp x
903		| F.TFN x => fcTfn x
904		| F.TAPP (f,tycs) => cont(m, F.TAPP(substval f, tycs))
905		| F.SWITCH x => fcSwitch x
906		| F.CON x => fcCon x
907		| F.RECORD x => fcRecord x
908		| F.SELECT x => fcSelect x
909		| F.RAISE (v,ltys) => cont(m, F.RAISE(substval v, ltys))
910		| F.HANDLE (le,v) => cont(m, F.HANDLE(loop m le #2, substval v))
911		| F.BRANCH x => fcBranch x
912		| F.PRIMOP x => fcPrimop x
913	end	end
914
915	in	in
916	(*  C.collect fdec; *)	(*  C.collect fdec; *)
917	case cexp S.empty	case fcexp S.empty
918	M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2	M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
919	of F.FIX([fdec], F.RET[F.VAR f]) => fdec	of F.FIX([fdec], F.RET[F.VAR f]) => fdec
920	| fdec => bug "invalid return fundec"	| fdec => bug "invalid return fundec"

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.200   changed lines   Added in v.201

---

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