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

SCM Repository

[diderot] Annotation of /branches/pure-cfg/src/compiler/IL/dom-tree-fn.sml
ViewVC logotype

Annotation of /branches/pure-cfg/src/compiler/IL/dom-tree-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3349 - (view) (download)

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

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