Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 200 - (download) (annotate)
Sat Nov 28 17:48:03 1998 UTC (22 years ago) by monnier
File size: 35191 byte(s)
* opt/fcontract.sml: generalized the BRANCH thing.
It should now be faster to detect and avoid potential code blowups while
applying to more cases.  But it requires one more pass to generate the
same code quality :-(
(* copyright 1998 YALE FLINT PROJECT *)
(* monnier@cs.yale.edu *)

signature FCONTRACT =
    (* needs Collect to be setup properly *)
    val contract : FLINT.prog * Stats.counter -> FLINT.prog

(* All kinds of beta-reductions.  In order to do as much work per pass as
 * possible, the usage counts of each variable (maintained by the Collect
 * module) is kept as much uptodate as possible.  For instance as soon as a
 * variable becomes dead, all the variables that were referenced have their
 * usage counts decremented correspondingly.  This means that we have to
 * be careful to make sure that a dead variable will indeed not appear
 * in the output lexp since it might else reference other dead variables *)

(* things that fcontract does:
 * - several things not mentioned
 * - elimination of Con(Decon x)
 * - update counts when selecting a SWITCH alternative
 * - contracting RECORD(R.1,R.2) => R  (only if the type is easily available)
 * - dropping of dead arguments

(* things that lcontract.sml does that fcontract doesn't do (yet):
 * - inline across DeBruijn depths (will be solved by named-tvar)
 * - elimination of let [dead-vs] = pure in body

(* things that cpsopt/eta.sml did that fcontract doesn't do:
 * - let f vs = select(v,i,g,g vs)

(* things that cpsopt/contract.sml did that fcontract doesn't do:
 * - IF-idiom (I still don't know what it is)
 * - unifying branches
 * - Handler operations
 * - primops expressions
 * - branch expressions

(* things that could also be added:
 * - elimination of dead vars in let
 * - elimination of constant arguments

(* things that would require some type info:
 * - dropping foo in LET vs = RAISE v IN foo

(* eta-reduction is tricky:
 * - recognition of eta-redexes and introduction of the corresponding
 *   substitution in the table has to be done at the very beginning of
 *   the processing of the FIX
 * - eta-reduction can turn a known function into an escaping function
 * - fun f (g,v2,v3) = g(g,v2,v3) looks tremendously like an eta-redex

(* order of contraction is important:
 * - the body of a FIX is contracted before the functions because the
 *   functions might end up being inlined in the body in which case they
 *   could be contracted twice.

(* When creating substitution f->g (as happens with eta redexes or with
 * code like `LET [f] = RET[g]'), we need to make sure that the usage cout
 * of f gets properly transfered to g.  One way to do that is to make the
 * transfer incremental:  each time we apply the substitution, we decrement
 * f's count and increment g's count.  But this can be tricky since the
 * elimination of the eta-redex (or the trivial binding) eliminates one of the
 * references to g and if this is the only one, we might trigger the killing
 * of g even though its count would be later incremented.  Similarly, inlining
 * of g would be dangerous as long as some references to f exist.
 * So instead we do the transfer once and for all when we see the eta-redex,
 * which frees us from those two problems but forces us to make sure that
 * every existing reference to f will be substituted with g.
 * Also, the transfer of counts from f to g is not quite straightforward
 * since some of the references to f might be from inside g and without doing
 * the transfer incrementally, we can't easily know which of the usage counts
 * of f should be transfered to the internal counts of g and which to the
 * external counts.

(* Preventing infinite inlining:
 * - inlining a function in its own body amounts to unrolling which has
 *   to be controlled (you only want to unroll some number of times).
 *   It's currently simply not allowed.
 * - inlining a recursive function outside of tis body amounts to `peeling'
 *   one iteration. Here also, since the inlined body will have yet another
 *   call, the inlining risks non-termination.  It's hence also
 *   not allowed.
 * - inlining a mutually recursive function is just a more general form
 *   of the problem above although it can be safe and desirable in some cases.
 *   To be safe, you simply need that one of the functions forming the
 *   mutual-recursion loop cannot be inlined (to break the loop).  This cannot
 *   be trivially checked.  So we (foolishly?) trust the `inline' bit in
 *   those cases.  This is mostly used to inline wrappers inside the
 *   function they wrap.
 * - even if one only allows inlining of funtions showing no sign of
 *   recursion, we can be bitten by a program creating its own Y combinator:
 *       datatype dt = F of dt -> int -> int
 *       let fun f (F g) x = g (F g) x in f (F f) end
 *   To solve this problem, `cexp' has an `ifs' parameter containing the set
 *   of funtions that we are inlining in order to detect (and break) cycles.
 * - funnily enough, if we allow inlining recursive functions the cycle
 *   detection will ensure that the unrolling (or peeling) will only be done
 *   once.  In the future, maybe.

(* Dropping useless arguments.
 * Arguments whose value is constant (i.e. the function is known and each
 * call site provides the same value for that argument (or the argument
 * itself in the case of recursive calls) can be safely removed and replaced
 * inside the body by a simple let binding.  The only problem is that the
 * constant argument might be out of scope at the function definition site.
 * It is obviously always possible to move the function to bring the argument
 * in scope, but since we don't do any code motion here, we're stuck.
 * If it wasn't for this little problem, we could do the cst-arg removal in
 * collect (we don't gain anything from doing it here).
 * The removal of dead arguments (args not used in the body) on the other
 * hand can quite well be done in collect, the only problem being that it
 * is convenient to do it after the cst-arg removal so that we can rely
 * on deadarg to do the actual removal of the cst-arg.

(* Simple inlining (inlining called-once functions, which doesn't require
 * alpha-renaming) seems inoffensive enough but is not always desirable.
 * The typical example is wrapper functions introduced by eta-expand: they
 * usually (until inlined) contain the only call to the main function,
 * but inlining the main function in the wrapper defeats the purpose of the
 * wrapper.
 * cpsopt dealt with this problem by adding a `NO_INLINE_INTO' hint to the
 * wrapper function.  In this file, the idea is the following:
 * If you have a function declaration like `let f x = body in exp', first
 * contract `exp' and only contract `body' afterwards.  This ensures that
 * the eta-wrapper gets a chance to be inlined before it is (potentially)
 * eta-reduced away.  Interesting details:
 * - all functions (even the ones that would have a `NO_INLINE_INTO') are
 *   contracted, because the "aggressive usage count maintenance" makes any
 *   alternative painful (the collect phase has already assumed that dead code
 *   will be eliminated, which means that fcontract should at the very least
 *   do the dead-code elimination, so you can only avoid fcontracting a
 *   a function if you can be sure that the body doesn't contain any dead-code,
 *   which is generally  not known).
 * - once a function is fcontracted, its inlinable status is re-examined.
 *   More specifically, if no inlining occured during its fcontraction, then
 *   we assume that the code has just become smaller and should hence
 *   still be considered inlinable.  On another hand, if inlining took place,
 *   then we have to reset the inline-bit because the new body might
 *   be completely different (i.e. much bigger) and inlining it might be
 *   undesirable.
 *   This means that in the case of
 *       let fwrap x = body1 and f y = body2 in exp
 *   if fwrap is fcontracted before f and something gets inlined into it,
 *   then fwrap cannot be inlined in f.
 *   To minimize the impact of this problem, we make sure that we fcontract
 *   inlinable functions only after fcontracting other mutually recursive
 *   functions.  One way to solve the problem more thoroughly would be
 *   to keep the uncontracted fwrap around until f has been contracted.
 *   Such a trick hasn't seemed necessary yet.
 * - at the very end of the optimization phase, cpsopt had a special pass
 *   that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
 *   into it doesn't have any undesirable side effects any more).  The present
 *   code doesn't need such a thing.  On another hand, the cpsopt approach
 *   had the advantage of keeping the `inline' bit from one contract phase to
 *   the next.  If this ends up being important, one could add a global
 *   "noinline" flag that could be set to true whenever fcontracting an
 *   inlinable function (this would ensure that fcontracting such an inlinable
 *   function can only reduce its size, which would allow keeping the `inline'
 *   bit set after fcontracting).

structure FContract :> FCONTRACT =
    structure F  = FLINT
    structure M  = IntmapF
    structure S  = IntSetF
    structure C  = Collect
    structure O  = Option
    structure DI = DebIndex
    structure PP = PPFlint
    structure FU = FlintUtil
    structure LT = LtyExtern
    structure LK = LtyKernel
    structure OU = OptUtils
    structure CTRL = Control.FLINT

val say = Control.Print.say
fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)

(* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)

val cplv = LambdaVar.dupLvar
val mklv = LambdaVar.mkLvar

datatype sval
  = Val    of F.value			(* F.value should never be F.VAR lv *)
  | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind
  | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list
  | Record of F.lvar * sval list
  | Con    of F.lvar * sval * F.dcon * F.tyc list
  | Decon  of F.lvar * sval * F.dcon * F.tyc list
  | Select of F.lvar * sval * int
  | Var    of F.lvar * F.lty option	(* cop out case *)

fun sval2lty (Var(_,x)) = x
  | sval2lty (Decon(_,_,(_,_,lty),tycs)) =
    SOME(hd(#2 (LT.ltd_arrow (hd(LT.lt_inst(lty, tycs))))))
  | sval2lty (Select(_,sv,i)) =
    (case sval2lty sv of SOME lty => SOME(LT.lt_select(lty, i)) | _ => NONE)
  | sval2lty _ = NONE

fun tycs_eq ([],[]) = true
  | tycs_eq (tyc1::tycs1,tyc2::tycs2) =
    LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
  | tycs_eq _ = false

(* calls `code' to append a lexp to each leaf of `le'.
 * Typically used to transform `let lvs = le in code' so that
 * `code' is now copied at the end of each branch of `le'.
 * `lvs' is a list of lvars that should be used if the result of `le'
 * needs to be bound before calling `code'. *)
fun append lvs code le =
    let fun l (F.RET vs) = code vs
	  | l (le as (F.APP _ | F.TAPP _ | F.RAISE _ | F.HANDLE _)) =
	    let val lvs = map (fn lv => let val nlv = cplv lv
	                                in C.new NONE nlv; nlv end)
	    in F.LET(lvs, le, code(map F.VAR lvs))
	  | l (F.LET (lvs,body,le)) = F.LET(lvs,body, l le)
	  | l (F.FIX (fdecs,le)) = F.FIX(fdecs, l le)
	  | l (F.TFN (tfdec,le)) = F.TFN(tfdec, l le)
	  | l (F.SWITCH (v,ac,arms,def)) =
	    let fun larm (con,le) = (con, l le)
	    in F.SWITCH(v, ac, map larm arms, O.map l def)
	  | l (F.CON (dc,tycs,v,lv,le)) = F.CON(dc, tycs, v, lv, l le)
	  | l (F.RECORD (rk,vs,lv,le)) = F.RECORD(rk, vs, lv, l le)
	  | l (F.SELECT (v,i,lv,le)) = F.SELECT(v, i, lv, l le)
	  | l (F.BRANCH (po,vs,le1,le2)) = F.BRANCH(po, vs, l le1, l le2)
	  | l (F.PRIMOP (po,vs,lv,le)) = F.PRIMOP(po, vs, lv, l le)
    in l le

fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)

(*  val c_inline	 = Stats.newCounter[] *)
(*  val c_deadval	 = Stats.newCounter[] *)
(*  val c_deadlexp	 = Stats.newCounter[] *)
(*  val c_select	 = Stats.newCounter[] *)
(*  val c_record	 = Stats.newCounter[] *)
(*  val c_lacktype	 = Stats.newCounter[] *)
(*  val c_con	 = Stats.newCounter[] *)
(*  val c_switch	 = Stats.newCounter[] *)
(*  val c_eta	 = Stats.newCounter[] *)
(*  val c_etasplit	 = Stats.newCounter[] *)
(*  val c_branch	 = Stats.newCounter[] *)
(*  val c_dropargs	 = Stats.newCounter[] *)

fun contract (fdec as (_,f,_,_), counter) = let

    val c_dummy = Stats.newCounter[]
    val c_miss = Stats.newCounter[]

    fun click_deadval  () = (click "d" counter)
    fun click_deadlexp () = (click "D" counter)
    fun click_select   () = (click "s" counter)
    fun click_record   () = (click "r" counter)
    fun click_con      () = (click "c" counter)
    fun click_switch   () = (click "s" counter)
    fun click_eta      () = (click "e" counter)
    fun click_etasplit () = (click "E" counter)
    fun click_branch   () = (click "b" counter)
    fun click_dropargs () = (click "a" counter)

    fun click_lacktype () = (click "t" c_miss)

    (* this counters is actually *used* by fcontract.
     * It's  not used just for statistics. *)
    val c_inline	 = Stats.newCounter[counter]
(*      val c_inline1	 = Stats.newCounter[c_inline] *)
(*      val c_inline2	 = Stats.newCounter[c_inline] *)
(*      val c_unroll	 = Stats.newCounter[c_inline] *)
    fun click_simpleinline () = (click "i" c_inline)
    fun click_copyinline   () = (click "I" c_inline)
    fun click_unroll       () = (click "u" c_inline)
    fun inline_count () = Stats.getCounter c_inline

    fun used lv = (C.usenb(C.get lv) > 0)
		      (* handle x =>
		      (say("while in FContract.used "^(C.LVarString lv)^"\n");
		       raise x) *)
    fun impurePO po = true		(* if a PrimOP is pure or not *)

    fun eqConV (F.INTcon i1,	F.INT i2)	= i1 = i2
      | eqConV (F.INT32con i1,	F.INT32 i2)	= i1 = i2
      | eqConV (F.WORDcon i1,	F.WORD i2)	= i1 = i2
      | eqConV (F.WORD32con i1,	F.WORD32 i2)	= i1 = i2
      | eqConV (F.REALcon r1,	F.REAL r2)	= r1 = r2
      | eqConV (F.STRINGcon s1,	F.STRING s2)	= s1 = s2
      | eqConV (con,v) = bugval("unexpected comparison with val", v)

    fun lookup m lv = (M.lookup m lv)
			  (* handle e as M.IntmapF =>
			  (say "\nlooking up unbound ";
			   say (!PP.LVarString lv);
			   raise e) *)

    fun sval2val sv =
	case sv
	 of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} | Decon{1=lv,...}
	  | Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
	  | Val v => v
    fun val2sval m (F.VAR ov) = 
	((lookup m ov) (* handle x =>
	 (say("val2sval "^(C.LVarString ov)^"\n"); raise x) *) )
      | val2sval m v = Val v

    fun bugsv (msg,sv) = bugval(msg, sval2val sv)

    fun subst m ov = sval2val (lookup m ov)
    fun substval m = sval2val o (val2sval m)
    fun substvar m lv =
	case substval m (F.VAR lv)
	 of F.VAR lv => lv
	  | v => bugval ("unexpected val", v)

    (* called when a variable becomes dead.
     * it simply adjusts the use-counts *)
    fun undertake m lv =
	let val undertake = undertake m
	in case lookup m lv
	    of Var {1=nlv,...}	 => ()
	     | Val v		 => ()
	     | Fun (lv,le,args,_) =>
	       C.unuselexp undertake
			   (F.LET(map #1 args,
				  F.RET (map (fn _ => F.INT 0) args),
	     | TFun{1=lv,2=le,...} =>
	       C.unuselexp undertake le
	     | (Select {2=sv,...} | Con {2=sv,...}) => unusesval m sv
	     | Record {2=svs,...} => app (unusesval m) svs
	     (* decon's are implicit so we can't get rid of them *)
	     | Decon _ => ()
		handle M.IntmapF =>
		(say("Unable to undertake "^(C.LVarString lv)^"\n"))
		     | x =>
		       (say("while undertaking "^(C.LVarString lv)^"\n"); raise x)

    and unusesval m sv = unuseval m (sval2val sv)
    and unuseval m (F.VAR lv) =
	if (C.unuse false (C.get lv)) then undertake m lv else ()
      | unuseval f _ = ()
    fun unusecall m lv = 
	if (C.unuse true (C.get lv)) then undertake m lv else ()

    fun addbind (m,lv,sv) = M.add(m, lv, sv)

    (* substitute a value sv for a variable lv and unuse value v. *)
    fun substitute (m, lv1, sv, v) =
	(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
	 unuseval m v;
	 addbind(m, lv1, sv)) (* handle x =>
	     (say ("while substituting "^
		   (C.LVarString lv1)^
		   " -> ");
	      PP.printSval (sval2val sv);
	      raise x) *)

    (* common code for primops *)
    fun cpo m (SOME{default,table},po,lty,tycs) =
	(SOME{default=substvar m default,
	      table=map (fn (tycs,lv) => (tycs, substvar m lv)) table},
      | cpo _ po = po

    fun cdcon m (s,Access.EXN(Access.LVAR lv),lty) =
	(s, Access.EXN(Access.LVAR(substvar m lv)), lty)
      | cdcon _ dc = dc

(* cfg: is used for deBruijn renumbering when inlining at different depths
 * ifs (inlined functions): records which functions we're currently inlining
 *     in order to detect loops
 * m: is a map lvars to their defining expressions (svals) *)
fun cexp ifs m le cont = let
    val loop = cexp ifs
    val substval = substval m
    val cdcon = cdcon m
    val cpo = cpo m
in case le
     of F.RET vs => cont(m, F.RET(map substval vs))

      | F.LET (lvs,le,body) =>
	let fun k (nm,nle) =
		let fun cbody () =
			let val nm = (foldl (fn (lv,m) =>
					     addbind(m, lv, Var(lv, NONE)))
					    nm lvs)
			in case loop nm body cont
			    of F.RET vs => if vs = (map F.VAR lvs) then nle
					   else F.LET(lvs, nle, F.RET vs)
			     | nbody => F.LET(lvs, nle, nbody)
		in case nle
		    of F.RET vs =>
		       let fun simplesubst (lv,v,m) =
			       let val sv = val2sval m v
			       in substitute(m, lv, sv, sval2val sv)
			   val nm = (ListPair.foldl simplesubst nm (lvs, vs))
		       in loop nm body cont
		     | _ => cbody()
	    fun clet () = loop m le k
	in case le
	    of (F.BRANCH _ | F.SWITCH _) =>
	       (* this is a hack originally meant to cleanup the BRANCH mess
		* introduced in flintnm (where each branch returns just true or
		* false which is generally only used as input to a SWITCH).
		* The present code does slightly more than clean up this case *)
	       (* As it stands, the code has at least 2 serious shortcomings:
		* 1 - it applies to the code before fcontraction
		* 2 - the SWITCH copied into each arm doesn't get reduced
		*     early, so the inlining that should happen cannot
		*     take place because by the time we know that the function
		*     is a simple-inline candidate, fcontract already processed
		*     the call *)

	       (* `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,
		       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))
			 | con =>
			   let val _ = C.new (SOME[]) f
			   in ((con, F.APP(F.VAR f, [])),
			       (fk, f, [], le))
		   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
			   let val (narms,fdecs) =
				   ListPair.unzip (map extract arms)
			       fun addswitch [v] =
				   C.copylexp IntmapF.empty
				 | addswitch _ = bug "Wrong number of values"
			       (* replace each leaf `ret' with a copy
				* of the switch *)
			       val nle = append [lv] addswitch le
			       (* decorate with the functions extracted out
				* of the switch arms *)
			       val nle = foldl (fn (f,le) => F.FIX([f],le))
					       (wrap nle) fdecs
			       (* Ugly hack to alleviate problem 2 mentioned
				* above: we go through the code twice *)
			       val nle = loop m nle #2
			   in  click_branch();
			       loop m nle cont
 	       in case (lvs,body)
 		   of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
 		      cassoc(lv, le, fn x => x)
 		    | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
 		      cassoc(lv, le, fn le => F.LET(lvs,le,rest))
 		    | _ => clet()
	     | _ => clet()

      | F.FIX (fs,le) =>
	let (* The actual function contraction *)
	    fun cfun (m,[]:F.fundec list,acc) = acc
	      | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
		let val fi = C.get f
		in if C.dead fi then cfun(m, fs, acc)
		   else if C.iusenb fi = C.usenb fi then
		       (* we need to be careful that undertake not be called
			* recursively *)
		       (C.use NONE fi; undertake m f; cfun(m, fs, acc))
		    let (*  val _ = say ("\nEntering "^(C.LVarString f)) *)
			val saved_ic = inline_count()
			(* make up the bindings for args inside the body *)
			fun addnobind ((lv,lty),m) =
			    addbind(m, lv, Var(lv, SOME lty))
			val nm = foldl addnobind m args
			(* contract the body and create the resulting fundec *)
			val nbody = cexp (S.add(f, ifs)) nm body #2
			(* if inlining took place, the body might be completely
			 * changed (read: bigger), so we have to reset the
			 * `inline' bit *)
			val nfk = {isrec=isrec, cconv=cconv,
				   known=known orelse not(C.escaping fi),
				   inline=if inline_count() = saved_ic
					  then inline
					  else F.IH_SAFE}
			(* update the binding in the map.  This step is
			 * not just a mere optimization but is necessary
			 * because if we don't do it and the function
			 * gets inlined afterwards, the counts will reflect the
			 * new contracted code while we'll be working on the
			 * the old uncontracted code *)
			val nm = addbind(m, f, Fun(f, nbody, args, nfk))
		    in cfun(nm, fs, (nfk, f, args, nbody)::acc)
			   (*  before say ("\nExiting "^(C.LVarString f)) *)

	    (* check for eta redex *)
	    fun ceta (fdec as (fk,f,args,F.APP(F.VAR g,vs)):F.fundec,
		      (m,fs,hs)) =
		if List.length args = List.length vs andalso
		    OU.ListPair_all (fn (v,(lv,t)) =>
				     case v of F.VAR v => v = lv andalso lv <> g
					     | _ => false)
				    (vs, args)
		    let val svg = lookup m g
			val g = case sval2val svg
				 of F.VAR g => g
				  | v => bugval("not a variable", v)
		    (* NOTE: we don't want to turn a known function into an
		     * escaping one.  It's dangerous for optimisations based
		     * on known functions (elimination of dead args, f.ex)
		     * and could generate cases where call>use in collect *)
		    in if (C.escaping(C.get f)) andalso not(C.escaping(C.get g))
		       (* the default case could ensure the inline *)
		       then (m, fdec::fs, hs)
		       else let
			   (* if an earlier function h has been eta-reduced
			    * to f, we have to be careful to update its
			    * binding to not refer to f any more since f
			    * will disappear *)
			   val nm = foldl (fn (h,m) =>
					   if sval2val(lookup m h) = F.VAR f
					   then addbind(m, h, svg) else m)
					  m hs
			   (* I could almost reuse `substitute' but the
			    * unuse in substitute assumes the val is escaping *)
			   C.transfer(f, g);
			   unusecall m g;
			   (addbind(m, f, svg), fs, f::hs)
		else (m, fdec::fs, hs)
	      | ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)

	    (* add wrapper for various purposes *)
	    fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
	      | wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
		let val gi = C.get g
		    fun dropargs filter =
			let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
			    val args' = filter args
			    val ng = cplv g
			    val nargs = map (fn (v,t) => (cplv v, t)) args
			    val nargs' = map #1 (filter nargs)
			    val appargs = (map F.VAR nargs')
			    val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))
			    val nf' = (nfk', ng, args', body)

			    val ngi = C.new (SOME(map #1 args')) ng
			    C.ireset gi;
			    app (ignore o (C.new NONE) o #1) nargs;
			    C.use (SOME appargs) ngi;
			    app (C.use NONE o C.get) nargs';
		    (* Don't introduce wrappers for escaping-only functions.
		     * This is debatable since although wrappers are useless
		     * on escaping-only functions, some of the escaping uses
		     * might turn into calls in the course of fcontract, so
		     * by not introducing wrappers here, we avoid useless work
		     * but we also postpone useful work to later invocations. *)
		    if C.dead gi then fs else
			let val used = map (used o #1) args
			in if C.called gi then
			    (* if some args are not used, let's drop them *)
			    if not (List.all (fn x => x) used) then
				 dropargs (fn xs => OU.filter(used, xs)))
			    (* eta-split: add a wrapper for escaping uses *)
			    else if C.escaping gi then
				(* like dropargs but keeping all args *)
				(click_etasplit(); dropargs (fn x => x))
			    else f::fs
			   else f::fs

	    (* add various wrappers *)
	    val fs = foldl wrap [] fs

	    (* register the new bindings (uncontracted for now) *)
	    val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
			    addbind(m, f, Fun(f, body, args, fk)))
			   m fs
	    (* check for eta redexes *)
	    val (nm,fs,_) = foldl ceta (nm,[],[]) fs

	    (* move the inlinable functions to the end of the list *)
	    val (f1s,f2s) =
		List.partition (fn ({inline=F.IH_ALWAYS,...},_,_,_) => true
				 | _ => false) fs
	    val fs = f2s @ f1s

	    (* contract the main body *)
	    val nle = loop nm le cont
	    (* contract the functions *)
	    val fs = cfun(nm, fs, [])
	    (* junk newly unused funs *)
	    val fs = List.filter (used o #2) fs
	    case fs
	     of [] => nle
	      | [f1 as ({isrec=NONE,...},_,_,_),f2] =>
		(* gross hack: `wrap' might have added a second
		 * non-recursive function.  we need to split them into
		 * 2 FIXes.  This is _very_ ad-hoc *)
		F.FIX([f2], F.FIX([f1], nle))
	      | _ => F.FIX(fs, nle)
      | F.APP (f,vs) =>
	let val nvs = map substval vs
	    val svf = val2sval m f
	(* F.APP inlining (if any) *)
	in case svf
	    of Fun(g,body,args,{inline,...}) =>
	       if (C.usenb(C.get g)) = 1 andalso not(S.member ifs g) then
		   (* simple inlining:  we should copy the body and then
		    * kill the function, but instead we just move the body
		    * and kill only the function name.
		    * This inlining strategy looks inoffensive enough,
		    * but still requires some care: see comments at the
		    * begining of this file and in cfun *)
		    ignore(C.unuse true (C.get g));
		    loop m (F.LET(map #1 args, F.RET vs, body)) cont)
	       (* aggressive (but safe) inlining.  We allow pretty much
		* any inlinling, but we detect and reject inlining
		* recursively which would else lead to infinite loop *)
	       (* unrolling is not as straightforward as it seems:
		* if you inline the function you're currently
		* fcontracting, you're asking for trouble: there is a
		* hidden assumption in the counting that the old code
		* will be replaced by the new code (and is hence dead).
		* If the function to be unrolled has the only call to
		* function f, then f might get simpleinlined before
		* unrolling, which means that unrolling will introduce
		* a second occurence of the `only call' but at that point
		* f has already been killed. *)
	       else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) then
		   let val nle =
			   C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
		       (app (unuseval m) vs);
		       unusecall m g;
		       cexp (S.add(g, ifs)) m nle cont
	       else cont(m,F.APP(sval2val svf, nvs))
	     | sv => cont(m,F.APP(sval2val svf, nvs))
      | F.TFN ((f,args,body),le) =>
	let val fi = C.get f
	in if C.dead fi then (click_deadlexp(); loop m le cont) else
	    let val nbody = cexp ifs m body #2
		val nm = addbind(m, f, TFun(f, nbody, args))
		val nle = loop nm le cont
		if C.dead fi then nle else F.TFN((f, args, nbody), nle)

      | F.TAPP(f,tycs) =>
	(* (case val2sval m f
	  of TFun(g,body,args,od) =>
	     if d = od andalso C.usenb(C.get g) = 1 then
		 let val (_,_,_,le) =
		     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) =>
	     let fun killle le = C.unuselexp (undertake m) le
		 fun kill lv le =
		     C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le
		 fun killarm (F.DATAcon(_,_,lv),le) = kill lv le
		   | killarm _ = buglexp("bad arm in switch(con)", le)

		 fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) =
		     (* sometimes lty1 <> lty2 :-( so this doesn't work:
		      *  FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) *)
		     if #2 dc1 = #2 (cdcon dc2) then
			 (map killarm tl; (* kill the rest *)
			  O.map killle def; (* and the default case *)
			  loop (substitute(m, lv, svc, F.VAR lvc))
			       le cont)
			 (* kill this arm and continue with the rest *)
			 (kill lv le; carm tl)
		   | carm [] = loop m (O.valOf def) cont
		   | carm _ = buglexp("unexpected arm in switch(con,...)", le)
	     in click_switch(); carm arms

	   | sv as Val v =>
	     let fun kill le = C.unuselexp (undertake m) le
		 fun carm ((con,le)::tl) =
		     if eqConV(con, v) then
			  (map (kill o #2) tl;
			   O.map kill def;
			   loop m le cont)
		     else (kill le; carm tl)
		   | carm [] = loop m (O.valOf def) cont
	     in click_switch(); carm arms

	   | sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
	     | (* will probably never happen *) Record{1=lvc,...}) =>
	     (case (arms,def)
	       of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>
		  (* this is a mere DECON, so we can push the let binding
		   * (hidden in cont) inside and maybe even drop the DECON *)
		  let val ndc = cdcon dc
		      val slv = Decon(lv, sv, ndc, tycs)
		      val nm = addbind(m, lv, slv)
		      (* see below *)
		      (* val nm = addbind(nm, lvc, Con(lvc, slv, ndc, tycs)) *)
		      val nle = loop nm le cont
		      val nv = sval2val sv
		      if used lv then
		      else (unuseval m nv; nle)
		| (([(_,le)],NONE) | ([],SOME le)) =>
		  (* This should never happen, but we can optimize it away *)
		  (unuseval m (sval2val sv); loop m le cont) 
		| _ =>
		  let fun carm (F.DATAcon(dc,tycs,lv),le) =
			  let val ndc = cdcon dc
			      val slv = Decon(lv, sv, ndc, tycs)
			      val nm = addbind(m, lv, slv)
			      (* we can rebind lv to a more precise value
			       * !!BEWARE!!  This rebinding is misleading:
			       * - it gives the impression that `lvc' is built
			       *   from`lv' although the reverse is true:
			       *   if `lvc' is undertaken, `lv's count should
			       *   *not* be updated!
			       *   Luckily, `lvc' will not become dead while
			       *   rebound to Con(lv) because it's used by the
			       *   SWITCH. All in all, it works fine, but it's
			       *   not as straightforward as it seems.
			       * - it seems to be a good idea, but it can hide
			       *   other opt-opportunities since it hides the
			       *   previous binding. *)
			      (* val nm = addbind(nm, lvc, Con(lvc,slv,ndc,tycs)) *)
			  in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
			| carm (con,le) = (con, loop m le #2)
		      val narms = map carm arms
		      val ndef = Option.map (fn le => loop m le #2) def
		  in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))

	   | sv as (Fun _ | TFun _) =>
	     bugval("unexpected switch arg", sval2val sv))

      | F.CON (dc1,tycs1,v,lv,le) =>
	let val lvi = C.get lv
	in if C.dead lvi then (click_deadval(); loop m le cont) else
	    let val ndc = cdcon dc1
		fun ccon sv =
		    let val nm = addbind(m, lv, Con(lv, sv, ndc, tycs1))
			val nle = loop nm le cont
		    in if C.dead lvi then nle
		       else F.CON(ndc, tycs1, sval2val sv, lv, nle)
	    in case val2sval m v
		of sv as (Decon (lvd,sv',dc2,tycs2)) =>
		   if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
			loop (substitute(m, lv, sv', F.VAR lvd)) le cont)
		   else ccon sv
		 | sv => ccon sv

      | F.RECORD (rk,vs,lv,le) =>
	(* g: check whether the record already exists *)
	let val lvi = C.get lv
	in if C.dead lvi then (click_deadval(); loop m le cont) else
	    let fun g (Select(_,sv,0)::ss) =
		    let fun g' (n,Select(_,sv',i)::ss) =
			    if n = i andalso (sval2val sv) = (sval2val sv')
			    then g'(n+1,ss) else NONE
			  | g' (n,[]) = 
			    (case sval2lty sv
			      of SOME lty =>
				 let val ltd = case rk
						of F.RK_STRUCT => LT.ltd_str
						 | F.RK_TUPLE _ => LT.ltd_tuple
						 | _ => buglexp("bogus rk",le)
				 in if length(ltd lty) = n
				    then SOME sv else NONE
			       | _ => (click_lacktype(); NONE)) (* sad *)
			   | g' _ = NONE
		    in g'(1,ss)
		  | g _ = NONE
		val svs = map (val2sval m) vs
	    in case g svs
		of SOME sv => (click_record();
			       loop (substitute(m, lv, sv, F.INT 0)) le cont
				    before app (unuseval m) vs)
		 | _ =>
		   let val nm = addbind(m, lv, Record(lv, svs))
		       val nle = loop nm le cont
		   in if C.dead lvi then nle
		      else F.RECORD(rk, map sval2val svs, lv, nle)

      | F.SELECT (v,i,lv,le) =>
	let val lvi = C.get lv
	in if C.dead lvi then (click_deadval(); loop m le cont) else
	    (case val2sval m v
	      of Record (lvr,svs) =>
		 let val sv = List.nth(svs, i)
		 in click_select();
		     loop (substitute(m, lv, sv, F.VAR lvr)) le cont
	       | sv =>
		 let val nm = addbind (m, lv, Select(lv, sv, i))
		     val nle = loop nm le cont
		 in if C.dead lvi then nle
		    else F.SELECT(sval2val sv, i, lv, nle) 
      | F.RAISE (v,ltys) =>
	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) =>
	let val nvs = map substval vs
	    val npo = cpo po
	    val nle1 = loop m le1 #2
	    val nle2 = loop m le2 #2
	in cont(m, F.BRANCH(npo, nvs, nle1, nle2))

      | F.PRIMOP (po,vs,lv,le) =>
	let val lvi = C.get lv
	    val pure = not(impurePO po)
	in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else
	    let val nvs = map substval vs
		val npo = cpo po
		val nm = addbind(m, lv, Var(lv,NONE))
		val nle = loop nm le cont
		if pure andalso C.dead lvi then nle
		else F.PRIMOP(npo, nvs, lv, nle)
    (*  C.collect fdec; *)
    case cexp S.empty
	      M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
     of F.FIX([fdec], F.RET[F.VAR f]) => fdec
      | fdec => bug "invalid return fundec"

ViewVC Help
Powered by ViewVC 1.0.0