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

Parent Directory | Revision Log | Patch

	revision 199, Wed Nov 25 18:30:38 1998 UTC	revision 200, Sat Nov 28 17:48:03 1998 UTC
#	Line 185	Line 185
185	structure PP = PPFlint	structure PP = PPFlint
186	structure FU = FlintUtil	structure FU = FlintUtil
187	structure LT = LtyExtern	structure LT = LtyExtern
188		structure LK = LtyKernel
189	structure OU = OptUtils	structure OU = OptUtils
190	structure CTRL = Control.FLINT	structure CTRL = Control.FLINT
191	in	in
#	Line 197	Line 198
198	(* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)	(* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
199
200	val cplv = LambdaVar.dupLvar	val cplv = LambdaVar.dupLvar
201		val mklv = LambdaVar.mkLvar
202
203	datatype sval	datatype sval
204	= Val    of F.value                   (* F.value should never be F.VAR lv *)	= Val    of F.value                   (* F.value should never be F.VAR lv *)
#	Line 220	Line 222
222	LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)	LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
223	| tycs_eq _ = false	| tycs_eq _ = false
224
225		(* calls `code' to append a lexp to each leaf of `le'.
226		* Typically used to transform `let lvs = le in code' so that
227		* `code' is now copied at the end of each branch of `le'.
228		* `lvs' is a list of lvars that should be used if the result of `le'
229		* needs to be bound before calling `code'. *)
230		fun append lvs code le =
231		let fun l (F.RET vs) = code vs
232		| l (le as (F.APP _ | F.TAPP _ | F.RAISE _ | F.HANDLE _)) =
233		let val lvs = map (fn lv => let val nlv = cplv lv
234		in C.new NONE nlv; nlv end)
235		lvs
236		in F.LET(lvs, le, code(map F.VAR lvs))
237		end
238		| l (F.LET (lvs,body,le)) = F.LET(lvs,body, l le)
239		| l (F.FIX (fdecs,le)) = F.FIX(fdecs, l le)
240		| l (F.TFN (tfdec,le)) = F.TFN(tfdec, l le)
241		| l (F.SWITCH (v,ac,arms,def)) =
242		let fun larm (con,le) = (con, l le)
243		in F.SWITCH(v, ac, map larm arms, O.map l def)
244		end
245		| l (F.CON (dc,tycs,v,lv,le)) = F.CON(dc, tycs, v, lv, l le)
246		| l (F.RECORD (rk,vs,lv,le)) = F.RECORD(rk, vs, lv, l le)
247		| l (F.SELECT (v,i,lv,le)) = F.SELECT(v, i, lv, l le)
248		| l (F.BRANCH (po,vs,le1,le2)) = F.BRANCH(po, vs, l le1, l le2)
249		| l (F.PRIMOP (po,vs,lv,le)) = F.PRIMOP(po, vs, lv, l le)
250		in l le
251		end
252
253	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)
254
255	(*  val c_inline         = Stats.newCounter[] *)	(*  val c_inline         = Stats.newCounter[] *)
#	Line 374	Line 404
404	of F.RET vs => cont(m, F.RET(map substval vs))	of F.RET vs => cont(m, F.RET(map substval vs))
405
406	| F.LET (lvs,le,body) =>	| F.LET (lvs,le,body) =>
407	let fun clet () =	let fun k (nm,nle) =
408	loop m le	let fun cbody () =
	(fn (m,F.RET vs) =>
	let fun simplesubst (lv,v,m) =
	let val sv = val2sval m v
	in substitute(m, lv, sv, sval2val sv)
	end
	val nm = (ListPair.foldl simplesubst m (lvs, vs))
	in loop nm body cont
	end
	| (m,nle) =>
409	let val nm = (foldl (fn (lv,m) =>	let val nm = (foldl (fn (lv,m) =>
410	addbind(m, lv, Var(lv, NONE)))	addbind(m, lv, Var(lv, NONE)))
411	m lvs)	nm lvs)
412	in case loop nm body cont	in case loop nm body cont
413	of F.RET vs => if vs = (map F.VAR lvs) then nle	of F.RET vs => if vs = (map F.VAR lvs) then nle
414	else F.LET(lvs, nle, F.RET vs)	else F.LET(lvs, nle, F.RET vs)
415	| nbody => F.LET(lvs, nle, nbody)	| nbody => F.LET(lvs, nle, nbody)
416	end)	end
417	in (* case le	in case nle
418	of F.BRANCH (po,vs,le1,le2) =>	of F.RET vs =>
419		let fun simplesubst (lv,v,m) =
420		let val sv = val2sval m v
421		in substitute(m, lv, sv, sval2val sv)
422		end
423		val nm = (ListPair.foldl simplesubst nm (lvs, vs))
424		in loop nm body cont
425		end
426		| _ => cbody()
427		end
428		fun clet () = loop m le k
429		in case le
430		of (F.BRANCH _ | F.SWITCH _) =>
431	(* this is a hack originally meant to cleanup the BRANCH mess	(* this is a hack originally meant to cleanup the BRANCH mess
432	* introduced in flintnm (where each branch returns just true or	* introduced in flintnm (where each branch returns just true or
433	* false which is generally only used as input to a SWITCH).	* false which is generally only used as input to a SWITCH).
434	* The present code does slightly more than clean up this case *)	* The present code does slightly more than clean up this case *)
435	let fun known (F.RECORD(_,_,_,le)) = known le	(* As it stands, the code has at least 2 serious shortcomings:
436	| known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')	* 1 - it applies to the code before fcontraction
437	| known (F.RET[F.VAR v]) = false	* 2 - the SWITCH copied into each arm doesn't get reduced
438	| known (F.RET[_]) = true	*     early, so the inlining that should happen cannot
439	| known _ = false	*     take place because by the time we know that the function
440	fun cassoc (lv,v,body,wrap) =	*     is a simple-inline candidate, fcontract already processed
441	if lv = v andalso ((C.usenb(C.get lv)) handle x=> raise x) = 1 andalso	*     the call *)
442	known le1 andalso known le2 then
443	(* here I should also check that le1 != le2 *)	(* `extract' extracts the code of a switch arm into a function
444	let val nle1 = F.LET([lv], le1, body)	* and replaces it with a call to that function *)
445	val nlv = cplv lv	let fun extract (con,le) =
446	val _ = C.new NONE nlv	let val f = mklv()
447	val body2 = C.copylexp (M.add(M.empty, lv, nlv))	val fk = {isrec=NONE,known=true,inline=F.IH_SAFE,
448	body	cconv=F.CC_FUN(LK.FF_FIXED)}
449	val nle2 = F.LET([nlv], le2, body2)	in case con of
450	in	F.DATAcon(dc as (_,_,lty),tycs,lv) =>
451	click_branch();	let val nlv = cplv lv
452	loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont	val _ = C.new (SOME[lv]) f
453		val _ = C.use NONE (C.new NONE nlv)
454		val (lty,_) = LT.ltd_parrow(hd(LT.lt_inst(lty, tycs)))
455		in ((F.DATAcon(dc, tycs, nlv),
456		F.APP(F.VAR f, [F.VAR nlv])),
457		(fk, f, [(lv, lty)], le))
458		end
459		| con =>
460		let val _ = C.new (SOME[]) f
461		in ((con, F.APP(F.VAR f, [])),
462		(fk, f, [], le))
463		end
464		end
465		fun cassoc (lv,F.SWITCH(F.VAR v,ac,arms,NONE),wrap) =
466		if lv <> v orelse C.usenb(C.get lv) > 1 then clet() else
467		let val (narms,fdecs) =
468		ListPair.unzip (map extract arms)
469		fun addswitch [v] =
470		C.copylexp IntmapF.empty
471		(F.SWITCH(v,ac,narms,NONE))
472		| addswitch _ = bug "Wrong number of values"
473		(* replace each leaf `ret' with a copy
474		* of the switch *)
475		val nle = append [lv] addswitch le
476		(* decorate with the functions extracted out
477		* of the switch arms *)
478		val nle = foldl (fn (f,le) => F.FIX([f],le))
479		(wrap nle) fdecs
480		(* Ugly hack to alleviate problem 2 mentioned
481		* above: we go through the code twice *)
482		val nle = loop m nle #2
483		in  click_branch();
484		loop m nle cont
485	end	end
	else
	clet()
486	in case (lvs,body)	in case (lvs,body)
487	of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>	of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
488	cassoc(lv, v, le, fn x => x)	cassoc(lv, le, fn x => x)
489	| ([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)) =>
490	cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))	cassoc(lv, le, fn le => F.LET(lvs,le,rest))
491	| _ => clet()	| _ => clet()
492	end	end
493	| _ => *) clet()	| _ => clet()
494	end	end
495
496	| F.FIX (fs,le) =>	| F.FIX (fs,le) =>

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

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

---

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