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

Parent Directory | Revision Log | Patch

	revision 163, Thu Oct 29 21:00:27 1998 UTC	revision 164, Sat Oct 31 01:03:30 1998 UTC
#	Line 240	Line 240
240	of F.VAR lv => lv	of F.VAR lv => lv
241	| v => bugval ("unexpected val", v)	| v => bugval ("unexpected val", v)
242
243	fun unuseval f (F.VAR lv) = C.unuse f false lv	fun unuseval f (F.VAR lv) = ((C.unuse f false lv) handle x => raise x)
244	| unuseval f _ = ()	| unuseval f _ = ()
245
246	(* called when a variable becomes dead.	(* called when a variable becomes dead.
#	Line 265	Line 265
265
266	fun addbind (m,lv,sv) = M.add(m, lv, sv)	fun addbind (m,lv,sv) = M.add(m, lv, sv)
267
268	(* substitute a value sv for a variable lv and unuse value v.	(* substitute a value sv for a variable lv and unuse value v. *)
	* This doesn't quite work for eta-redex since the `use' we have
	* to remove in that case is a non-escaping use, whereas this code
	* assumes that we're getting rid of an escaping use *)
269	fun substitute (m, lv1, sv, v) =	fun substitute (m, lv1, sv, v) =
270	(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();	(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
271	unuseval (undertake m) v;	unuseval (undertake m) v;
272	addbind(m, lv1, sv)) handle x =>	addbind(m, lv1, sv)) handle x =>
273	(say "\nwhile substituting ";	(say ("\nwhile substituting "^
274	PP.printSval (F.VAR lv1);	(C.LVarString lv1)^
275	say " for ";	" -> ");
276	PP.printSval (sval2val sv);	PP.printSval (sval2val sv);
277	raise x)	raise x)
278
#	Line 306	Line 303
303	fun inline ifs (f,vs) =	fun inline ifs (f,vs) =
304	case ((val2sval m f) handle x => raise x)	case ((val2sval m f) handle x => raise x)
305	of Fun(g,body,args,fk,od) =>	of Fun(g,body,args,fk,od) =>
306	(ASSERT(C.usenb g > 0, "C.usenb g > 0");	(ASSERT(used g, "used "^(C.LVarString g));
307	(* if a function is mutually recursive with one of the	if C.usenb g = 1 andalso od = d andalso not(S.member ifs g)
	* functions inside which we are, inlining it will turn
	* extrnal uses in internal ones.  The 'body move' optimization
	* used below cannot be used in such a case *)
	if C.usenb g = 1 andalso od = d andalso not (isrec fk)
308
309	(* simple inlining:  we should copy the body and then	(* simple inlining:  we should copy the body and then
310	* kill the function, but instead we just move the body	* kill the function, but instead we just move the body
311	* and kill only the function name.  This inlining strategy	* and kill only the function name.  This inlining strategy
312	* looks inoffensive enough, but still requires some care:	* looks inoffensive enough, but still requires some care:
313	* see comments at the begining of this file and in cfun *)	* see comments at the begining of this file and in cfun *)
314	then (C.unuse (fn _ => ()) true g; ASSERT(not (used g), "killed");	then ((C.unuse (fn _ => ()) true g) handle x => raise x; ASSERT(not (used g), "killed");
315	(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))	(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
316
317	(* aggressive inlining (but hopefully safe).  We allow	(* aggressive inlining (but hopefully safe).  We allow
#	Line 328	Line 321
321	* mutually recursive with its main function.  On another hand,	* mutually recursive with its main function.  On another hand,
322	* self recursion (C.recursive) is too dangerous to be inlined	* self recursion (C.recursive) is too dangerous to be inlined
323	* except for loop unrolling which we don't support yet *)	* except for loop unrolling which we don't support yet *)
324	else if ((inlinable fk orelse	else if inlinable fk andalso od = d andalso not(S.member ifs g) then
	(C.usenb g = 1 andalso not (C.recursive g)))
	andalso od = d andalso not(S.member ifs g)) then
325	let val nle =	let val nle =
326	FU.copy M.empty (F.LET(map #1 args, F.RET vs, body))	C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
327	val _ = if C.recursive g then	in
328	(say "\n inlining recursive function ";	(app (unuseval (undertake m)) vs) handle x => raise x;
329	PP.printSval (F.VAR g)) else ()	(C.unuse (undertake m) true g) handle x => raise x;
	in C.uselexp nle;
	app (unuseval (undertake m)) vs;
	(* FIXME: this `unuse' can lead to bogus counts if we
	* currently are in a function mutually recursive with g *)
	if isrec fk then () else C.unuse (undertake m) true g;
330	(SOME(nle, od), S.add(g, ifs))	(SOME(nle, od), S.add(g, ifs))
331	end	end
332	else (NONE, ifs))	else (NONE, ifs))
#	Line 387	Line 373
373	(* here I should also check that le1 != le2 *)	(* here I should also check that le1 != le2 *)
374	let val nle1 = F.LET([lv], le1, body)	let val nle1 = F.LET([lv], le1, body)
375	val nlv = cplv lv	val nlv = cplv lv
376	val body2 = FU.copy (M.add(M.empty,lv,nlv)) body	val _ = C.new NONE nlv
377		val body2 = C.copylexp (M.add(M.empty, lv, nlv))
378		body
379	val nle2 = F.LET([nlv], le2, body2)	val nle2 = F.LET([nlv], le2, body2)
380	in C.new false nlv; C.uselexp body2;	in
381	lopm(wrap(F.BRANCH(po, vs, nle1, nle2)))	lopm(wrap(F.BRANCH(po, vs, nle1, nle2)))
382	end	end
383	else	else
#	Line 402	Line 390
390	| _ => clet()	| _ => clet()
391	end	end
392	| F.RET vs =>	| F.RET vs =>
393	(let fun simplesubst ((lv,v),m) =	let fun simplesubst ((lv,v),m) =
394	let val sv = (val2sval m v) handle x => raise x	let val sv = (val2sval m v) handle x => raise x
395	in substitute(m, lv, sv, sval2val sv)	in substitute(m, lv, sv, sval2val sv)
396	end	end
397	in loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body	in loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body
398	end handle x => raise x)	end
399	| F.APP(f,vs) =>	| F.APP(f,vs) => clet()
400	(case inline ifs (f, vs)	(* let-associativity can be annoying here.  I should really use
401	of (SOME(le,od),ifs) => cexp (d,od) ifs m (F.LET(lvs, le, body))	* continuation passing style instead.
402	| (NONE,_) => clet())	* (case inline ifs (f, vs)
403		* of (SOME(le,od),ifs) => cexp (d,od) ifs m (F.LET(lvs, le, body))
404		*  | (NONE,_) => clet()) *)
405	| (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>	| (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>
406	clet()	clet()
407	end	end
408
409	| F.FIX (fs,le) =>	| F.FIX (fs,le) =>
410	let fun cfun (m,[]:F.fundec list,acc) = acc	let (* register dump bindings *)
411		val m = foldl (fn (fdec as (_,f,_,_),m) =>
412		addbind(m, f, Var(f,NONE)))
413		m fs
414
415		(* The actual function contraction *)
416		fun cfun (m,[]:F.fundec list,acc) = acc
417	| cfun (m,fdec as (fk,f,args,body)::fs,acc) =	| cfun (m,fdec as (fk,f,args,body)::fs,acc) =
418	if used f then	if used f then
419	let (* make up the bindings for args inside the body *)	let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
420		(* make up the bindings for args inside the body *)
421	fun addnobind ((lv,lty),m) =	fun addnobind ((lv,lty),m) =
422	addbind(m, lv, Var(lv, SOME lty))	addbind(m, lv, Var(lv, SOME lty))
423	val nm = foldl addnobind m args	val nm = foldl addnobind m args
424	(* contract the body and create the resulting fundec *)	(* contract the body and create the resulting fundec *)
425	val nbody = C.inside f (fn()=> loop nm body)	val nbody = cexp cfg (S.add(f, ifs)) nm body
426	(* fixup the fkind info with new data.	(* The `inline' bit has to be turned off because
	* C.recursive only tells us if a fun is self-recursive
	* but doesn't deal with mutual recursion.
	* Also the `inline' bit has to be turned off because
427	* it applied to the function before contraction	* it applied to the function before contraction
428	* but might not apply to its new form (inlining might	* but might not apply to its new form (inlining might
429	* have increased its size substantially or made it	* have increased its size substantially or made it
#	Line 438	Line 432
432	val nfk =	val nfk =
433	case fk of F.FK_FCT => fk	case fk of F.FK_FCT => fk
434	| F.FK_FUN {isrec,fixed,known,inline} =>	| F.FK_FUN {isrec,fixed,known,inline} =>
435	let val nisrec = if isSome isrec andalso	let val nknown = known orelse not(C.escaping f)
436	null fs andalso	in F.FK_FUN{isrec=isrec, fixed=fixed,
	null acc andalso
	not(C.recursive f)
	then NONE else isrec
	val nknown = known orelse not(C.escaping f)
	in F.FK_FUN{isrec=nisrec, fixed=fixed,
437	inline=false, known=nknown}	inline=false, known=nknown}
438	end	end
439	(* update the binding in the map.  This step is not	(* update the binding in the map.  This step is not
#	Line 455	Line 444
444	* the old uncontracted code *)	* the old uncontracted code *)
445	val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))	val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))
446	in cfun(nm, fs, (nfk, f, args, nbody)::acc)	in cfun(nm, fs, (nfk, f, args, nbody)::acc)
447		(*  before say ("\nExiting "^(C.LVarString f)) *)
448	end	end
449	else cfun(m, fs, acc)	else cfun(m, fs, acc)
450
#	Line 485	Line 475
475	then addbind(m, h, svg) else m)	then addbind(m, h, svg) else m)
476	m hs	m hs
477	in	in
478	(* if g is one of the members of the FIX, f might	(* I could almost reuse `substitute' but the
479	* appear in its body, so we don't know what parts	* unuse in substitute assumes the val is escaping *)
480	* of the counts of f should be counted as inside	C.transfer(f, g);
481	* g and what parts should be counted as outside	C.unuse (undertake m) true g;
482	* so we take the conservative approach of counting	(addbind(m, f, svg), f::hs)
	* them in both *)
	if isSome(List.find (fn (_,f,_,_) => f = g) fs)
	then C.inside g (fn()=> C.addto(f,g)) else ();
	C.transfer(f,g); C.unuse (undertake nm) true g;
	(addbind(nm, f, svg),f::hs)
483	end	end
484	(* the default case could ensure the inline *)	(* the default case could ensure the inline *)
485	else (m, hs)	else (m, hs)
#	Line 502	Line 487
487	else (m, hs)	else (m, hs)
488	| ceta (_,(m,hs)) = (m, hs)	| ceta (_,(m,hs)) = (m, hs)
489
490	(* add droparg wrapper if useful *)	(* drop constant arguments if possible *)
491	fun dropargs (f as (fk,g,args,body):F.fundec,fs) =	fun dropcstargs (f as (fk,g,args,body):F.fundec,fs) =
492		case fk
493		of F.FK_FCT => f::fs (* we can't make inlinable fcts *)
494		| F.FK_FUN{inline=true,...} => f::fs (* no use *)
495		| fk =>
496		let val cst =
497		ListPair.map
498		(fn (NONE,_) => false
499		| (SOME(F.VAR lv),(v,_)) =>
500		((lookup m lv;
501		if used v andalso used lv then
502		(C.use NONE lv; true)
503		else false)
504		handle M.IntmapF => false)
505		| _ => true)
506		(C.actuals g, args)
507		(* if all args are used, there's nothing we can do *)
508		in if List.all not cst then f::fs else
509		let fun newarg lv =
510		let val nlv = cplv lv in C.new NONE nlv; nlv end
511		fun filter xs = OU.filter(cst, xs)
512		(* construct the new arg list *)
513		val nargs = ListPair.map
514		(fn ((a,t),true) => (newarg a,t)
515		| ((a,t),false) => (a,t))
516		(args, cst)
517		(* construct the new body *)
518		val nbody =
519		F.LET(map #1 (filter args),
520		F.RET(map valOf (filter (C.actuals g))),
521		body)
522		in (fk,g,nargs,nbody)::fs
523		end
524		end
525
526		(* add droparg wrapper to drop dead arguments *)
527		fun dropdeadargs (f as (fk,g,args,body):F.fundec,fs) =
528	case fk	case fk
529	of F.FK_FCT => f::fs (* we can't make inlinable fcts *)	of F.FK_FCT => f::fs (* we can't make inlinable fcts *)
530	| F.FK_FUN{inline=true,...} => f::fs (* no use *)	| F.FK_FUN{inline=true,...} => f::fs (* no use *)
531	| fk as F.FK_FUN{isrec,...} =>	| fk as F.FK_FUN{isrec,...} =>
532	let val used = map (fn (v,t) => (C.usenb v > 0)) args	let val used = map (used o #1) args
533	(* if all args are used, there's nothing we can do *)	(* if all args are used, there's nothing we can do *)
534	in if List.all OU.id used then f::fs else	in if List.all OU.id used then f::fs else
535	let fun filter xs = OU.filter(used, xs)	let fun filter xs = OU.filter(used, xs)
536		val args' = filter args
537	val ng = cplv g	val ng = cplv g
	val _ = (C.new true ng; C.use true ng; C.extcounts g)
538	val nargs = map (fn (v,t) => (cplv v, t)) args	val nargs = map (fn (v,t) => (cplv v, t)) args
539	val _ = app (fn (v,t) =>	val nargs' = map #1 (filter nargs)
540	(C.new false v; C.use false v))	val appargs = (map F.VAR nargs')
541	nargs
542	val appargs = (map (F.VAR o #1) nargs)	val _ = C.new (SOME(map #1 args')) ng
543		val _ = C.use (SOME appargs) ng
544		val _ = app ((C.new NONE) o #1) nargs
545		val _ = app (C.use NONE) nargs'
546
547	val (nfk,nfk') = OU.fk_wrap(fk, isrec)	val (nfk,nfk') = OU.fk_wrap(fk, isrec)
548	val nf = (nfk, g, nargs,	val nf = (nfk, g, nargs,
549	F.APP(F.VAR ng, filter appargs))	F.APP(F.VAR ng, appargs))
550	val nf' = (nfk', ng, filter args, body)	val nf' = (nfk', ng, args', body)
551	in nf'::nf::fs	in nf'::nf::fs
552	end	end
553	end	end
554
555	(* junk unused funs *)	(* add wrappers to drop unused arguments *)
556	val fs = List.filter (used o #2) fs	val fs = foldl dropcstargs [] fs
557
558	(* add wrappers to drop unused arguments *)	(* add wrappers to drop unused arguments *)
559	val fs = foldl dropargs [] fs	val fs = foldl dropdeadargs [] fs
560
561	(* register the new bindings (uncontracted for now) *)	(* register the new bindings (uncontracted for now) *)
562	val nm = foldl (fn (fdec as (fk,f,args,body),m) =>	val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
#	Line 573	Line 598
598	end	end
599
600	| F.TFN ((f,args,body),le) =>	| F.TFN ((f,args,body),le) =>
	if used f then
601	let val nbody = cexp (DI.next d, DI.next od) ifs m body	let val nbody = cexp (DI.next d, DI.next od) ifs m body
602	val nm = addbind(m, f, TFun(f, nbody, args, od))	val nm = addbind(m, f, TFun(f, nbody, args, od))
603	val nle = loop nm le	val nle = loop nm le
604	in	in
605	if used f then F.TFN((f, args, nbody), nle) else nle	if used f then F.TFN((f, args, nbody), nle) else nle
606	end	end
	else loop m le
607
608	| F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)	| F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)
609
#	Line 614	Line 637
637	end	end
638
639	| Con (lvc,v,dc1,tycs1) =>	| Con (lvc,v,dc1,tycs1) =>
640	let fun killle le = (#1 (C.unuselexp (undertake m))) le	let fun killle le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
641	fun kill lv le =	fun kill lv le =
642	(#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le	((#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le) handle x => raise x
643	fun killarm (F.DATAcon(_,_,lv),le) = kill lv le	fun killarm (F.DATAcon(_,_,lv),le) = kill lv le
644	| killarm _ = buglexp("bad arm in switch(con)", le)	| killarm _ = buglexp("bad arm in switch(con)", le)
645
#	Line 634	Line 657
657	end	end
658
659	| Val v =>	| Val v =>
660	let fun kill le = (#1 (C.unuselexp (undertake m))) le	let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
661	fun carm ((con,le)::tl) =	fun carm ((con,le)::tl) =
662	if eqConV(con, v) then	if eqConV(con, v) then
663	(map (kill o #2) tl; Option.map kill def; loop m le)	(map (kill o #2) tl; Option.map kill def; loop m le)
#	Line 646	Line 669
669	bugval("unexpected switch arg", sval2val sv))	bugval("unexpected switch arg", sval2val sv))
670
671	| F.CON (dc1,tycs1,v,lv,le) =>	| F.CON (dc1,tycs1,v,lv,le) =>
	(* Here we should try to nullify CON(DECON x) => x *)
	if used lv then
672	let val ndc = cdcon dc1	let val ndc = cdcon dc1
673	fun ccon sv =	fun ccon sv =
674	let val nv = sval2val sv	let val nv = sval2val sv
#	Line 664	Line 685
685	else ccon sv	else ccon sv
686	| sv => ccon sv	| sv => ccon sv
687	end	end
	else loop m le
688
689	| F.RECORD (rk,vs,lv,le) =>	| F.RECORD (rk,vs,lv,le) =>
	(* Here I could try to see if I'm reconstructing a preexisting record.
	* The `lty option' of Var is there just for that purpose *)
	if used lv then
690	(* g: check whether the record already exists *)	(* g: check whether the record already exists *)
691	let fun g (n,Select(_,v1,i)::ss) =	let fun g (n,Select(_,v1,i)::ss) =
692	if n = i then	if n = i then
#	Line 704	Line 721
721	in if used lv then F.RECORD(rk, nvs, lv, nle) else nle	in if used lv then F.RECORD(rk, nvs, lv, nle) else nle
722	end	end
723	end	end
	else loop m le
724
725	| F.SELECT (v,i,lv,le) =>	| F.SELECT (v,i,lv,le) =>
726	if used lv then	(case ((val2sval m v) handle x => raise x)
	case ((val2sval m v) handle x => raise x)
727	of Record (lvr,vs) =>	of Record (lvr,vs) =>
728	let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x	let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x
729	in loop (substitute(m, lv, sv, F.VAR lvr)) le	in loop (substitute(m, lv, sv, F.VAR lvr)) le
#	Line 718	Line 733
733	val nm = addbind (m, lv, Select(lv, nv, i))	val nm = addbind (m, lv, Select(lv, nv, i))
734	val nle = loop nm le	val nle = loop nm le
735	in if used lv then F.SELECT(nv, i, lv, nle) else nle	in if used lv then F.SELECT(nv, i, lv, nle) else nle
736	end	end)
	else loop m le
737
738	| F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)	| F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)
739
#	Line 735	Line 749
749
750	| F.PRIMOP (po,vs,lv,le) =>	| F.PRIMOP (po,vs,lv,le) =>
751	let val impure = impurePO po	let val impure = impurePO po
752	in if impure orelse used lv then	val nvs = ((map substval vs) handle x => raise x)
	let val nvs = ((map substval vs) handle x => raise x)
753	val npo = cpo po	val npo = cpo po
754	val nm = addbind(m, lv, Var(lv,NONE))	val nm = addbind(m, lv, Var(lv,NONE))
755	val nle = loop nm le	val nle = loop nm le
#	Line 745	Line 758
758	then F.PRIMOP(npo, nvs, lv, nle)	then F.PRIMOP(npo, nvs, lv, nle)
759	else nle	else nle
760	end	end
	else loop m le
	end
761	end	end
762
763	fun contract (fdec as (_,f,_,_)) =	fun contract (fdec as (_,f,_,_)) =
764	(C.collect fdec;	((*  C.collect fdec; *)
765	case cexp (DI.top,DI.top) S.empty M.empty (F.FIX([fdec], F.RET[F.VAR f]))	case cexp (DI.top,DI.top) S.empty M.empty (F.FIX([fdec], F.RET[F.VAR f]))
766	of F.FIX([fdec], F.RET[F.VAR f]) => fdec	of F.FIX([fdec], F.RET[F.VAR f]) => fdec
767	| 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.163   changed lines   Added in v.164

---

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