source: project/release/4/graph-ssa/trunk/ssa.scm @ 14375

Last change on this file since 14375 was 14375, checked in by Ivan Raikov, 11 years ago

graph-ssa ported to Chicken 4

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