scsh-0.6/ps-compiler/util/dominators.scm

274 lines
8.8 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
;;; Find immediate dominators in a directed graph
;;; Mark Reinhold (mbr@research.nj.nec.com)/3 February 1995
; Debugging code removed and everything reluctantly Scheme-ized by
; R. Kelsey, St. Valentine's Day, 1995
; This fast dominator code is based upon Lengauer and Tarjan, "A Fast
; Algorithm for Finding Dominators in a Flowgraph," ACM TOPLAS 1:1, pp.
; 121--141, July 1979. It runs in time $O(|E|\log|V|)$, where $|E|$ is the
; number of edges and $|V|$ is the number of vertices. A smaller time bound
; of $O(|E|\alpha(|E|,|V|))$, where $\alpha$ is the inverse of Ackerman's
; function, can be achieved with more complex versions of the internal link!
; and eval! procedures.
;
; The client provides a rooted, directed graph by passing a root node,
; successor and predecessor functions, and auxiliary procedures for accessing
; and setting a slot in each node. The dominator code creates a shadow of
; the client's graph using the vertex record type defined below. To keep
; things clear, the client's graph is considered to contain "nodes," while
; the shadow graph contains "vertices."
(define-record-type vertex :vertex
(really-make-vertex node semi bucket ancestor debug)
vertex?
(node vertex-node) ; Corresponding node in client's graph
(semi vertex-semi ; A number for this vertex, w, as follows:
set-vertex-semi!) ; After w is numbered, but before its semidominator
; is computed: w's DFS number
; After w's semidominator is computed:
; the number of its semidominator
(parent vertex-parent ; Parent of this vertex in DFS spanning tree
set-vertex-parent!)
(pred vertex-pred ; Parents
set-vertex-pred!)
(label vertex-label ; Label in spanning forest, initially this vertex
set-vertex-label!)
(bucket vertex-bucket ; List of vertices whose semidominator is this vertex
set-vertex-bucket!)
(dom vertex-dom ; A vertex, as follows:
set-vertex-dom!) ; After step 3: If the semidominator of this
; vertex, w, is its immediate dominator, then
; this slot contains that vertex; otherwise,
; this slot is a vertex v whose number is
; smaller than w's and whose immediate dominator
; is also w's immediate dominator
; After step 4: The immediate dominator of this
; vertex
(ancestor vertex-ancestor ; An ancestor of this vertex in the spanning forest
set-vertex-ancestor!)
(debug vertex-debug ; Debug field ##
set-vertex-debug!))
(define (make-vertex node semi)
(really-make-vertex node
semi
'() ; bucket
#f ; ancestor
#f)) ; debug
(define (push-vertex-bucket! inf elt)
(set-vertex-bucket! inf (cons elt (vertex-bucket inf))))
(define (find-dominators-quickly! root ; root node
succ ; maps a node to its children
pred ; maps a node to its parents
slot ; result slot accessor
set-slot!) ; result slot setter
;; Compute the dominator tree of the given rooted, directed graph;
;; when done, the slot of each node will contain its immediate dominator.
;; Requires that each slot initially contain #f.
(define (dfs root)
(let ((n 0) (vertices '()))
(let go ((node root) (parent #f))
(let ((v (make-vertex node n)))
(set-slot! node v)
(set! n (+ n 1))
(set-vertex-parent! v parent)
(set-vertex-label! v v)
(set! vertices (cons v vertices))
(for-each (lambda (node)
(if (not (slot node))
(go node v)))
(succ node))))
(let ((vertex-map (list->vector (reverse! vertices))))
(do ((i 0 (+ i 1)))
((= i (vector-length vertex-map)))
(let ((v (vector-ref vertex-map i)))
(set-vertex-pred! v (map slot (pred (vertex-node v))))))
(values n vertex-map))))
(define (compress! v)
(let ((a (vertex-ancestor v)))
(if (vertex-ancestor a)
(begin
(compress! a)
(if (< (vertex-semi (vertex-label a))
(vertex-semi (vertex-label v)))
(set-vertex-label! v (vertex-label a)))
(set-vertex-ancestor! v (vertex-ancestor (vertex-ancestor v)))))))
(define (eval! v)
(cond ((not (vertex-ancestor v))
v)
(else
(compress! v)
(vertex-label v))))
(define (link! v w)
(set-vertex-ancestor! w v))
(receive (n vertex-map) (dfs root) ; Step 1
(do ((i (- n 1) (- i 1)))
((= i 0))
(let ((w (vector-ref vertex-map i)))
(for-each (lambda (v) ; Step 2
(let ((u (eval! v)))
(if (< (vertex-semi u)
(vertex-semi w))
(set-vertex-semi! w
(vertex-semi u)))))
(vertex-pred w))
(push-vertex-bucket! (vector-ref vertex-map (vertex-semi w)) w)
(link! (vertex-parent w) w)
(for-each (lambda (v) ; Step 3
;; T&L delete v from the bucket list at this point,
;; but there is no reason to do so
(let ((u (eval! v)))
(set-vertex-dom! v
(if (< (vertex-semi u)
(vertex-semi v))
u
(vertex-parent w)))))
(vertex-bucket (vertex-parent w)))))
(do ((i 1 (+ i 1))) ; Step 4
((= i n))
(let ((w (vector-ref vertex-map i)))
(if (not (eq? (vertex-dom w)
(vector-ref vertex-map (vertex-semi w))))
(set-vertex-dom! w
(vertex-dom (vertex-dom w))))))
(set-vertex-dom! (slot root) #f)
;(show-nodes root succ slot) ; ## debug
(do ((i 0 (+ i 1))) ; Set dominator pointers
((= i n))
(let ((w (vector-ref vertex-map i)))
(let ((d (vertex-dom w)))
(set-slot! (vertex-node w) (if d (vertex-node d) #f)))))))
;;; The fast dominator algorithm is difficult to prove correct, so the
;;; following slow code is provided in order to check its results. The slow
;;; algorithm, which runs in time $O(|E||V|)$, is adapted from Aho and Ullman,
;;; _The Theory of Parsing, Translation, and Compiling_, Prentice-Hall, 1973,
;;; p. 916.
(define (find-dominators-slowly! root succ pred slot set-slot!)
(define vertex-succ vertex-pred)
(define set-vertex-succ! set-vertex-pred!)
(define vertex-mark vertex-ancestor)
(define set-vertex-mark! set-vertex-ancestor!)
(define (dfs root)
(let ((n 0) (vertices '()))
(let go ((node root) (parent #f))
(let ((v (make-vertex node n)))
(set-slot! node v)
(set! n (+ n 1))
(set! vertices (cons v vertices))
(set-vertex-parent! v #f)
(set-vertex-label! v #f)
(for-each (lambda (node)
(if (not (slot node))
(go node v)))
(succ node))))
(for-each (lambda (v)
(set-vertex-succ! v (map slot (succ (vertex-node v)))))
vertices)
(values n (reverse! vertices))))
(receive (n vertices) (dfs root)
(define (inaccessible v)
;; Determine set of vertices that are inaccessible if vertex v is ignored
(set-vertex-mark! v #t)
(let go ((w (car vertices)))
(set-vertex-mark! w #t)
(for-each (lambda (u)
(if (not (vertex-mark u))
(go u)))
(vertex-succ w)))
(filter (lambda (w)
(cond
((vertex-mark w)
(set-vertex-mark! w #f)
#f)
(else #t)))
vertices))
(for-each (lambda (v) (set-vertex-dom! v (car vertices)))
(cdr vertices))
(for-each (lambda (v)
(let ((dominated-by-v (inaccessible v)))
(for-each (lambda (w)
(if (eq? (vertex-dom w) (vertex-dom v))
(set-vertex-dom! w v)))
dominated-by-v)))
(cdr vertices))
(set-vertex-dom! (car vertices) #f)
;(show-nodes root succ slot) ; ## debug
(for-each (lambda (v)
(set-slot! (vertex-node v)
(let ((d (vertex-dom v)))
(if d (vertex-node d) #f))))
vertices)))
(define (time-thunk thunk) (thunk))
(define (find-and-check-dominators! root succ pred slot set-slot!)
(let ((set-fast-slot! (lambda (x v) (set-car! (slot x) v)))
(fast-slot (lambda (x) (car (slot x))))
(set-slow-slot! (lambda (x v) (set-cdr! (slot x) v)))
(slow-slot (lambda (x) (cdr (slot x)))))
(let go ((node root))
(set-slot! node (cons #f #f))
(for-each (lambda (node)
(if (not (slot node))
(go node)))
(succ node)))
(let ((fast (time-thunk
(lambda ()
(find-dominators-quickly!
root succ pred fast-slot set-fast-slot!))))
(slow (time-thunk (lambda ()
(find-dominators-slowly!
root succ pred slow-slot set-slow-slot!)))))
; (format #t "** find-and-check-dominators!: fast ~a, slow ~a~%" fast slow) ; ##
(let go ((node root))
(if (not (eq? (fast-slot node) (slow-slot node)))
(bug "Dominator algorithm error"))
(set-slot! node (fast-slot node))
(for-each (lambda (node)
(if (pair? (slot node)) ; ## Assumes nodes are not pairs
(go node)))
(succ node))))))
(define *check?* #t)
(define (find-dominators! . args)
(apply (if *check?*
find-and-check-dominators!
find-dominators-quickly!)
args))