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

Parent Directory | Revision Log | Patch

	revision 183, Sun Nov 8 16:58:19 1998 UTC	revision 184, Sun Nov 8 21:18:20 1998 UTC
#	Line 22	Line 22
22	* - elimination of Con(Decon x)	* - elimination of Con(Decon x)
23	* - update counts when selecting a SWITCH alternative	* - update counts when selecting a SWITCH alternative
24	* - contracting RECORD(R.1,R.2) => R  (only if the type is easily available)	* - contracting RECORD(R.1,R.2) => R  (only if the type is easily available)
25	* - dropping of arguments	* - dropping of dead arguments
26		* - elimination of constant arguments
27	*)	*)
28
29	(* things that lcontract.sml does that fcontract doesn't do (yet):	(* things that lcontract.sml does that fcontract doesn't do (yet):
#	Line 43	Line 44
44	*)	*)
45
46	(* things that could also be added:	(* things that could also be added:
47	* - elimination of dead vars in let (subsumes what lcontract does)	* - elimination of dead vars in let
48	*)	*)
49
50	(* things that would require some type info:	(* things that would require some type info:
#	Line 109	Line 110
110	*   once.  In the future, maybe.	*   once.  In the future, maybe.
111	*)	*)
112
113		(* Dropping useless arguments.
114		* Arguments whose value is constant (i.e. the function is known and each
115		* call site provides the same value for that argument (or the argument
116		* itself in the case of recursive calls) can be safely removed and replaced
117		* inside the body by a simple let binding.  The only problem is that the
118		* constant argument might be out of scope at the function definition site.
119		* It is obviously always possible to move the function to bring the argument
120		* in scope, but since we don't do any code motion here, we're stuck.
121		* If it wasn't for this little problem, we could do the cst-arg removal in
122		* collect (we don't gain anything from doing it here).
123		* The removal of dead arguments (args not used in the body) on the other
124		* hand can quite well be done in collect, the only problem being that it
125		* is convenient to do it after the cst-arg removal so that we can rely
126		* on deadarg to do the actual removal of the cst-arg.
127		*)
128
129	(* Simple inlining (inlining called-once functions, which doesn't require	(* Simple inlining (inlining called-once functions, which doesn't require
130	* alpha-renaming) seems inoffensive enough but is not always desirable.	* alpha-renaming) seems inoffensive enough but is not always desirable.
131	* The typical example is wrapper functions introduced by eta-expand: they	* The typical example is wrapper functions introduced by eta-expand: they
#	Line 155	Line 172
172	structure M  = IntmapF	structure M  = IntmapF
173	structure S  = IntSetF	structure S  = IntSetF
174	structure C  = Collect	structure C  = Collect
175		structure O  = Option
176	structure DI = DebIndex	structure DI = DebIndex
177	structure PP = PPFlint	structure PP = PPFlint
178	structure FU = FlintUtil	structure FU = FlintUtil
#	Line 199	Line 217
217	* ifs (inlined functions): records which functions we're currently inlining	* ifs (inlined functions): records which functions we're currently inlining
218	*     in order to detect loops	*     in order to detect loops
219	* m: is a map lvars to their defining expressions (svals) *)	* m: is a map lvars to their defining expressions (svals) *)
220	fun cexp (cfg as (d,od)) ifs m le = let	fun cexp (cfg as (d,od)) ifs m le cont = let
221
222	val loop = cexp cfg ifs	val loop = cexp cfg ifs
223
#	Line 287	Line 305
305	(s, Access.EXN(Access.LVAR(substvar lv)), lty)	(s, Access.EXN(Access.LVAR(substvar lv)), lty)
306	| cdcon dc = dc	| cdcon dc = dc
307
308	fun isrec (F.FK_FCT | F.FK_FUN{isrec=NONE,...}) = false	fun zip ([],[]) = []
309	| isrec _ = true	| zip (x::xs,y::ys) = (x,y)::(zip(xs,ys))
310		| zip _ = bug "bad zip"
	fun inlinable F.FK_FCT = false
	| inlinable (F.FK_FUN{inline,...}) = inline
311
312	(* F.APP inlining (if any)	(* F.APP inlining (if any)
313	* `ifs' is the set of function we are currently inlining	* `ifs' is the set of function we are currently inlining
#	Line 302	Line 318
318	*)	*)
319	fun inline ifs (f,vs) =	fun inline ifs (f,vs) =
320	case ((val2sval m f) handle x => raise x)	case ((val2sval m f) handle x => raise x)
321	of Fun(g,body,args,fk,od) =>	of Fun(g,body,args,{inline,...},od) =>
322	(ASSERT(used g, "used "^(C.LVarString g));	(ASSERT(used g, "used "^(C.LVarString g));
323	if C.usenb g = 1 andalso od = d andalso not(S.member ifs g)	if d <> od then (NONE, ifs)
324		else if C.usenb g = 1 andalso not(S.member ifs g) then
325
326	(* simple inlining:  we should copy the body and then	(* simple inlining:  we should copy the body and then
327	* kill the function, but instead we just move the body	* kill the function, but instead we just move the body
328	* and kill only the function name.  This inlining strategy	* and kill only the function name.  This inlining strategy
329	* looks inoffensive enough, but still requires some care:	* looks inoffensive enough, but still requires some care:
330	* see comments at the begining of this file and in cfun *)	* see comments at the begining of this file and in cfun *)
331	then ((C.unuse (fn _ => ()) true g) handle x => raise x; ASSERT(not (used g), "killed");	(C.unuse (fn _ => ()) true g;
332		ASSERT(not (used g), "killed");
333	(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))	(SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
334
335	(* aggressive inlining (but hopefully safe).  We allow	(* aggressive inlining (but hopefully safe).  We allow
#	Line 320	Line 338
338	* happen that a wrapper (that should be inlined) has to be made	* happen that a wrapper (that should be inlined) has to be made
339	* mutually recursive with its main function.  On another hand,	* mutually recursive with its main function.  On another hand,
340	* self recursion (C.recursive) is too dangerous to be inlined	* self recursion (C.recursive) is too dangerous to be inlined
341	* except for loop unrolling which we don't support yet *)	* except for loop unrolling *)
342	else if inlinable fk andalso od = d andalso not(S.member ifs g) then	else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) orelse
343		(inline = F.IH_UNROLL andalso (S.member ifs g)) then
344	let val nle =	let val nle =
345	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))
346	in	in
347		(*  say ("\nInlining "^(C.LVarString g)); *)
348	(app (unuseval (undertake m)) vs) handle x => raise x;	(app (unuseval (undertake m)) vs) handle x => raise x;
349	(C.unuse (undertake m) true g) handle x => raise x;	(C.unuse (undertake m) true g) handle x => raise x;
350	(SOME(nle, od), S.add(g, ifs))	(SOME(nle, od),
351		(* gross hack: to prevent further unrolling,
352		* I pretend that the rest is not inside the body *)
353		if inline = F.IH_UNROLL then S.rmv(g, ifs) else S.add(g, ifs))
354	end	end
355	else (NONE, ifs))	else (NONE, ifs))
356	| sv => (NONE, ifs)	| sv => (NONE, ifs)
357	in	in
358	case le	case le
359	of F.RET vs => F.RET((map substval vs) handle x => raise x)	of F.RET vs => cont(m, F.RET(map substval vs) handle x => raise x)
360
361	| F.LET (lvs,le,body) =>	| F.LET (lvs,le,body) =>
362	let fun cassoc le = F.LET(lvs, le, body)	let fun clet () =
363	(* default behavior *)	loop m le
364	fun clet () =	(fn (m,F.RET vs) =>
365	let val nle = loop m le	let fun simplesubst ((lv,v),m) =
366	val nm = foldl (fn (lv,m) => addbind(m, lv, Var(lv, NONE)))	let val sv = (val2sval m v) handle x => raise x
367	m lvs	in substitute(m, lv, sv, sval2val sv)
368	in case loop nm body	end
369		val nm = (foldl simplesubst m (zip(lvs, vs)))
370		in loop nm body cont
371		end
372		| (m,nle) =>
373		let val nm = (foldl (fn (lv,m) =>
374		addbind(m, lv, Var(lv, NONE)))
375		m lvs)
376		in case loop nm body cont
377	of F.RET vs => if vs = (map F.VAR lvs) then nle	of F.RET vs => if vs = (map F.VAR lvs) then nle
378	else F.LET(lvs, nle, F.RET vs)	else F.LET(lvs, nle, F.RET vs)
379	| nbody => F.LET(lvs, nle, nbody)	| nbody => F.LET(lvs, nle, nbody)
380	end	end)
	val lopm = loop m
381	in case le	in case le
382	(* apply let associativity  *)	of F.BRANCH (po,vs,le1,le2) =>
	of F.LET(lvs1,le',le) => lopm(F.LET(lvs1, le', cassoc le))
	| F.FIX(fdecs,le) => lopm(F.FIX(fdecs, cassoc le))
	| F.TFN(tfdec,le) => lopm(F.TFN(tfdec, cassoc le))
	| F.CON(dc,tycs,v,lv,le) => lopm(F.CON(dc, tycs, v, lv, cassoc le))
	| F.RECORD(rk,vs,lv,le) => lopm(F.RECORD(rk, vs, lv, cassoc le))
	| F.SELECT(v,i,lv,le) => lopm(F.SELECT(v, i, lv, cassoc le))
	| F.PRIMOP(po,vs,lv,le) => lopm(F.PRIMOP(po, vs, lv, cassoc le))
383	(* this is a hack originally meant to cleanup the BRANCH mess	(* this is a hack originally meant to cleanup the BRANCH mess
384	* introduced in flintnm (where each branch returns just true or	* introduced in flintnm (where each branch returns just true or
385	* false which is generally only used as input to a SWITCH).	* false which is generally only used as input to a SWITCH).
386	* The present code does slightly more than clean up this case *)	* The present code does slightly more than clean up this case *)
	| F.BRANCH (po,vs,le1,le2) =>
387	let fun known (F.RECORD(_,_,_,le)) = known le	let fun known (F.RECORD(_,_,_,le)) = known le
388	| known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')	| known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')
389	| known (F.RET[F.VAR v]) = false	| known (F.RET[F.VAR v]) = false
390	| known (F.RET[_]) = true	| known (F.RET[_]) = true
391	| known _ = false	| known _ = false
392	fun cassoc (lv,v,body) wrap =	fun cassoc (lv,v,body,wrap) =
393	if lv = v andalso C.usenb lv = 1 andalso	if lv = v andalso C.usenb lv = 1 andalso
394	known le1 andalso known le2 then	known le1 andalso known le2 then
395	(* here I should also check that le1 != le2 *)	(* here I should also check that le1 != le2 *)
#	Line 378	Line 400
400	body	body
401	val nle2 = F.LET([nlv], le2, body2)	val nle2 = F.LET([nlv], le2, body2)
402	in	in
403	lopm(wrap(F.BRANCH(po, vs, nle1, nle2)))	loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont
404	end	end
405	else	else
406	clet()	clet()
407	in case (lvs,body)	in case (lvs,body)
408	of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>	of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
409	cassoc(lv, v, le) (fn x => x)	cassoc(lv, v, le, OU.id)
410	| ([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)) =>
411	cassoc(lv, v, le) (fn le => F.LET(lvs,le,rest))	cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))
412	| _ => clet()	| _ => clet()
413	end	end
414	| F.RET vs =>	| _ => clet()
	let fun simplesubst ((lv,v),m) =
	let val sv = (val2sval m v) handle x => raise x
	in substitute(m, lv, sv, sval2val sv)
	end
	in loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body
	end
	| F.APP(f,vs) => clet()
	(* let-associativity can be annoying here.  I should really use
	* continuation passing style instead.
	* (case inline ifs (f, vs)
	* of (SOME(le,od),ifs) => cexp (d,od) ifs m (F.LET(lvs, le, body))
	*  | (NONE,_) => clet()) *)
	| (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>
	clet()
415	end	end
416
417	| F.FIX (fs,le) =>	| F.FIX (fs,le) =>
#	Line 414	Line 422
422
423	(* The actual function contraction *)	(* The actual function contraction *)
424	fun cfun (m,[]:F.fundec list,acc) = acc	fun cfun (m,[]:F.fundec list,acc) = acc
425	| cfun (m,fdec as (fk,f,args,body)::fs,acc) =	| cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
426	if used f then	if used f then
427	let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)	let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
428	(* make up the bindings for args inside the body *)	(* make up the bindings for args inside the body *)
#	Line 422	Line 430
430	addbind(m, lv, Var(lv, SOME lty))	addbind(m, lv, Var(lv, SOME lty))
431	val nm = foldl addnobind m args	val nm = foldl addnobind m args
432	(* contract the body and create the resulting fundec *)	(* contract the body and create the resulting fundec *)
433	val nbody = cexp cfg (S.add(f, ifs)) nm body	val nbody = cexp cfg (S.add(f, ifs)) nm body #2
434	(* The `inline' bit has to be turned off because	(* The `inline' bit has to be turned off because
435	* it applied to the function before contraction	* it applied to the function before contraction
436	* but might not apply to its new form (inlining might	* but might not apply to its new form (inlining might
437	* have increased its size substantially or made it	* have increased its size substantially or made it
438	* recursive in a different way which could make further	* recursive in a different way which could make further
439	* inlining even dangerous) *)	* inlining even dangerous) *)
440	val nfk =	val nknown = known orelse not(C.escaping f)
441	case fk of F.FK_FCT => fk	val nfk = {isrec=isrec, cconv=cconv,
442	| F.FK_FUN {isrec,fixed,known,inline} =>	inline=F.IH_SAFE, known=nknown}
	let val nknown = known orelse not(C.escaping f)
	in F.FK_FUN{isrec=isrec, fixed=fixed,
	inline=false, known=nknown}
	end
443	(* update the binding in the map.  This step is not	(* update the binding in the map.  This step is not
444	* not just a mere optimization but is necessary	* not just a mere optimization but is necessary
445	* because if we don't do it and the function	* because if we don't do it and the function
#	Line 488	Line 492
492	| ceta (_,(m,hs)) = (m, hs)	| ceta (_,(m,hs)) = (m, hs)
493
494	(* drop constant arguments if possible *)	(* drop constant arguments if possible *)
495	fun dropcstargs (f as (fk,g,args,body):F.fundec,fs) =	fun cstargs (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec) = f
496	case fk	| cstargs (f as (fk,g,args,body):F.fundec) =
	of F.FK_FCT => f::fs (* we can't make inlinable fcts *)
	| F.FK_FUN{inline=true,...} => f::fs (* no use *)
	| fk =>
497	let val cst =	let val cst =
498	ListPair.map	ListPair.map
499	(fn (NONE,_) => false	(fn (NONE,_) => false
#	Line 505	Line 506
506	| _ => true)	| _ => true)
507	(C.actuals g, args)	(C.actuals g, args)
508	(* if all args are used, there's nothing we can do *)	(* if all args are used, there's nothing we can do *)
509	in if List.all not cst then f::fs else	in if List.all not cst then f else
510	let fun newarg lv =	let fun newarg lv =
511	let val nlv = cplv lv in C.new NONE nlv; nlv end	let val nlv = cplv lv in C.new NONE nlv; nlv end
512	fun filter xs = OU.filter(cst, xs)	fun filter xs = OU.filter(cst, xs)
#	Line 519	Line 520
520	F.LET(map #1 (filter args),	F.LET(map #1 (filter args),
521	F.RET(map valOf (filter (C.actuals g))),	F.RET(map valOf (filter (C.actuals g))),
522	body)	body)
523	in (fk,g,nargs,nbody)::fs	in (fk, g, nargs, nbody)
524	end	end
525	end	end
526
527	(* add droparg wrapper to drop dead arguments *)	(* add wrapper for various purposes *)
528	fun dropdeadargs (f as (fk,g,args,body):F.fundec,fs) =	fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
529	case fk	| wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
530	of F.FK_FCT => f::fs (* we can't make inlinable fcts *)	let fun dropargs filter =
531	| F.FK_FUN{inline=true,...} => f::fs (* no use *)	let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
	| fk as F.FK_FUN{isrec,...} =>
	let val used = map (used o #1) args
	(* if all args are used, there's nothing we can do *)
	in if List.all OU.id used then f::fs else
	let fun filter xs = OU.filter(used, xs)
532	val args' = filter args	val args' = filter args
533	val ng = cplv g	val ng = cplv g
534	val nargs = map (fn (v,t) => (cplv v, t)) args	val nargs = map (fn (v,t) => (cplv v, t)) args
535	val nargs' = map #1 (filter nargs)	val nargs' = map #1 (filter nargs)
536	val appargs = (map F.VAR nargs')	val appargs = (map F.VAR nargs')
537		val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))
	val _ = C.new (SOME(map #1 args')) ng
	val _ = C.use (SOME appargs) ng
	val _ = app ((C.new NONE) o #1) nargs
	val _ = app (C.use NONE) nargs'
	val (nfk,nfk') = OU.fk_wrap(fk, isrec)
	val nf = (nfk, g, nargs,
	F.APP(F.VAR ng, appargs))
538	val nf' = (nfk', ng, args', body)	val nf' = (nfk', ng, args', body)
539	in nf'::nf::fs	in
540		C.new (SOME(map #1 args')) ng;
541		C.use (SOME appargs) ng;
542		app ((C.new NONE) o #1) nargs;
543		app (C.use NONE) nargs';
544		nf'::nf::fs
545	end	end
546		val used = map (used o #1) args
547		in
548		(* if some args are not used, let's drop them *)
549		if not (List.all OU.id used) then
550		dropargs (fn xs => OU.filter(used, xs))
551
552		(* eta-split: add a wrapper for escaping uses *)
553		else if C.escaping g andalso C.called g then
554		(* like dropargs but keeping all args *)
555		dropargs OU.id
556
557		else f::fs
558	end	end
559
560	(* add wrappers to drop unused arguments *)	(* redirect cst args to their source value *)
561	val fs = foldl dropcstargs [] fs	val fs = map cstargs fs
562
563	(* add wrappers to drop unused arguments *)	(* add various wrappers *)
564	val fs = foldl dropdeadargs [] fs	val fs = foldl wrap [] fs
565
566	(* register the new bindings (uncontracted for now) *)	(* register the new bindings (uncontracted for now) *)
567	val nm = foldl (fn (fdec as (fk,f,args,body),m) =>	val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
#	Line 567	Line 572
572
573	(* move the inlinable functions to the end of the list *)	(* move the inlinable functions to the end of the list *)
574	val (f1s,f2s) =	val (f1s,f2s) =
575	List.partition (fn (F.FK_FUN{inline,...},_,_,_) => inline	List.partition (fn ({inline=F.IH_ALWAYS,...},_,_,_) => true
576	| _ => false) fs	| _ => false) fs
577	val fs = f2s @ f1s	val fs = f2s @ f1s
578
579	(* contract the main body *)	(* contract the main body *)
580	val nle = loop nm le	val nle = loop nm le cont
581	(* contract the functions *)	(* contract the functions *)
582	val fs = cfun(nm, fs, [])	val fs = cfun(nm, fs, [])
583	(* junk newly unused funs *)	(* junk newly unused funs *)
#	Line 580	Line 585
585	in	in
586	case fs	case fs
587	of [] => nle	of [] => nle
588	| [f1 as (F.FK_FUN{isrec=NONE,...},f,args,F.APP _),f2] =>	| [f1 as ({isrec=NONE,...},_,_,_),f2] =>
589	(* gross hack: dropargs might have added a second	(* gross hack: dropargs might have added a second
590	* non-recursive function.  we need to split them into	* non-recursive function.  we need to split them into
591	* 2 FIXes.  This is very ad-hoc *)	* 2 FIXes.  This is _very_ ad-hoc *)
592	F.FIX([f2], F.FIX([f1], nle))	F.FIX([f2], F.FIX([f1], nle))
	| (F.FK_FUN{isrec=NONE,...},f,args,body)::_::_ =>
	bug "gross hack failed"
593	| _ => F.FIX(fs, nle)	| _ => F.FIX(fs, nle)
594	end	end
595
596	| F.APP (f,vs) =>	| F.APP (f,vs) =>
597	let val nvs = ((map substval vs) handle x => raise x)	let val nvs = ((map substval vs) handle x => raise x)
598	in case inline ifs (f, nvs)	in case inline ifs (f, nvs)
599	of (SOME(le,od),ifs) => cexp (d,od) ifs m le	of (SOME(le,od),nifs) => cexp (d,od) ifs m le cont
600	| (NONE,_) => F.APP((substval f) handle x => raise x, nvs)	| (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))
601	end	end
602
603	| F.TFN ((f,args,body),le) =>	| F.TFN ((f,args,body),le) =>
604	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 #2
605	val nm = addbind(m, f, TFun(f, nbody, args, od))	val nm = addbind(m, f, TFun(f, nbody, args, od))
606	val nle = loop nm le	val nle = loop nm le cont
607	in	in
608	if used f then F.TFN((f, args, nbody), nle) else nle	if used f then F.TFN((f, args, nbody), nle) else nle
609	end	end
610
611	| F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)	| F.TAPP(f,tycs) =>
612		cont(m, F.TAPP((substval f) handle x => raise x, tycs))
613
614	| F.SWITCH (v,ac,arms,def) =>	| F.SWITCH (v,ac,arms,def) =>
615	(case ((val2sval m v) handle x => raise x)	(case ((val2sval m v) handle x => raise x)
#	Line 627	Line 631
631	*   other opt-opportunities since it hides the	*   other opt-opportunities since it hides the
632	*   previous binding. *)	*   previous binding. *)
633	val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))	val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))
634	in (F.DATAcon(ndc, tycs, lv), loop nm le)	in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
635	end	end
636	| carm (con,le) = (con, loop m le)	| carm (con,le) = (con, loop m le #2)
637	val narms = map carm arms	val narms = map carm arms
638	val ndef = Option.map (loop m) def	val ndef = Option.map (fn le => loop m le #2) def
639	in	in
640	F.SWITCH(sval2val sv, ac, narms, ndef)	cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
641	end	end
642
643	| Con (lvc,v,dc1,tycs1) =>	| Con (lvc,v,dc1,tycs1) =>
#	Line 647	Line 651
651	if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then	if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
652	(map killarm tl; (* kill the rest *)	(map killarm tl; (* kill the rest *)
653	Option.map killle def; (* and the default case *)	Option.map killle def; (* and the default case *)
654	loop (substitute(m, lv, val2sval m v, F.VAR lvc)) le)	loop (substitute(m, lv, val2sval m v, F.VAR lvc))
655		le cont)
656	else	else
657	(* kill this arm and continue with the rest *)	(* kill this arm and continue with the rest *)
658	(kill lv le; carm tl)	(kill lv le; carm tl)
659	| carm [] = loop m (Option.valOf def)	| carm [] = loop m (Option.valOf def) cont
660	| carm _ = buglexp("unexpected arm in switch(con,...)", le)	| carm _ = buglexp("unexpected arm in switch(con,...)", le)
661	in carm arms	in carm arms
662	end	end
#	Line 660	Line 665
665	let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x	let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
666	fun carm ((con,le)::tl) =	fun carm ((con,le)::tl) =
667	if eqConV(con, v) then	if eqConV(con, v) then
668	(map (kill o #2) tl; Option.map kill def; loop m le)	(map (kill o #2) tl;
669		Option.map kill def;
670		loop m le cont)
671	else (kill le; carm tl)	else (kill le; carm tl)
672	| carm [] = loop m (Option.valOf def)	| carm [] = loop m (Option.valOf def) cont
673	in carm arms	in carm arms
674	end	end
675	| sv as (Fun _ | TFun _) =>	| sv as (Fun _ | TFun _) =>
#	Line 673	Line 680
680	fun ccon sv =	fun ccon sv =
681	let val nv = sval2val sv	let val nv = sval2val sv
682	val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))	val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))
683	val nle = loop nm le	val nle = loop nm le cont
684	in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle	in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle
685	end	end
686	in case ((val2sval m v) handle x => raise x)	in case ((val2sval m v) handle x => raise x)
687	of sv as (Decon (lvd,vc,dc2,tycs2)) =>	of sv as (Decon (lvd,vc,dc2,tycs2)) =>
688	if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then	if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
689	let val sv = (val2sval m vc) handle x => raise x	let val sv = (val2sval m vc) handle x => raise x
690	in loop (substitute(m, lv, sv, F.VAR lvd)) le	in loop (substitute(m, lv, sv, F.VAR lvd)) le cont
691	end	end
692	else ccon sv	else ccon sv
693	| sv => ccon sv	| sv => ccon sv
#	Line 711	Line 718
718	in case g (0,svs)	in case g (0,svs)
719	of SOME v =>	of SOME v =>
720	let val sv = (val2sval m v) handle x => raise x	let val sv = (val2sval m v) handle x => raise x
721	in loop (substitute(m, lv, sv, F.INT 0)) le	in loop (substitute(m, lv, sv, F.INT 0)) le cont
722	before app (unuseval (undertake m)) vs	before app (unuseval (undertake m)) vs
723	end	end
724	| _ =>	| _ =>
725	let val nvs = map sval2val svs	let val nvs = map sval2val svs
726	val nm = addbind(m, lv, Record(lv, nvs))	val nm = addbind(m, lv, Record(lv, nvs))
727	val nle = loop nm le	val nle = loop nm le cont
728	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
729	end	end
730	end	end
#	Line 726	Line 733
733	(case ((val2sval m v) handle x => raise x)	(case ((val2sval m v) handle x => raise x)
734	of Record (lvr,vs) =>	of Record (lvr,vs) =>
735	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
736	in loop (substitute(m, lv, sv, F.VAR lvr)) le	in loop (substitute(m, lv, sv, F.VAR lvr)) le cont
737	end	end
738	| sv =>	| sv =>
739	let val nv = sval2val sv	let val nv = sval2val sv
740	val nm = addbind (m, lv, Select(lv, nv, i))	val nm = addbind (m, lv, Select(lv, nv, i))
741	val nle = loop nm le	val nle = loop nm le cont
742	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
743	end)	end)
744
745	| F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)	| F.RAISE (v,ltys) =>
746		cont(m, F.RAISE((substval v) handle x => raise x, ltys))
747
748	| F.HANDLE (le,v) => F.HANDLE(loop m le, (substval v) handle x => raise x)	| F.HANDLE (le,v) =>
749		cont(m, F.HANDLE(loop m le #2, (substval v) handle x => raise x))
750
751	| F.BRANCH (po,vs,le1,le2) =>	| F.BRANCH (po,vs,le1,le2) =>
752	let 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 nle1 = loop m le1	val nle1 = loop m le1 #2
755	val nle2 = loop m le2	val nle2 = loop m le2 #2
756	in F.BRANCH(npo, nvs, nle1, nle2)	in cont(m, F.BRANCH(npo, nvs, nle1, nle2))
757	end	end
758
759	| F.PRIMOP (po,vs,lv,le) =>	| F.PRIMOP (po,vs,lv,le) =>
#	Line 752	Line 761
761	val nvs = ((map substval vs) handle x => raise x)	val nvs = ((map substval vs) handle x => raise x)
762	val npo = cpo po	val npo = cpo po
763	val nm = addbind(m, lv, Var(lv,NONE))	val nm = addbind(m, lv, Var(lv,NONE))
764	val nle = loop nm le	val nle = loop nm le cont
765	in	in
766	if impure orelse used lv	if impure orelse used lv
767	then F.PRIMOP(npo, nvs, lv, nle)	then F.PRIMOP(npo, nvs, lv, nle)
#	Line 762	Line 771
771
772	fun contract (fdec as (_,f,_,_)) =	fun contract (fdec as (_,f,_,_)) =
773	((*  C.collect fdec; *)	((*  C.collect fdec; *)
774	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
775		M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
776	of F.FIX([fdec], F.RET[F.VAR f]) => fdec	of F.FIX([fdec], F.RET[F.VAR f]) => fdec
777	| fdec => bug "invalid return fundec")	| fdec => bug "invalid return fundec")
778

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.183   changed lines   Added in v.184

---

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