guile-prescheme/ps-compiler/util/dominators.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey, Mark Reinhold
;;;
;;;   scheme48-1.9.2/ps-compiler/util/dominators.scm
;;;
;;;;; 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-module (ps-compiler util dominators)
  #:use-module (srfi srfi-9)
  #:use-module (prescheme scheme48)
  #:use-module (ps-compiler util util)
  #:export (find-dominators!))

(define-record-type :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))