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

SCM Repository

[diderot] View of /branches/lamont_dev/src/compiler/IL/ssa-fn.sml
ViewVC logotype

View of /branches/lamont_dev/src/compiler/IL/ssa-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1232 - (download) (annotate)
Mon May 16 23:37:52 2011 UTC (8 years, 6 months ago) by jhr
Original Path: trunk/src/compiler/IL/ssa-fn.sml
File size: 17688 byte(s)
  Porting many changes from the pure-cfg branch, including value numbering
  and support for parallel execution on SMP systems.
(* ssa-fn.sml
 *
 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * The SSAFn functor is used to generate the High, Med, and Low ILs in the Diderot
 * compiler.  These ILs have the same program and control-flow structure, but differ
 * in their types and operators.
 *)

functor SSAFn (

    val ilName : string
    structure Ty : SSA_TYPES
    structure Op : OPERATORS where type ty = Ty.ty

  ) : SSA = struct

    structure Ty = Ty
    structure Op = Op

    val ilName = ilName

  (***** CFG *****)

    datatype cfg = CFG of {
	entry : node,	(* the entry node of a graph; not necessarily an ENTRY node *)
	exit : node	(* the exit node of a graph; not necessarily an EXIT node. *)
      }

    and node = ND of {
	id : Stamp.stamp,
	props : PropList.holder,
	kind : node_kind
      }

    and node_kind
      = NULL
      | ENTRY of {
	    succ : node ref
	  }
      | JOIN of {
	    preds : node list ref,
	    phis : phi list ref,
	    succ : node ref
	  }
      | COND of {
	    pred : node ref,
	    cond : var,
	    trueBranch : node ref,
	    falseBranch : node ref
	  }
      | COM of  {			(* comment *)
	    pred : node ref,
	    text : string list,
	    succ : node ref
	  }
      | ASSIGN of {			(* assignment *)
	    pred : node ref,
	    stm : assign,
	    succ : node ref
	  }
      | NEW of {			(* create new strand instance *)
	    pred : node ref,
	    strand : Atom.atom,
	    args : var list,
	    succ : node ref
	  }
      | EXIT of {			(* includes die and stabilize *)
	    pred : node ref,
	    kind : ExitKind.kind,	(* kind of exit node *)
	    live : var list		(* live variables *)
	  }

    and rhs
      = VAR of var
      | LIT of Literal.literal
      | OP of Op.rator * var list
      | APPLY of ILBasis.name * var list (* basis function application *)
      | CONS of Ty.ty * var list	(* tensor/sequence-value construction *)

    and var = V of {
	name : string,			(* name *)
	id : Stamp.stamp,		(* unique ID *)
	ty : Ty.ty,			(* type *)
	bind : var_bind ref,		(* binding *)
	useCnt : int ref,		(* count of uses *)
	props : PropList.holder
      }

    and var_bind
      = VB_NONE
      | VB_RHS of rhs			(* defined by an assignment (includes globals and state variables) *)
      | VB_PHI of var list		(* defined by a phi node *)
      | VB_PARAM			(* parameter to a strand *)

    withtype assign = (var * rhs)
	 and phi = (var * var list)


  (***** Program representation *****)

    datatype program = Program of {
	globalInit : cfg,
	initially : initially,
	strands : strand list
      }

    and initially = Initially of {
	isArray : bool,			(* true for initially array, false for collection *)
	rangeInit : cfg,		(* code to compute bounds of iteration *)
	iters : (var * var * var) list,
	create : (cfg * Atom.atom * var list)
      }

    and strand = Strand of {
	name : Atom.atom,
	params : var list,
	state : (bool * var) list,	(* output variables are marked with true *)
	stateInit : cfg,
	methods : method list
      }

    and method = Method of {
	name : Atom.atom,
	stateIn : var list,	(* names of state variables on method entry *)
	body : cfg		(* method body *)
      }

    structure Var =
      struct
	fun new (name, ty) = V{
		name = name,
		id = Stamp.new(),
		ty = ty,
		bind = ref VB_NONE,
		useCnt = ref 0,
		props = PropList.newHolder()
	      }
	fun copy (V{name, ty, ...}) = new (name, ty)
	fun name (V{name, ...}) = name
	fun ty (V{ty, ...}) = ty
	fun binding (V{bind, ...}) = !bind
	fun setBinding (V{bind, ...}, vb) = bind := vb
	fun useCount (V{useCnt, ...}) = !useCnt
	fun same (V{id=a, ...}, V{id=b, ...}) = Stamp.same(a, b)
	fun compare (V{id=a, ...}, V{id=b, ...}) = Stamp.compare(a, b)
	fun hash (V{id, ...}) = Stamp.hash id
	fun toString (V{name, id, ...}) = name ^ Stamp.toString id
      (* properties *)
	fun newProp initFn =
	      PropList.newProp (fn (V{props, ...}) => props, initFn) 
	fun newFlag () =
	      PropList.newFlag (fn (V{props, ...}) => props) 
	local
	  structure V =
	    struct
	      type ord_key = var
	      val compare = compare
	    end
	in
	structure Map = RedBlackMapFn (V)
	structure Set = RedBlackSetFn (V)
	end
	structure Tbl = HashTableFn (
	  struct
	    type hash_key = var
	    val hashVal = hash
	    val sameKey = same
	  end)
      end

    structure Node =
      struct
	fun id (ND{id, ...}) = id
	fun kind (ND{kind, ...}) = kind
	fun same (ND{id=a, ...}, ND{id=b, ...}) = Stamp.same(a, b)
	fun compare (ND{id=a, ...}, ND{id=b, ...}) = Stamp.compare(a, b)
	fun hash (ND{id, ...}) = Stamp.hash id
	fun toString (ND{id, kind, ...}) = let
	      val tag = (case kind
		     of NULL => "NULL"
		      | ENTRY _ => "ENTRY"
		      | JOIN _ => "JOIN"
		      | COND _ => "COND"
		      | COM _ => "COM"
		      | ASSIGN _ => "ASSIGN"
		      | NEW _ => "NEW"
		      | EXIT{kind, ...} => ExitKind.toString kind
		    (* end case *))
	      in
		tag ^ Stamp.toString id
	      end
	fun new kind = ND{id = Stamp.new(), props = PropList.newHolder(), kind = kind}
      (* variable defs and uses *)
	fun uses (ND{kind, ...}) = (case kind
	       of JOIN{phis, ...} => List.foldr (fn ((_, xs), ys) => xs@ys) [] (!phis)
		| COND{cond, ...} => [cond]
		| ASSIGN{stm=(y, rhs), ...} => (case rhs
		     of VAR x => [x]
		      | LIT _ => []
		      | OP(_, args) => args
		      | APPLY(_, args) => args
		      | CONS(_, args) => args
		    (* end case *))
		| NEW{args, ...} => args
		| EXIT{live, ...} => live
		| _ => []
	      (* end case *))
	fun defs (ND{kind, ...}) = (case kind
	       of JOIN{phis, ...} => List.map #1 (!phis)
		| ASSIGN{stm=(y, _), ...} => [y]
		| _ => []
	      (* end case *))
	val dummy = new NULL
	fun mkENTRY () = new (ENTRY{succ = ref dummy})
	fun mkJOIN phis = new (JOIN{preds = ref [], phis = ref phis, succ = ref dummy})
	fun mkCOND {cond, trueBranch, falseBranch} = new (COND{
		pred = ref dummy, cond = cond,
		trueBranch = ref trueBranch, falseBranch = ref falseBranch
	      })
	fun mkCOM text = new (COM{pred = ref dummy, text = text, succ = ref dummy})
	fun mkASSIGN (lhs, rhs) = (
	      Var.setBinding (lhs, VB_RHS rhs);
	      new (ASSIGN{pred = ref dummy, stm = (lhs, rhs), succ = ref dummy}))
	fun mkNEW {strand, args} = new (NEW{
		pred = ref dummy, strand = strand, args = args, succ = ref dummy
	      })
	fun mkEXIT (kind, xs) = new (EXIT{kind = kind, live = xs, pred = ref dummy})
	fun mkFRAGMENT xs = mkEXIT (ExitKind.FRAGMENT, xs)
	fun mkSINIT xs = mkEXIT (ExitKind.SINIT, xs)
	fun mkRETURN xs = mkEXIT (ExitKind.RETURN, xs)
	fun mkACTIVE xs = mkEXIT (ExitKind.ACTIVE, xs)
	fun mkSTABILIZE xs = mkEXIT (ExitKind.STABILIZE, xs)
	fun mkDIE () = mkEXIT (ExitKind.DIE, [])
	fun isNULL (ND{kind=NULL, ...}) = true
	  | isNULL _ = false
      (* editing node edges *)
	fun hasPred (ND{kind, ...}) = (case kind
	       of NULL => false
		| ENTRY _ => false
		| _ => true
	      (* end case *))
	fun setPred (nd0 as ND{kind, ...}, nd) = (case kind
	       of NULL => raise Fail("setPred on NULL node " ^ toString nd0)
		| ENTRY _ => raise Fail("setPred on ENTRY node " ^ toString nd0)
		| JOIN{preds, ...} => if List.exists (fn nd' => same(nd, nd')) (!preds)
		    then ()
		    else preds := !preds @ [nd]  (* assume preds are added in order *)
		| COND{pred, ...} => pred := nd
		| COM{pred, ...} => pred := nd
		| ASSIGN{pred, ...} => pred := nd
		| NEW{pred, ...} => pred := nd
		| EXIT{pred, ...} => pred := nd
	      (* end case *))
	fun preds (nd as ND{kind, ...}) = (case kind
	       of NULL => [] (*raise Fail("preds on NULL node "^toString nd)*)
		| ENTRY _ => []
		| JOIN{preds, ...} => !preds
		| COND{pred, ...} => [!pred]
		| COM{pred, ...} => [!pred]
		| ASSIGN{pred, ...} => [!pred]
		| NEW{pred, ...} => [!pred]
		| EXIT{pred, ...} => [!pred]
	      (* end case *))
	fun hasSucc (ND{kind, ...}) = (case kind
	       of NULL => false
		| ENTRY _ => true
		| JOIN _ => true
		| COND _ => true
		| COM _ => true
		| ASSIGN _ => true
		| NEW _ => true
		| EXIT _ => false
	      (* end case *))
	fun setSucc (nd0 as ND{kind, ...}, nd) = (case kind
	       of NULL => raise Fail("setSucc on NULL node "^toString nd0)
		| ENTRY{succ} => succ := nd
		| JOIN{succ, ...} => succ := nd
		| COND _ => raise Fail("setSucc on COND node "^toString nd0)
		| COM{succ, ...} => succ := nd
		| ASSIGN{succ, ...} => succ := nd
		| NEW{succ, ...} => succ := nd
		| EXIT _ => raise Fail("setSucc on EXIT node "^toString nd0)
	      (* end case *))
	fun succs (nd as ND{kind, ...}) = (case kind
	       of NULL => [] (*raise Fail("succs on NULL node "^toString nd)*)
		| ENTRY{succ} => [!succ]
		| JOIN{succ, ...} => [!succ]
		| COND{trueBranch, falseBranch, ...} => [!trueBranch, !falseBranch]
		| COM{succ, ...} => [!succ]
		| ASSIGN{succ, ...} => [!succ]
		| NEW{succ, ...} => [!succ]
		| EXIT _ => []
	      (* end case *))
	fun setTrueBranch (ND{kind=COND{trueBranch, ...}, ...}, nd) = trueBranch := nd
	  | setTrueBranch (nd, _) = raise Fail("setTrueBranch on " ^ toString nd)
	fun setFalseBranch (ND{kind=COND{falseBranch, ...}, ...}, nd) = falseBranch := nd
	  | setFalseBranch (nd, _) = raise Fail("setFalseBranch on " ^ toString nd)
	fun addEdge (nd1, nd2) = (
	      if hasSucc nd1
		then (
		  setSucc (nd1, nd2);
		  setPred (nd2, nd1))
		else ())
(*DEBUG*)handle ex => (
print(concat["error in addEdge(", toString nd1, ",", toString nd2, ")\n"]);
raise ex)
	fun replaceInEdge {src, oldDst, dst} = (
	    (* first set the successor of src *)
	      case kind src
	       of COND{trueBranch, falseBranch, ...} =>
		    if same(!trueBranch, oldDst)
		      then trueBranch := dst
		      else falseBranch := dst
		| _ => setSucc (src, dst)
	      (* end case *);
	    (* then set the predecessor of dst *)
	      setPred (dst, src))
(*DEBUG*)handle ex => (
print(concat["error in replaceInEdge(", toString src, ",", toString oldDst, ",", toString dst, ")\n"]);
raise ex)
	fun replaceOutEdge {oldSrc, src, dst} = (
	    (* first set the successor of src *)
	      case kind oldSrc
	       of COND{trueBranch, falseBranch, ...} =>
		    if same(!trueBranch, dst)
		      then setTrueBranch (src, dst)
		      else setFalseBranch (src, dst)
		| _ => setSucc (src, dst)
	      (* end case *);
	    (* then set the predecessor of dst *)
	      case kind dst
	       of JOIN{preds, ...} => let
		    fun edit [] = raise Fail "replaceOutEdge: cannot find predecessor"
		      | edit (nd::nds) = if same(nd, oldSrc) then src::nds else nd::edit nds
		    in
		      preds := edit (!preds)
		    end
		| _ => setPred (dst, src)
	      (* end case *))
(*DEBUG*)handle ex => (
print(concat["error in replaceOutEdge(", toString oldSrc, ",", toString src, ",", toString dst, ")\n"]);
raise ex)
      (* properties *)
	fun newProp initFn =
	      PropList.newProp (fn (ND{props, ...}) => props, initFn) 
	fun newFlag () =
	      PropList.newFlag (fn (ND{props, ...}) => props) 
      end

    structure CFG =
      struct
	val empty = CFG{entry = Node.dummy, exit = Node.dummy}

	fun isEmpty (CFG{entry, exit}) =
	      Node.same(entry, exit) andalso Node.isNULL entry

      (* create a basic block from a list of assignments *)
	fun mkBlock [] = empty
	  | mkBlock (stm::stms) = let
	      val entry = Node.mkASSIGN stm
	      fun f (stm, prev) = let
		    val nd = Node.mkASSIGN stm
		    in
		      Node.addEdge (prev, nd);
		      nd
		    end
	      val exit = List.foldl f entry stms
	      in
		CFG{entry = entry, exit = exit}
	      end

      (* entry/exit nodes of a CFG *)
	fun entry (CFG{entry = nd, ...}) = nd
	fun exit (CFG{exit = nd, ...}) = nd

      (* return the list of variables that are live at exit from a CFG *)
	fun liveAtExit cfg = (case Node.kind(exit cfg)
	       of EXIT{live, ...} => live
		| _ => raise Fail "bogus exit node"
	      (* end case *))

      (* DFS sorting of the graph rooted at the entry to a statement; the resulting list will
       * be in preorder with parents before children.
       *)
	fun sort (CFG{entry, ...}) = let
	      val {getFn, setFn} = PropList.newFlag (fn (ND{props, ...}) => props)
	      fun dfs (nd, l) =
		    if getFn nd
		      then l
		      else (
			setFn (nd, true);
			nd :: List.foldl dfs l (Node.succs nd))
	      val nodes = dfs (entry, [])
	      in
		List.app (fn nd => setFn(nd, false)) nodes;
		nodes
	      end

      (* apply a function to all of the nodes in the graph rooted at the entry to the statement *)
	fun apply (f : node -> unit) (CFG{entry, ...}) = let
	      val {getFn, setFn} = PropList.newFlag (fn (ND{props, ...}) => props)
	      fun dfs (nd, l) =
		    if getFn nd
		      then l
		      else (
			f nd; (* visit *)
			setFn (nd, true);
			nd :: List.foldl dfs l (Node.succs nd))
	      val nodes = dfs (entry, [])
	      in
		List.app (fn nd => setFn(nd, false)) nodes
	      end

      (* delete a simple node from a CFG *)
	fun deleteNode (nd as ND{kind, ...}) = (case kind
	       of ASSIGN{pred = ref pred, succ = ref succ, ...} => (
		    Node.setPred (succ, pred);
		    case Node.kind pred
		     of COND{trueBranch, falseBranch, ...} => (
			(* note that we treat each branch independently, so that we handle the
			 * situation where both branches are the same node.
			 *)
			  if Node.same(!trueBranch, nd)
			    then Node.setTrueBranch(pred, succ)
			    else ();
			  if Node.same(!falseBranch, nd)
			    then Node.setFalseBranch(pred, succ)
			    else ())
		      | _ => Node.setSucc (pred, succ)
		    (* end case *))
		| _ => raise Fail "unsupported deleteNode"
	      (* end case *))

      (* replace a simple node in a cfg with a subgraph *)
	fun replaceNode (oldNd as ND{kind, ...}, node) = (case kind
	       of ASSIGN{pred, succ, ...} => (
		    Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
		    Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
		| NEW{pred, succ, ...} => (
		    Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
		    Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
		| EXIT{pred, ...} =>
		    Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node}
		| _ => raise Fail "unsupported replaceNode"
	      (* end case *))

      (* replace a simple node in a cfg with a subgraph *)
	fun replaceNodeWithCFG (nd as ND{kind, ...}, cfg as CFG{entry, exit}) =
	      if isEmpty cfg
		then deleteNode nd
		else (case kind
		   of ASSIGN{pred, succ, ...} => (
			Node.replaceInEdge {src = !pred, oldDst = nd, dst = entry};
			Node.replaceOutEdge {oldSrc = nd, src = exit, dst = !succ})
		    | _ => raise Fail "unsupported replaceNodeWithCFG"
		  (* end case *))

      (* concatenate two CFGs *)
	fun concat (cfg1 as CFG{entry=e1, exit=x1}, cfg2 as CFG{entry=e2, exit=x2}) =
	      if isEmpty cfg1 then cfg2
	      else if isEmpty cfg2 then cfg1
	      else (
		Node.setSucc (x1, e2);
		Node.setPred (e2, x1);
		CFG{entry = e1, exit = x2})

      (* append a node to a CFG *)
	fun appendNode (cfg as CFG{entry, exit}, nd) =
	      if isEmpty cfg
		then CFG{entry=nd, exit=nd}
		else (
		  Node.setPred (nd, exit);
		  Node.setSucc (exit, nd);
		  CFG{entry=entry, exit=nd})

      (* update the exit of a CFG by modifying the live variable list *)
	fun updateExit (CFG{entry, exit as ND{kind, ...}}, f) = let
	      val newExit = (case kind
		     of EXIT{pred, kind, live} => let
			  val newNd = Node.mkEXIT(kind, f live)
			  in
			    Node.replaceInEdge {src = !pred, oldDst = exit, dst = newNd};
			    newNd
			  end
		      | _ => raise Fail "bogus exit node for updateExit"
		    (* end case *))
	      in
		CFG{entry=entry, exit=newExit}
	      end
      end

    structure RHS =
      struct
	fun vars rhs = (case rhs
	       of VAR x => [x]
		| LIT _ => []
		| OP(rator, xs) => xs
		| APPLY(g, xs) => xs
		| CONS(ty, xs) => xs
	      (* end case *))

	fun map f = let
	      fun mapf rhs = (case rhs
		     of VAR x => VAR(f x)
		      | LIT _ => rhs
		      | OP(rator, xs) => OP(rator, List.map f xs)
		      | APPLY(g, xs) => APPLY(g, List.map f xs)
		      | CONS(ty, xs) => CONS(ty, List.map f xs)
		    (* end case *))
	      in
		mapf
	      end

	fun app f = let
	      fun mapf rhs = (case rhs
		     of VAR x => f x
		      | LIT _ => ()
		      | OP(rator, xs) => List.app f xs
		      | APPLY(_, xs) => List.app f xs
		      | CONS(ty, xs) => List.app f xs
		    (* end case *))
	      in
		mapf
	      end

      (* return a string representation of a rhs *)
	fun toString rhs = (case rhs
	       of VAR x => Var.toString x
		| LIT lit => Literal.toString lit
		| OP(rator, xs) => String.concat [
		      Op.toString rator,
		      "(", String.concatWith "," (List.map Var.toString xs), ")"
		    ]
		| APPLY(f, xs) => String.concat [
		      ILBasis.toString f,
		      "(", String.concatWith "," (List.map Var.toString xs), ")"
		    ]
		| CONS(ty, xs) => String.concat [
		      "<", Ty.toString ty, ">[",
		      String.concatWith "," (List.map Var.toString xs), "]"
		    ]
	      (* end case *))
      end

  (* return a string representation of a variable binding *)
    fun vbToString VB_NONE = "NONE"
      | vbToString (VB_RHS rhs) = concat["RHS(", RHS.toString rhs, ")"]
      | vbToString (VB_PHI xs) = concat[
	    "PHI(", String.concatWith "," (List.map Var.toString xs), ")"
	  ]
      | vbToString VB_PARAM = "PARAM"


  (* return a string representation of a PHI node *)
    fun phiToString (y, xs) = String.concat [
	    Ty.toString(Var.ty y), " ", Var.toString y, " = PHI(",
	    String.concatWith "," (List.map Var.toString xs), ")"
	  ]

  (* return a string representation of an assignment *)
    fun assignToString (y, rhs) =
	  String.concat [Ty.toString(Var.ty y), " ", Var.toString y, " = ", RHS.toString rhs]

  end (* SSAFn *)

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