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

Parent Directory | Revision Log | Patch

	revision 189, Sun Nov 15 22:29:42 1998 UTC	revision 190, Thu Nov 19 21:01:17 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 * Stats.counter -> FLINT.fundec	val contract : FLINT.prog * Stats.counter -> FLINT.prog
9
10	end	end
11
#	Line 145	Line 145
145	*   do the dead-code elimination, so you can only avoid fcontracting a	*   do the dead-code elimination, so you can only avoid fcontracting a
146	*   a function if you can be sure that the body doesn't contain any dead-code,	*   a function if you can be sure that the body doesn't contain any dead-code,
147	*   which is generally  not known).	*   which is generally  not known).
148	* - once a function is fcontracted it is marked as non-inlinable since	* - once a function is fcontracted, its inlinable status is re-examined.
149	*   fcontraction might have changed its shape considerably (via inlining).	*   More specifically, if no inlining occured during its fcontraction, then
150		*   we assume that the code has just become smaller and should hence
151		*   still be considered inlinable.  On another hand, if inlining took place,
152		*   then we have to reset the inline-bit because the new body might
153		*   be completely different (i.e. much bigger) and inlining it might be
154		*   undesirable.
155	*   This means that in the case of	*   This means that in the case of
156	*       let fwrap x = body1 and f y = body2 in exp	*       let fwrap x = body1 and f y = body2 in exp
157	*   if fwrap is fcontracted before f, then fwrap cannot be inlined in f.	*   if fwrap is fcontracted before f and something gets inlined into it,
158		*   then fwrap cannot be inlined in f.
159	*   To minimize the impact of this problem, we make sure that we fcontract	*   To minimize the impact of this problem, we make sure that we fcontract
160	*   inlinable functions only after fcontracting other mutually recursive	*   inlinable functions only after fcontracting other mutually recursive
161	*   functions.	*   functions.  One way to solve the problem more thoroughly would be
162		*   to keep the uncontracted fwrap around until f has been contracted.
163		*   Such a trick hasn't seemed necessary yet.
164	* - at the very end of the optimization phase, cpsopt had a special pass	* - at the very end of the optimization phase, cpsopt had a special pass
165	*   that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining	*   that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
166	*   into it doesn't have any undesirable side effects any more).  The present	*   into it doesn't have any undesirable side effects any more).  The present
#	Line 226	Line 234
234	(*  val c_eta    = Stats.newCounter[] *)	(*  val c_eta    = Stats.newCounter[] *)
235	(*  val c_etasplit       = Stats.newCounter[] *)	(*  val c_etasplit       = Stats.newCounter[] *)
236	(*  val c_branch         = Stats.newCounter[] *)	(*  val c_branch         = Stats.newCounter[] *)
	(*  val c_cstargs        = Stats.newCounter[] *)
237	(*  val c_dropargs       = Stats.newCounter[] *)	(*  val c_dropargs       = Stats.newCounter[] *)
238
239	fun contract (fdec as (_,f,_,_), counter) = let	fun contract (fdec as (_,f,_,_), counter) = let
#	Line 243	Line 250
250	fun click_eta      () = (click "e" counter)	fun click_eta      () = (click "e" counter)
251	fun click_etasplit () = (click "E" counter)	fun click_etasplit () = (click "E" counter)
252	fun click_branch   () = (click "b" counter)	fun click_branch   () = (click "b" counter)
	fun click_cstargs  () = (click "A" counter)
253	fun click_dropargs () = (click "a" counter)	fun click_dropargs () = (click "a" counter)
254
255	fun click_lacktype () = (click "t" c_miss)	fun click_lacktype () = (click "t" c_miss)
#	Line 399	Line 405
405	* mutually recursive with its main function.  On another hand,	* mutually recursive with its main function.  On another hand,
406	* self recursion (C.recursive) is too dangerous to be inlined	* self recursion (C.recursive) is too dangerous to be inlined
407	* except for loop unrolling *)	* except for loop unrolling *)
408	else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) orelse	(* unrolling is not as straightforward as it seems:
409	(inline = F.IH_UNROLL andalso (S.member ifs g)) then	* if you inline the function you're currently fcontracting,
410		* you're asking for trouble: there is a hidden assumption
411		* in the counting that the old code will be replaced by the new
412		* code (and is hence dead).  If the function to be unrolled
413		* has the only call to function f, then f might get simpleinlined
414		* before unrolling, which means that unrolling will introduce
415		* a second occurence of the `only call' but at that point f
416		* has already been killed. *)
417		else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) (*orelse
418		(inline = F.IH_UNROLL andalso (S.member ifs g)) *) then
419	let val nle =	let val nle =
420	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))
421	in	in
#	Line 424	Line 439
439	let fun clet () =	let fun clet () =
440	loop m le	loop m le
441	(fn (m,F.RET vs) =>	(fn (m,F.RET vs) =>
442	let fun simplesubst ((lv,v),m) =	let fun simplesubst (lv,v,m) =
443	let val sv = (val2sval m v) handle x => raise x	let val sv = (val2sval m v) handle x => raise x
444	in substitute(m, lv, sv, sval2val sv)	in substitute(m, lv, sv, sval2val sv)
445	end	end
446	val nm = (foldl simplesubst m (zip(lvs, vs)))	val nm = (ListPair.foldl simplesubst m (lvs, vs))
447	in loop nm body cont	in loop nm body cont
448	end	end
449	| (m,nle) =>	| (m,nle) =>
#	Line 469	Line 484
484	clet()	clet()
485	in case (lvs,body)	in case (lvs,body)
486	of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>	of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
487	cassoc(lv, v, le, OU.id)	cassoc(lv, v, le, fn x => x)
488	| ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>	| ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
489	cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))	cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))
490	| _ => clet()	| _ => clet()
#	Line 555	Line 570
570	else (m, fdec::fs, hs)	else (m, fdec::fs, hs)
571	| ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)	| ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
572
	(* drop constant arguments if possible *)
	fun cstargs (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec) = f
	| cstargs (f as (fk,g,args,body):F.fundec) =
	let val actuals = (C.actuals (C.get g)) handle x => raise x
	val cst =
	ListPair.map
	(fn (NONE,_) => false
	| (SOME(F.VAR lv),(a,_)) =>
	((case sval2val(lookup m lv)
	of F.VAR lv =>
	if used a andalso used lv then
	(C.use NONE (C.get lv); true)
	else false
	| _ => true)
	handle M.IntmapF => false)
	| (SOME v,(a,_)) => true)
	(actuals, args)
	(* if all args are used, there's nothing we can do *)
	in if List.all not cst then f else
	let fun newarg lv =
	let val nlv = cplv lv in C.new NONE nlv; nlv end
	fun filter xs = OU.filter(cst, xs)
	(* construct the new arg list *)
	val nargs = ListPair.map
	(fn ((a,t),true) => (newarg a,t)
	| ((a,t),false) => (a,t))
	(args, cst)
	(* construct the new body *)
	val nbody =
	F.LET(map #1 (filter args),
	F.RET(map O.valOf (filter actuals)),
	body)
	in click_cstargs();
	(fk, g, nargs, nbody)
	end
	end
573	(* add wrapper for various purposes *)	(* add wrapper for various purposes *)
574	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
575	| wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =	| wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
#	Line 614	Line 592
592	app (C.use NONE o C.get) nargs';	app (C.use NONE o C.get) nargs';
593	nf'::nf::fs	nf'::nf::fs
594	end	end
	val used = map (used o #1) args
595	in	in
596	(* Don't introduce wrappers for escaping-only functions.	(* Don't introduce wrappers for escaping-only functions.
597	* This is debatable since although wrappers are useless	* This is debatable since although wrappers are useless
#	Line 622	Line 599
599	* might turn into calls in the course of fcontract, so	* might turn into calls in the course of fcontract, so
600	* by not introducing wrappers here, we avoid useless work	* by not introducing wrappers here, we avoid useless work
601	* but we also postpone useful work to later invocations. *)	* but we also postpone useful work to later invocations. *)
602	if C.called gi then	if C.dead gi then fs else
603		let val used = map (used o #1) args
604		in if C.called gi then
605	(* if some args are not used, let's drop them *)	(* if some args are not used, let's drop them *)
606	if not (List.all OU.id used) then	if not (List.all (fn x => x) used) then
607	(click_dropargs();	(click_dropargs();
608	dropargs (fn xs => OU.filter(used, xs)))	dropargs (fn xs => OU.filter(used, xs)))
609
610	(* eta-split: add a wrapper for escaping uses *)	(* eta-split: add a wrapper for escaping uses *)
611	else if C.escaping gi then	else if C.escaping gi then
612	(* like dropargs but keeping all args *)	(* like dropargs but keeping all args *)
613	(click_etasplit(); dropargs OU.id)	(click_etasplit(); dropargs (fn x => x))
614
615	else f::fs	else f::fs
616	else f::fs	else f::fs
617	end	end
618		end
	(* junk unused funs *)
	val fs = List.filter (fn (_,f,_,_) =>
	used f orelse (click_deadlexp(); false))
	fs
	(* redirect cst args to their source value *)
	val fs = map cstargs fs
619
620	(* add various wrappers *)	(* add various wrappers *)
621	val fs = foldl wrap [] fs	val fs = foldl wrap [] fs
#	Line 681	Line 653
653	| F.APP (f,vs) =>	| F.APP (f,vs) =>
654	let val nvs = ((map substval vs) handle x => raise x)	let val nvs = ((map substval vs) handle x => raise x)
655	in case inline ifs (f, nvs)	in case inline ifs (f, nvs)
656	of (SOME(le,od),nifs) => cexp (d,od) ifs m le cont	of (SOME(le,od),nifs) => cexp (d,od) nifs m le cont
657	| (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))	| (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))
658	end	end
659

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.189   changed lines   Added in v.190

---

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