source: project/release/3/graph-ssa/trunk/ssa.scm @ 11135

Last change on this file since 11135 was 11135, checked in by Ivan Raikov, 12 years ago

Imported graph-ssa sources.

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