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/collect.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 186 - (download) (annotate)
Wed Nov 11 05:24:43 1998 UTC (20 years, 6 months ago) by monnier
File size: 14793 byte(s)
* opt/collect.sml: switched back to a read-only collect phase.  Also try
  to export the info to allow fcontract to circumvent some of the get calls.
(* copyright 1998 YALE FLINT PROJECT *)
(* monnier@cs.yale.edu *)

signature COLLECT =
sig
    type info
    
    (* Collect information about variables and function uses.
     * The info is accumulated in the map `m' *)
    val collect : FLINT.fundec -> FLINT.fundec

    val get : FLINT.lvar -> info

    (* query functions *)
    val escaping  : info -> bool	(* non-call uses *)
    val called    : info -> bool	(* known call uses *)
    val usenb     : info -> int	(* nb of non-recursive uses *)
    val actuals   : info -> (FLINT.value option list) (* constant args *)

    (* inc the "true=call,false=use" count *)
    val use    : FLINT.value list option -> info -> unit
    (* dec the "true=call,false=use" count and call the function (and return true) if zero *)
    val unuse  : (FLINT.lvar -> unit) -> bool -> FLINT.lvar -> bool
    (* transfer the counts of var1 to var2 *)
    val transfer : FLINT.lvar * FLINT.lvar -> unit
    (* add the counts of var1 to var2 *)
    (*  val addto  : info * info -> unit *)
    (* delete the last reference to a variable *)
    val kill   : FLINT.lvar -> unit
    (* create a new var entry (SOME arg list if fun) initialized to zero *)
    val new    : FLINT.lvar list option -> FLINT.lvar -> info

    (* when creating a new var.  Used when alpha-renaming *)
    (* val copy   : FLINT.lvar * FLINT.lvar -> unit *)

    (* fix up function to keep counts up-to-date when getting rid of code.
     * the arg is only called for *free* variables becoming dead.
     * the first function returned just unuses an exp, while the
     * second unuses a function declaration (f,args,body) *)
    val unuselexp : (FLINT.lvar -> unit) -> 
	((FLINT.lexp -> unit) *
         ((FLINT.lvar * FLINT.lvar list * FLINT.lexp) -> unit))
    (* function to collect info about a newly created lexp *)
    val uselexp : FLINT.lexp -> unit
    (* function to copy (and collect info) a lexp *)
    val copylexp : FLINT.lvar IntmapF.intmap  -> FLINT.lexp -> FLINT.lexp

    (* mostly useful for PPFlint *)
    val LVarString : FLINT.lvar -> string
end

(* Internal vs External references:
 * I started with a version that kept track separately of internal and external
 * uses.  This has the advantage that if the extuses count goes to zero, we can
 * consider the function as dead.  Without this, recursive functions can never
 * be recognized as dead during fcontract (they are still eliminated at the
 * beginning, tho).  This looks nice at first, but poses problems:
 * - when you do simple inlining (just moving the body of the procedure), you
 *   may inadvertently turn ext-uses into int-uses.  This only happens when
 *   inlining mutually recursive function, but this can be commen (thing of
 *   when fcontract undoes a useless uncurrying or a recursive function).  This
 *   can be readily overcome by not using the `move body' optimization in
 *   dangerous cases and do the full copy+kill instead.
 * - you have to keep track of what is inside what.  The way I did it was to
 *   have an 'inside' ref cell in each fun.  That was a bad idea.  The problem
 *   stems from the fact that when you detect that a function becomes dead,
 *   you have to somehow reset those `inside' ref cells to reflect the location
 *   of the function before you can uncount its references.  In most cases, this
 *   is unnecessary, but it is necessary when undertaking a function mutually
 *   recursive with a function in which you currently are when you detect the
 *   function's death.
 * rather than fix this last point, I decided to get rid of the distinction.
 * This makes the code simpler and less bug-prone at the cost of slightly
 * increasing the number of fcontract passes required.
 *)

structure Collect :> COLLECT =
struct
local
    structure F  = FLINT
    structure M  = Intmap
    structure FU = FlintUtil
    structure LV = LambdaVar
    structure PP = PPFlint
in

val say = Control.Print.say
fun bug msg = ErrorMsg.impossible ("Collect: "^msg)
fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
fun ASSERT (true,_) = ()
  | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")

exception UnexpectedTransfer

datatype info
  (* for functions we keep track of calls and escaping uses *)
  = Fun of {calls: int ref, uses: int ref,
	    args: (FLINT.lvar * (FLINT.value option)) option list ref}
  | Var of int ref	(* for other vars, a simple use count is kept *)
  | Transfer of FLINT.lvar	(* for vars which have been transfered *)
    
exception NotFound
	      
val m : info M.intmap = M.new(128, NotFound)

(* map related helper functions *)
fun get lv = (M.map m lv)
		  handle x as NotFound =>
		  (say ("Collect: ERROR: get unknown var "^
			(LV.lvarName lv)^
			". Pretending dead...\n");
		   (*  raise x; *)
		   Var (ref 0))

fun LVarString lv =
    (LV.lvarName lv)^
    ((case get lv of
	 Var uses => "{"^(Int.toString (!uses))^"}"
       | Fun {calls,uses,...} =>
	 concat ["{", Int.toString (!uses), ",", Int.toString (!calls), "}"]
       | Transfer lv => "{->"^(LVarString lv)^"}")
	 handle NotFound => "{?}")

fun get' lv = case get lv of Transfer nlv => get' nlv | i => i

fun new args lv =
    let val i =
	    case args
	     of SOME args => Fun{calls=ref 0, uses=ref 0,
				 args=ref (map (fn a => SOME(a, NONE)) args)}
	      | NONE => Var(ref 0)
    in M.add m (lv, i); i
    end

(* adds the counts of lv1 to those of lv2 *)
fun addto (info1,info2) =
    case info1
     of Var uses1 =>
	(case info2
	  of Var uses2 => uses2 := !uses2 + !uses1
	   | Fun {uses=uses2,...} => uses2 := !uses2 + !uses1
	   | Transfer _ => raise UnexpectedTransfer)
      | Fun {uses=uses1,calls=calls1,...} =>
	(case info2
	  of Fun {uses=uses2,calls=calls2,...} =>
	     (uses2 := !uses2 + !uses1; calls2 := !calls2 + !calls1)
	   | Var uses2 => uses2 := !uses2 + !uses1
	   | Transfer _ => raise UnexpectedTransfer)
      | Transfer _ => raise UnexpectedTransfer

fun transfer (lv1,lv2) =
    (addto(get lv1, get lv2);
     (* note the transfer *)
     M.add m (lv1, Transfer lv2)) handle x => raise x
	       
fun inc ri = (ri := !ri + 1)
fun dec ri = (ri := !ri - 1)

(* - first list is list of formal args
 * - second is list of `up to know known arg'
 * - third is args of the current call. *)
fun mergearg (NONE,a) = NONE
  | mergearg (SOME(fv,NONE),a) =
    if a = F.VAR fv then SOME(fv,NONE) else SOME(fv,SOME a)
  | mergearg (SOME(fv,SOME b),a) =
    if a = b orelse a = F.VAR fv then SOME(fv,SOME b) else NONE

fun actuals (Var _) = bug "can't query actuals of a var" (* (LVarString lv) *)
  | actuals (Transfer lv) = raise UnexpectedTransfer
  | actuals (Fun{args,...}) = map (fn SOME(_,v) => v | _ => NONE) (!args)

fun use call (Var uses) = inc uses
  | use call (Transfer lv) = raise UnexpectedTransfer
  | use call (Fun {uses,calls,args,...}) =
    case call of
	NONE => (inc uses; args := map (fn _ => NONE) (!args))
      | SOME vals => 
	(inc calls; inc uses; args := ListPair.map mergearg (!args, vals))

fun unuse undertaker call lv =
    let fun check uses =
	    if !uses < 0 then
		bugval("decrementing too much", F.VAR lv)
	    else if !uses = 0 then
		(undertaker lv; true)
	    else false
    in case get' lv
	of Var uses => (dec uses; check uses)
	 | Fun {uses,calls,...} =>
	   (dec uses; if (call andalso !calls > 0) then dec calls else ASSERT(!uses >= !calls, "unknown sanity"); check uses)
	 | Transfer lv => bug "transfer"
    end handle x => raise x

fun usenb (Fun{uses=uses,...} | Var uses) = !uses
  | usenb (Transfer _) = (raise UnexpectedTransfer; 0)
fun used i      = usenb i > 0

fun escaping (Fun{uses,calls,...}) = !uses > !calls
  | escaping (Var us) = !us > 0 (* arbitrary, but hopefully "safe" *)
  | escaping (Transfer lv) = raise UnexpectedTransfer

fun called (Fun{calls,...}) = !calls > 0
  | called (Var us) = false (* arbitrary, but consistent with escaping *)
  | called (Transfer lv) = raise UnexpectedTransfer

(* Ideally, we should check that usenb = 1, but we may have been a bit
 * conservative when keeping the counts uptodate *)
fun kill lv = (ASSERT(usenb(get' lv) >= 1, "usenb "^(LVarString lv)^" >= 1 ");
	       M.rmv m lv)

(* ********************************************************************** *)
(* ********************************************************************** *)

datatype usage
  = All
  | None
  | Some of bool list

fun usage bs =
    let fun ua [] = All
	  | ua (false::_) = Some bs
	  | ua (true::bs) = ua bs
	fun un [] = None
	  | un (true::_) = Some bs
	  | un (false::bs) = un bs
    in case bs
	of true::bs => ua bs
	 | false::bs => un bs
	 | [] => None
    end

fun impurePO po = true		(* if a PrimOP is pure or not *)

val census = let
    (* val use = if inc then use else unuse *)
    fun call args lv = use args (get' lv)
    val use = fn F.VAR lv => use NONE (get' lv) | _ => ()
    fun newv lv = new NONE lv
    fun newf args lv = new args lv
    fun id x = x

    fun impurePO po = true		(* if a PrimOP is pure or not *)

    (* here, the use resembles a call, but it's safer to consider it as a use *)
    fun cpo (NONE:F.dict option,po,lty,tycs) = ()
      | cpo (SOME{default,table},po,lty,tycs) =
	(use (F.VAR default); app (use o F.VAR o #2) table)
    fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = use (F.VAR lv)
      | cdcon _ = ()

    (* the actual function:
     * `uvs' is an optional list of booleans representing which of 
     * the return values are actually used *)
    fun cexp uvs lexp =
	(case lexp
	 of F.RET vs => app use vs
(* 	    (case uvs *)
(* 	      of SOME uvs => (* only count vals that are actually used *) *)
(* 		 app (fn(v,uv)=>if uv then use v else ()) (ListPair.zip(vs,uvs)) *)
(* 	       | NONE => app use vs) *)

	  | F.LET (lvs,le1,le2) =>
	    let val lvsi = map newv lvs
	    in cexp uvs le2; cexp (usage(map used lvsi)) le1
	    end

	  | F.FIX (fs,le) =>
	    let val fs = map (fn (_,f,args,body) =>
			      (newf (SOME(map #1 args)) f,args,body))
			     fs
		fun cfun (_,args,body) = (* census of a fundec *)
		    (app (fn (v,t) => ignore(newv v)) args; cexp All body)
		fun cfix fs =	(* census of a list of fundecs *)
		    let val (ufs,nfs) = List.partition (used o #1) fs
		    in if List.null ufs then ()
		       else (app cfun ufs; cfix nfs)
		    end
	    in cexp uvs le; cfix fs
	    end
	       
	  | F.APP (F.VAR f,vs) =>
	    (call (SOME vs) f; app use vs)

	  | F.TFN ((tf,args,body),le) =>
	    let val tfi = newf NONE tf
	    in cexp uvs le;
		if used tfi then cexp All body else ()
	    end

	  | F.TAPP (F.VAR tf,tycs) => call NONE tf

	  | F.SWITCH (v,cs,arms,def) =>
	    (use v; Option.map (cexp uvs) def;
	     app (fn (F.DATAcon(dc,_,lv),le) => (cdcon dc; newv lv; cexp uvs le)
		   | (_,le) => cexp uvs le)
		 arms)
		
	  | F.CON (dc,_,v,lv,le) =>
	    let val lvi = newv lv
	    in cdcon dc; cexp uvs le; if used lvi then use v else ()
	    end

	  | F.RECORD (_,vs,lv,le) =>
	    let val lvi = newv lv
	    in cexp uvs le; if used lvi then app use vs else ()
	    end

	  | F.SELECT (v,_,lv,le) =>
	    let val lvi = newv lv
	    in cexp uvs le; if used lvi then use v else ()
	    end

	  | F.RAISE (v,_) => use v
	  | F.HANDLE (le,v) => (use v; cexp uvs le)
	  
	  | F.BRANCH (po,vs,le1,le2) =>
	    (app use vs; cpo po; cexp uvs le1; cexp uvs le2)
	  
	  | F.PRIMOP (po,vs,lv,le) =>
	    let val lvi = newv lv
	    in cexp uvs le;
		if impurePO po orelse used lvi then (cpo po; app use vs) else ()
	    end
	  
	  | le => buglexp("unexpected lexp", le)) handle x => raise x
in
    cexp
end

(* The code is almost the same for uncounting, except that calling
 * undertaker should not be done for non-free variables.  For that we
 * artificially increase the usage count of each variable when it's defined
 * (accomplished via the "def" calls)
 * so that its counter never reaches 0 while processing its scope.
 * Once its scope has been processed, we can completely get rid of
 * the variable and corresponding info (after verifying that the count
 * is indeed exactly 1 (accomplished by the "kill" calls) *)
fun unuselexp undertaker = let
    (* val use = if inc then use else unuse *)
    fun uncall lv = ignore(unuse undertaker true lv)
    val unuse = fn F.VAR lv => ignore(unuse undertaker false lv) | _ => ()
    fun def lv = (use NONE (get lv)) handle x => raise x
    fun id x = x

    fun cpo (NONE:F.dict option,po,lty,tycs) = ()
      | cpo (SOME{default,table},po,lty,tycs) =
	(unuse(F.VAR default); app (unuse o F.VAR o #2) table)
    fun cdcon (s,Access.EXN(Access.LVAR lv),lty) = unuse(F.VAR lv)
      | cdcon _ = ()

    fun cfun (f,args,body) = (* census of a fundec *)
	(app def args; cexp body; app kill args) handle x => raise x

    and cexp lexp =
	(case lexp
	 of F.RET vs => app unuse vs

	  | F.LET (lvs,le1,le2) =>
	    (app def lvs; cexp le2; cexp le1; app kill lvs)

	  | F.FIX (fs,le) =>
	    let val usedfs = (List.filter ((used o get o #2) handle x => raise x) fs)
	    in app (def o #2) fs;
		cexp le;
		app (fn (_,lv,args,le) => cfun(lv, map #1 args, le)) usedfs;
		app (kill o #2) fs
	    end
	       
	  | F.APP (F.VAR f,vs) =>
	    (uncall f; app unuse vs)

	  | F.TFN ((tf,args,body),le) =>
	    (if used(get tf) then cexp body else ();
	     def tf; cexp le; kill tf)

	  | F.TAPP (F.VAR tf,tycs) => uncall tf

	  | F.SWITCH (v,cs,arms,default) =>
	    (unuse v; Option.map cexp default;
	     (* here we don't absolutely have to keep track of vars bound within
	      * each arm since these vars can't be eliminated anyway *)
	     app (fn (F.DATAcon(dc,_,lv),le) =>
		  (cdcon dc; def lv; cexp le; kill lv)
		   | (_,le) => cexp le)
		 arms)
		
	  | F.CON (dc,_,v,lv,le) =>
	    (cdcon dc; if used(get lv) then unuse v else ();
	     def lv; cexp le; kill lv)

	  | F.RECORD (_,vs,lv,le) =>
	    (if used(get lv) then app unuse vs else ();
	     def lv; cexp le; kill lv)

	  | F.SELECT (v,_,lv,le) =>
	    (if used(get lv) then unuse v else ();
	     def lv; cexp le; kill lv)

	  | F.RAISE (v,_) => unuse v
	  | F.HANDLE (le,v) => (unuse v; cexp le)
	  
	  | F.BRANCH (po,vs,le1,le2) =>
	    (app unuse vs; cpo po; cexp le1; cexp le2)
	  
	  | F.PRIMOP (po,vs,lv,le) =>
	    (if impurePO po orelse used(get lv) then
		 (cpo po; app unuse vs)
	     else ();
	     def lv; cexp le; kill lv)

	  | le => buglexp("unexpected lexp", le)) handle x => raise x
in
    (cexp, cfun)
end

val uselexp = census All
fun copylexp alpha le =
    let val nle = FU.copy alpha le
    in uselexp nle; nle
    end

fun collect (fdec as (_,f,_,_)) =
    ((*  say "Entering Collect...\n"; *)
     M.clear m;				(* start from a fresh state *)
     PP.LVarString := LVarString;
     uselexp (F.FIX([fdec], F.RET[F.VAR f]));
     (*  say "...Collect Done.\n"; *)
     fdec)

end
end

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