Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] View of /branches/charisee/src/compiler/IL/value-numbering-fn.sml
ViewVC logotype

View of /branches/charisee/src/compiler/IL/value-numbering-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1115 - (download) (annotate)
Thu May 5 04:42:18 2011 UTC (8 years, 6 months ago) by jhr
Original Path: trunk/src/compiler/IL/value-numbering-fn.sml
File size: 5628 byte(s)
  More merging of pure-cfg back into trunk
(* value-numbering-fn.sml
 *
 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * This file contains an implementation of the hash-based value numbering
 * algorithm described in
 *
 *	Value Numbering
 *	by Preston Briggs, Keith Cooper, and Taylor Simpson
 *	CRPC-TR94517-S
 *	November 1994
 *)

functor ValueNumberingFn (D : DOMINANCE_TREE) : sig

    structure IL : SSA

    val transform : IL.program -> IL.program

  end = struct

    structure IL = D.IL
    structure HC = HashCons

    datatype exp = E of {
	uid : word,		(* unique ID *)
	hash : word,		(* hash value *)
	term : exp_node
      }

    and exp_node
      = VAR of IL.var
      | LIT of Literal.literal
      | OP of Op.rator * exp list
      | APPLY of ILBasis.name * exp list
      | CONS of IL.Ty.ty * exp list
      | PHI of exp list

    fun hashArgs (args, base) =
	  List.foldl (fn (E{uid, ...}, h) => uid+h) base args

    fun hashNode (VAR x) = IL.Var.hash x
      | hashNode (LIT l) = Literal.hash l
      | hashNode (OP(rator, args)) = hashArgs (IL.Op.hash rator, args)
      | hashNode (APPLY(f, args)) = hashArgs (ILBasis.hash f, args)
      | hashNode (CONS(ty, args)) = hashArgs (IL.Ty.hash ty + 0w49, args)
      | hashNode (PHI args) = hashArgs (0w57, args)

    fun sameNode (VAR x, VAR y) = IL.Var.same(x, y)
      | sameNode (LIT l1, LIT l2) = Literal.same(l1, l2)
      | sameNode (OP(rator1, args1), OP(rator2, args2)) =
	  IL.Op.same(rator1, rator2) andalso ListPair.allEq sameNode (args1, args2)
      | sameNode (APPLY(f1, args1), APPLY(f2, args2)) =
	  ILBasis.same(f1, f2) andalso ListPair.allEq sameNode (args1, args2)
      | sameNode (CONS(ty1, args1), CONS(ty2, args2)) =
	  IL.Ty.same(ty1, ty2) andalso ListPair.allEq sameNode (args1, args2)
      | sameNode (PHI args1, PHI args2) = ListPair.allEq sameNode (args1, args2)

    structure Tbl = HashTableFn (
      struct
	type hash_key = (word * exp_node)
	fun hashVal (h, _) = h
	fun sameKey ((_, e1), (_, e2)) = sameNode(e1, e2)
      end)

  (* hashConsExp : unit -> exp_node -> exp
   * returns the hash-consed representation of an expression.
   *)
    fun hashConsExp () = let
	  val uidCnt = ref 0w0
	  val tbl = Tbl.mkTable (1024, raise Fail "Value Table")
	  val find = Tbl.find tbl
	  val insert = Tbl.insert tbl
	  fun mk e = let
		val h = hashNode e
		val key = (h, e)
		in
		  case find key
		   of SOME exp => exp
		    | NONE => let
			val uid = !uidCnt
			val exp = E{uid=uid, hash=h, term=e}
			in
			  insert (key, exp);
			  exp
			end
		  (* end case *)
		end
	  in
	    mk
	  end

    local

      fun compareExp (E{uid=a, ...}, E{uid=b, ...}) = Word.compare(a, b)

      structure ValueSet = RedBlackSetFn (
	struct
	  type ord_key = exp
	  val compare = compareExp
	end)
      structure ValueMap = RedBlackMapFn (
	struct
	  type ord_key = exp
	  val compare = compareExp
	end)

    (* property for mapping variables to their value number (VN), which is represented as a
     * SSA variable.  If their VN is different from themselves, then they are redundant.
     *)
      val {getFn=getVN, setFn=setVN, clrFn=clrVN, ...} = IL.Var.newProp (fn x => x)

    (* property for mapping value numbers to hash-consed expressions. *)
      val {getFn : IL.var -> exp =getExp, setFn=setExp, clrFn=clrExp, ...} =
	    IL.Var.newProp (fn x => raise Fail "getExp")

      datatype env = ENV of {
	  avail : IL.Var ValueMap.map	(* map from expressions to their value numbers, which *)
					(* are represented as SSA vars.  The domain are those *)
					(* expressions that are available. *)
	}
    in
  (* map variables to their hash-consed definition *)
    val getVN = getVN
    fun varToExp x = getExp(getVN x)
    fun bindVarToExp (E{avail}, x, e) = (
	  setVN(x, x); setExp(x, e);
	  E{avail=ValueMap.insert(avail, e, x))
    fun expToVN (E{avail}, e) = ValueMap.find(avail, e)
    end (* local *)

    fun rewrite nd = (case IL.Node.kind nd
	  (* end case *))

    fun transform prog = let
	  val hashConsExp = hashConsExp()
	  fun varsToExp (env, xs) = List.map (fn x => varToExp(env, x)) xs
	(* convert an SSA RHS into a hash-consed expression *)
	  fun mkExp (env, rhs) = (case rhs
		 of IL.VAR x => varToExp(env, x)
		  | IL.LIT l => hashConsExp(LIT l)
		  | IL.OP(rator, args) => hashConsExp(OP(rator, varsToExp(env, args)))
		  | IL.APPLY(f, args) => hashConsExp(APPLY(f, varsToExp(env, args)))
		  | IL.CONS(ty, args) => hashConsExp(CONS(ty, varsToExp(env, args)))
		(* end case *))
	  fun vn (env, nd) = let
		val env = (case IL.Node.kind nd
		       of IL.JOIN{succ, phis, ...} => let
			    fun doPhi ((y, xs), env) = let
				  val vn::vns = List.map getVN xs
				  in
				    if List.all (fn vn' => IL.Var.same(vn, vn')) vns
				      then (* a meaningless phi node; map y to vn *)
				      else let
					val exp = hashConsExp(PHI(varsToExp(env, args)))
					in
					  case expToVN(env, exp)
					   of SOME x => (* a redundant phi node *)
					    | NONE => bindVarToExp(env, y, exp)
					  (* end case *)
					end
				  end
			    in
			      List.foldl doPhi env (!phis)
			    end
			| IL.ASSIGN{stm=(y, rhs), succ, ...} => let
			    val exp = mkExp(env, rhs)
			    in
			      case expToVN(env, exp)
			       of SOME x => (* y is redundant, so map it to x *)
				| NONE => bindVarToExp(env, y, exp)
			      (* end case *)
			    end
			| _ => env
		      (* end case *))
		in
		  List.app (fn nd => vn (env, nd)) (D.children nd)
		end
	(* value number a CFG *)
	  fun vnCFG (env, cfg) = (
		D.computeTree cfg;
		vn (env, IL.CFG.entryNode cfg);
		D.clear cfg)
	  in
	  end 

  end

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