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

SCM Repository

[diderot] View of /branches/vis15/src/compiler/cfg-ir/dom-tree-fn.sml
ViewVC logotype

View of /branches/vis15/src/compiler/cfg-ir/dom-tree-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3522 - (download) (annotate)
Sun Dec 20 14:20:20 2015 UTC (4 years, 7 months ago) by jhr
File size: 4312 byte(s)
working on merge
(* dom-tree-fn.sml
 *
 * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
 *
 * COPYRIGHT (c) 2015 The University of Chicago
 * All rights reserved.
 *)

signature DOMINANCE_TREE =
  sig

    structure IR : SSA

  (* compute the dominance-tree information for a CFG *)
    val computeTree : IR.cfg -> unit

  (* return the dominance-tree children associated with a given node.
   * For a conditional, the true child proceeds the false child (if
   * both are dominance-tree children)
   *)
    val children : IR.node -> IR.node list

  (* cleanup the node properties used to store information about the tree *)
    val clear : IR.cfg -> unit

  end

functor DomTreeFn (IR : SSA) : DOMINANCE_TREE = struct

    structure IR = IR
    structure Nd = IR.Node

  (* a property for COND nodes that maps them to their associated JOIN node
   * (if one exists).
   *)
    val {
	  peekFn = getJoin : IR.node -> IR.node option,
	  setFn = setJoin, clrFn = clrJoin, ...
	} = Nd.newProp (fn _ => raise Fail "join property")

  (* an element on the stack of open COND nodes. *)
    datatype open_if
      = THEN_BR of {cond : IR.node, elseBr : IR.node}
      | ELSE_BR of {cond : IR.node}

  (* compute the dominance-tree information for a CFG.  Most of the immediate
   * dominator info is already present in the graph, but there are two interesting
   * cases: JOIN nodes and FOREACH nodes.  We also need tree edges from
   * COND nodes to their matching JOIN (it it exists).  We use properties
   * to implemented these edges
   *)
    fun computeTree cfg = let
	  fun walk (ifStk : open_if list, nd) = (case Nd.kind nd
		 of IR.NULL => raise Fail "unexpected NULL node"
		  | IR.ENTRY{succ} => walk (ifStk, !succ)
		  | IR.JOIN{preds, succ, ...} =>
		      if (List.length(!preds) > 1)
			then (case ifStk
			   of [] => raise Fail "unmatched JOIN"
			    | THEN_BR{cond, elseBr}::r => (
				setJoin(cond, nd);
				walk (ELSE_BR{cond=cond}::r, elseBr))
			    | ELSE_BR{cond}::r => (
				walk (r, !succ))
			  (* end case *))
			else walk(List.tl ifStk, !succ)
		  | IR.COND{trueBranch, falseBranch, ...} =>
		      walk (THEN_BR{cond=nd, elseBr = !falseBranch}::ifStk, !trueBranch)
		  | IR.FOREACH{bodyEntry, succ, ...} => (
		      walk ([], !bodyEntry);
		      walk (ifStk, !succ))
		  | IR.COM{succ, ...} => walk (ifStk, !succ)
		  | IR.ASSIGN{succ, ...} => walk (ifStk, !succ)
		  | IR.MASSIGN{succ, ...} => walk (ifStk, !succ)
                  | IR.GASSIGN{succ, ...} => walk (ifStk, !succ)
		  | IR.NEW{succ, ...} => walk (ifStk, !succ)
                  | IR.SAVE{succ, ...} => walk (ifStk, !succ)
		  | IR.EXIT _ => resume ifStk
		(* end case *))
	  and resume [] = ()
	    | resume (THEN_BR{cond, elseBr}::r) = walk (ELSE_BR{cond=cond}::r, elseBr)
	    | resume (ELSE_BR{cond}::r) = (case getJoin cond
		 of NONE => resume r
		  | SOME nd' => walk(r, nd')
		(* end case *))
	  in
	    walk ([], IR.CFG.entry cfg)
	  end

  (* get the dominance-tree children associated with a given node *)
    fun children nd = let
	(* check to see if a successor node is immediately dominated by nd. *)
	  fun maybeSucc (ref nd') = (case Nd.kind nd'
		 of IR.JOIN{preds, ...} => (case !preds
		       of [_] => [nd'] (* JOIN with single predecessor *)
			| _ => []
		      (* end case *))
		  | IR.COM{succ, ...} => maybeSucc succ (* skip comments *)
		  | _ => [nd']
		(* end case *))
	  in
	    case Nd.kind nd
	     of IR.NULL => raise Fail "unexpected NULL node"
	      | IR.ENTRY{succ} => maybeSucc succ
	      | IR.JOIN{succ, ...} => maybeSucc succ
	      | IR.COND{trueBranch, falseBranch, ...} => (case getJoin nd
		   of SOME nd' => maybeSucc trueBranch @ maybeSucc falseBranch @ [nd']
		    | NONE => [!trueBranch, !falseBranch]
		  (* end case *))
	      | IR.FOREACH{bodyEntry, succ, ...} => [!bodyEntry, !succ]
	      | IR.COM{succ, ...} => maybeSucc succ
	      | IR.ASSIGN{succ, ...} => maybeSucc succ
	      | IR.MASSIGN{succ, ...} => maybeSucc succ
	      | IR.GASSIGN{succ, ...} => maybeSucc succ
	      | IR.NEW{succ, ...} => maybeSucc succ
	      | IR.SAVE{succ, ...} => maybeSucc succ
	      | IR.EXIT _ => []
	    (* end case *)
	  end

  (* cleanup the node properties used to store information about the tree *)
    fun clear cfg = IR.CFG.apply clrJoin cfg

  end

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