Annotation of /trunk/src/compiler/IL/dom-tree-fn.sml

Parent Directory | Revision Log

---

Revision 1640 - (view) (download)

1 :	jhr	1115	(* dom-tree-fn.sml
2 :			*
3 :			* COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :			* All rights reserved.
5 :			*)
6 :
7 :			signature DOMINANCE_TREE =
8 :			sig
9 :
10 :			structure IL : SSA
11 :
12 :			(* compute the dominance-tree information for a CFG *)
13 :			val computeTree : IL.cfg -> unit
14 :
15 :			(* return the dominance-tree children associated with a given node. Note that children,
16 :			* which are immediate successors of the node, will be listed first.
17 :			*)
18 :			val children : IL.node -> IL.node list
19 :
20 :			(* cleanup the node properties used to store information about the tree *)
21 :			val clear : IL.cfg -> unit
22 :
23 :			end
24 :
25 :			functor DomTreeFn (IL : SSA) : DOMINANCE_TREE = struct
26 :
27 :			structure IL = IL
28 :			structure Nd = IL.Node
29 :
30 :			(* a property for COND nodes that maps them to their associated JOIN node
31 :			* (if one exists).
32 :			*)
33 :			val {
34 :			peekFn = getJoin : IL.node -> IL.node option,
35 :			setFn = setJoin, clrFn = clrJoin, ...
36 :			} = Nd.newProp (fn _ => raise Fail "join property")
37 :
38 :			(* an element on the stack of open COND nodes. *)
39 :			datatype open_if
40 :			= THEN_BR of {cond : IL.node, elseBr : IL.node}
41 :			| ELSE_BR of {cond : IL.node}
42 :
43 :			(* compute the dominance-tree information for a CFG. Most of the immediate
44 :			* dominator info is already present in the tree, since JOIN nodes are the
45 :			* only ones with multiple predecessors, but we also need tree edges from
46 :			* COND nodes to their matching JOIN (it it exists). We use properties
47 :			* to implemented these edges
48 :			*)
49 :			fun computeTree cfg = let
50 :			fun walk (ifStk : open_if list, nd) = (case Nd.kind nd
51 :			of IL.NULL => raise Fail "unexpected NULL node"
52 :			| IL.ENTRY{succ} => walk (ifStk, !succ)
53 :			| IL.JOIN{preds, succ, ...} =>
54 :			if (List.length(!preds) > 1)
55 :			then (case ifStk
56 :			of [] => raise Fail "unmatched JOIN"
57 :			| THEN_BR{cond, elseBr}::r => (
58 :			setJoin(cond, nd);
59 :			walk (ELSE_BR{cond=cond}::r, elseBr))
60 :			| ELSE_BR{cond}::r => (
61 :			walk (r, !succ))
62 :			(* end case *))
63 :			else walk(List.tl ifStk, !succ)
64 :			| IL.COND{trueBranch, falseBranch, ...} =>
65 :			walk (THEN_BR{cond=nd, elseBr = !falseBranch}::ifStk, !trueBranch)
66 :			| IL.COM{succ, ...} => walk (ifStk, !succ)
67 :			| IL.ASSIGN{succ, ...} => walk (ifStk, !succ)
68 :	jhr	1640	| IL.MASSIGN{succ, ...} => walk (ifStk, !succ)
69 :	jhr	1115	| IL.NEW{succ, ...} => walk (ifStk, !succ)
70 :	jhr	1640	| IL.SAVE{succ, ...} => walk (ifStk, !succ)
71 :	jhr	1115	| IL.EXIT _ => resume ifStk
72 :			(* end case *))
73 :			and resume [] = ()
74 :			| resume (THEN_BR{cond, elseBr}::r) = walk (ELSE_BR{cond=cond}::r, elseBr)
75 :			| resume (ELSE_BR{cond}::r) = (case getJoin cond
76 :			of NONE => resume r
77 :			| SOME nd' => walk(r, nd')
78 :			(* end case *))
79 :			in
80 :			walk ([], IL.CFG.entry cfg)
81 :			end
82 :
83 :			(* get the dominance-tree children associated with a given node *)
84 :			fun children nd = let
85 :			(* check to see if a successor node is immediately dominated by nd. *)
86 :			fun maybeSucc (ref nd') = (case Nd.kind nd'
87 :			of IL.JOIN{preds, ...} => (case !preds
88 :			of [_] => [nd'] (* JOIN with single predecessor *)
89 :			| _ => []
90 :			(* end case *))
91 :			| IL.COM{succ, ...} => maybeSucc succ (* skip comments *)
92 :			| _ => [nd']
93 :			(* end case *))
94 :			in
95 :			case Nd.kind nd
96 :			of IL.NULL => raise Fail "unexpected NULL node"
97 :			| IL.ENTRY{succ} => maybeSucc succ
98 :			| IL.JOIN{succ, ...} => maybeSucc succ
99 :			| IL.COND{trueBranch, falseBranch, ...} => (case getJoin nd
100 :			of SOME nd' => [!trueBranch, !falseBranch, nd']
101 :			| NONE => [!trueBranch, !falseBranch]
102 :			(* end case *))
103 :			| IL.COM{succ, ...} => maybeSucc succ
104 :			| IL.ASSIGN{succ, ...} => maybeSucc succ
105 :	jhr	1640	| IL.MASSIGN{succ, ...} => maybeSucc succ
106 :	jhr	1115	| IL.NEW{succ, ...} => maybeSucc succ
107 :	jhr	1640	| IL.SAVE{succ, ...} => maybeSucc succ
108 :	jhr	1115	| IL.EXIT _ => []
109 :			(* end case *)
110 :			end
111 :
112 :			(* cleanup the node properties used to store information about the tree *)
113 :			fun clear cfg = IL.CFG.apply clrJoin cfg
114 :
115 :			end

---

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