1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Finding where to put phi-functions.
;
; First call:
; (GRAPH->SSA-GRAPH! <root-node> <node-successors> <node-temp> <set-node-temp!>)
;
; Then:
; (FIND-JOINS <nodes> <node-temp>)
; will return the list of nodes N for which there are (at least) two paths
; ... N_0 M_0 ... M_i N and ... N_1 P_0 ... P_j N such that N_0 and N_1
; are distinct members of <nodes> and the M's and P's are disjoint sets.
;
; Algorithm from:
; Efficiently computing static single assignment form and the control
; dependence graph,
; Ron Cytron, Jeanne Ferrante, Barry K. Rosen, Mark N. Wegman, and
; F. Kenneth Zadeck,
; ACM Transactions on Programming Languages and Systems 1991 13(4)
; pages 451-490
(define-record-type ssa-node :node
(really-make-node data use-uid predecessors dominator dominated
seen-mark join-mark)
node?
(data node-data) ; user's stuff
(use-uid node-use-uid) ; distinguishes between different invocations
(successors node-successors ; parents
set-node-successors!)
(predecessors node-predecessors ; and children in the graph
set-node-predecessors!)
(dominator node-dominator ; parent ;; initialize for goofy dominator code
set-node-dominator!)
(dominated node-dominated ; and children in the dominator tree
set-node-dominated!)
(frontier node-frontier ; dominator frontier
set-node-frontier!)
(seen-mark node-seen-mark ; two markers used in
set-node-seen-mark!)
(join-mark node-join-mark ; the ssa algorithm
set-node-join-mark!))
(define (make-node data use-uid)
(really-make-node data
use-uid
'() ; predecessors
#f ; dominator
'() ; dominated
-1 ; see-mark
-1)) ; join-mark
(define (graph->ssa-graph! root successors temp set-temp!)
(let ((graph (real-graph->ssa-graph root successors temp set-temp!)))
(find-dominators! (car graph)
node-successors node-predecessors
node-dominator set-node-dominator!)
(for-each (lambda (node)
(let ((dom (node-dominator node)))
(set-node-dominated! dom (cons node (node-dominated dom)))))
(cdr graph)) ; root has no dominator
(find-frontiers! (car graph))
(values)))
; Turn the user's graph into a NODE graph.
(define (real-graph->ssa-graph root successors temp set-temp!)
(let ((uid (next-uid))
(nodes '()))
(let recur ((data root))
(let ((node (temp data)))
(if (and (node? node)
(= uid (node-use-uid node)))
node
(let ((node (make-node data uid)))
(set! nodes (cons node nodes))
(set-temp! data node)
(let ((succs (map recur (successors data))))
(for-each (lambda (succ)
(set-node-predecessors! succ
(cons node (node-predecessors succ))))
succs)
(set-node-successors! node succs))
node))))
(if (any (lambda (node)
(not (eq? node (temp (node-data node)))))
nodes)
(breakpoint "graph made incorrectly"))
(reverse! nodes))) ; root ends up at front
; Find the dominance frontiers of the nodes in a graph.
(define (find-frontiers! node)
(let ((frontier (let loop ((succs (node-successors node)) (frontier '()))
(if (null? succs)
frontier
(loop (cdr succs)
(if (eq? node (node-dominator (car succs)))
frontier
(cons (car succs) frontier)))))))
(let loop ((kids (node-dominated node)) (frontier frontier))
(cond ((null? kids)
(set-node-frontier! node frontier)
frontier)
(else
(let kid-loop ((kid-frontier (find-frontiers! (car kids)))
(frontier frontier))
(if (null? kid-frontier)
(loop (cdr kids) frontier)
(kid-loop (cdr kid-frontier)
(if (eq? node (node-dominator (car kid-frontier)))
frontier
(cons (car kid-frontier) frontier))))))))))
(define (find-joins nodes temp)
(for-each (lambda (n)
(if (not (node? (temp n)))
(begin
(breakpoint "node not seen before ~s" n)
n)))
nodes)
(map node-data (really-find-joins (map temp nodes))))
(define (really-find-joins nodes)
(let ((marker (next-uid)))
(for-each (lambda (n)
(set-node-seen-mark! n marker))
nodes)
(let loop ((to-do nodes) (joins '()))
(if (null? to-do)
joins
(let frontier-loop ((frontier (node-frontier (car to-do)))
(to-do (cdr to-do))
(joins joins))
(cond ((null? frontier)
(loop to-do joins))
((eq? marker (node-join-mark (car frontier)))
(frontier-loop (cdr frontier) to-do joins))
(else
(let ((node (car frontier)))
(set-node-join-mark! node marker)
(frontier-loop (cdr frontier)
(if (eq? marker (node-seen-mark node))
to-do
(begin
(set-node-seen-mark! node marker)
(cons node to-do)))
(cons node joins))))))))))
; Integers as UID's
(define *next-uid* 0)
(define (next-uid)
(let ((uid *next-uid*))
(set! *next-uid* (+ uid 1))
uid))
;----------------------------------------------------------------
; Testing
;(define-record-type data
; (name)
; (kids
; temp))
;
;(define-record-discloser type/data
; (lambda (data)
; (list 'data (data-name data))))
;
;(define (make-test-graph spec)
; (let ((vertices (map (lambda (d)
; (data-maker (car d)))
; spec)))
; (for-each (lambda (data vertex)
; (set-data-kids! vertex (map (lambda (s)
; (first (lambda (v)
; (eq? s (data-name v)))
; vertices))
; (cdr data))))
; spec
; vertices)
; vertices))
;(define g1 (make-test-graph '((a b) (b c d) (c b e) (d d e) (e))))
;(graph->ssa-graph (car g1) data-kids data-temp set-data-temp!)
;(find-joins (list (list-ref g1 0)) data-temp)
|
