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

402 lines
13 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; General transitive closure
; (make-graph-from-predecessors nodes node-parents node-temp set-node-temp!)
; -> graph
; (make-graph-from-successors nodes node-kids node-temp set-node-temp!)
; -> graph
;
; (transitive-or! graph elements set-elements! element-temp set-element-temp!)
; (transitive-or-with-kill! graph elements set-elements! node-kills element-temp set-element-temp!)
; (transitive-or-with-pass! graph elements set-elements! node-passes element-temp set-element-temp!)
;
; (transitive-and! graph elements set-elements! element-temp set-element-temp!)
; (transitive-and-with-kill! graph elements set-elements! node-kills element-temp set-element-temp!)
; (transitive-and-with-pass! graph elements set-elements! node-passes element-temp set-element-temp!)
;----------------
(define (make-graph-from-predecessors user-nodes user-node-parents node-temp set-node-temp!)
(let ((nodes (make-nodes user-nodes set-node-temp!)))
(connect-nodes-using-parents! nodes user-node-parents node-temp)
(for-each (lambda (node)
(set-node-temp! (node-data node) #f))
nodes)
(make-graph nodes)))
(define (make-graph-from-successors user-nodes user-node-kids node-temp set-node-temp!)
(let ((nodes (make-nodes user-nodes set-node-temp!)))
(connect-nodes-using-children! nodes user-node-kids node-temp)
(for-each (lambda (node)
(set-node-temp! (node-data node) #f))
nodes)
(make-graph nodes)))
(define (make-nodes user-nodes set-node-temp!)
(map (lambda (data)
(let ((node (node-maker data '() '())))
(set-node-temp! data node)
node))
user-nodes))
(define-record-type graph
(nodes ; list of nodes
)
())
(define make-graph graph-maker)
(define-record-type node
(data ; user's data
(parents) ; predecessors
(kids)) ; successors
(elt-set ; elements
kill-set ; elements that are not passed
changed? ; change flag for iteration
))
;------------------------------
; Six false fronts for the real procedure.
(define (transitive-or! graph elts set-elts! elt-hash set-elt-hash!)
(do-it graph elts set-elts! #f #f elt-hash set-elt-hash!
(transitive-or-closure! or-update-node)))
(define (transitive-or-with-kill! graph elts set-elts! kill-elts elt-hash set-elt-hash!)
(do-it graph elts set-elts! kill-elts #f elt-hash set-elt-hash!
(transitive-or-closure! or-update-node-with-kill)))
(define (transitive-or-with-pass! graph elts set-elts! pass-elts elt-hash set-elt-hash!)
(do-it graph elts set-elts! pass-elts #t elt-hash set-elt-hash!
(transitive-or-closure! or-update-node-with-kill)))
(define (transitive-and! graph elts set-elts! elt-hash set-elt-hash!)
(do-it graph elts set-elts! #f #f elt-hash set-elt-hash!
(transitive-and-closure! and-update-node)))
(define (transitive-and-with-kill! graph elts set-elts! kill-elts elt-hash set-elt-hash!)
(do-it graph elts set-elts! kill-elts #f elt-hash set-elt-hash!
(transitive-and-closure! and-update-node-with-kill)))
(define (transitive-and-with-pass! graph elts set-elts! pass-elts elt-hash set-elt-hash!)
(do-it graph elts set-elts! pass-elts #t elt-hash set-elt-hash!
(transitive-and-closure! and-update-node-with-kill)))
(define (do-it graph elts set-elts! kill-elts pass? elt-hash set-elt-hash! op)
(let* ((nodes (graph-nodes graph))
(elt-unhash-vec (add-elements! nodes elts kill-elts pass?
elt-hash set-elt-hash!)))
(op nodes)
(record-results! nodes elt-unhash-vec set-elts!)
(do ((i 0 (+ i 1)))
((= i (vector-length elt-unhash-vec)))
(set-elt-hash! (vector-ref elt-unhash-vec i) #f))
(values)))
;----------------
; Setting the kids field of the nodes
(define (connect-nodes-using-children! nodes children node-slot)
(for-each
(lambda (node)
(set-node-kids! node
(map (lambda (kid)
(let ((t (node-slot kid)))
(if (not (node? t))
(missing-node-error kid "child" node))
(set-node-parents! t
(cons node
(node-parents t)))
t))
(children (node-data node)))))
nodes))
(define (connect-nodes-using-parents! nodes parents node-slot)
(for-each
(lambda (node)
(set-node-parents! node
(map (lambda (parent)
(let ((t (node-slot parent)))
(if (not (node? t))
(missing-node-error t "parent" node))
(set-node-kids! t
(cons node
(node-kids t)))
t))
(parents (node-data node)))))
nodes))
(define (missing-node-error node relationship relation)
(error (format #f "Transitive - ~S, ~A of ~S, not in list of nodes"
node relationship (node-data relation))))
;----------------
(define (add-elements! nodes node-elements node-kills pass?
element-temp set-element-temp!)
(let ((unhash-vec (element-hasher nodes node-elements element-temp set-element-temp!))
(element-hash (make-element-hash element-temp)))
(for-each (lambda (node)
(set-node-elt-set! node
(make-element-set (node-elements (node-data node))
element-hash)))
nodes)
(if node-kills
(for-each (lambda (node)
(let ((kill-set (make-element-set (node-kills (node-data node))
element-hash)))
(set-node-kill-set! node (if pass?
(integer-set-not kill-set)
kill-set))))
nodes))
unhash-vec))
(define (make-element-set elts elt-hash)
(let loop ((elts elts) (set (make-empty-integer-set)))
(if (null? elts)
set
(loop (cdr elts)
(cond ((elt-hash (car elts))
=> (lambda (hash)
(add-to-integer-set set hash)))
(else set))))))
;----------------
; Counting the elements and assigning numbers to them
(define-record-type element-hash
(number ; the element-hash record is just a way of tagging this number
) ; with a unique predicate
())
(define (element-hasher nodes elts elt-hash set-elt-hash!)
(let loop ((to-do '()) (ts nodes) (all-elts '()) (count 0))
(cond ((null? to-do)
(if (null? ts)
(real-element-hasher all-elts count)
(loop (elts (node-data (car ts))) (cdr ts) all-elts count)))
((element-hash? (elt-hash (car to-do)))
(loop (cdr to-do) ts all-elts count))
(else
(set-elt-hash! (car to-do) (element-hash-maker count))
(loop (cdr to-do) ts (cons (car to-do) all-elts) (+ count 1))))))
(define (real-element-hasher elts count)
(let ((unhash-vec (make-vector count)))
(do ((i (- count 1) (- i 1))
(elts elts (cdr elts)))
((null? elts))
(vector-set! unhash-vec i (car elts)))
unhash-vec))
(define (make-element-hash elt-hash)
(lambda (elt)
(let ((hash (elt-hash elt)))
(if (element-hash? hash)
(element-hash-number hash)
#f))))
;----------------
; Turn the element sets into lists of elements and clean up stray pointers
; at the same time.
(define (record-results! nodes elt-unhash-vec set-elts!)
(for-each (lambda (node)
(set-elts! (node-data node)
(map-over-integer-set
(lambda (i) (vector-ref elt-unhash-vec i))
(node-elt-set node)))
(set-node-elt-set! node #f)
(set-node-kill-set! node #f))
nodes))
;----------------
; The OR algorithm - keeps passing elements around until the changes stop.
(define (transitive-or-closure! op)
(lambda (nodes)
(for-each (lambda (node)
(set-node-changed?! node #t))
nodes)
(let loop ((to-do nodes))
(if (not (null? to-do))
(let* ((node (car to-do))
(elt-set (node-elt-set node)))
(set-node-changed?! node #f)
(let kids-loop ((ts (node-kids node))
(to-do (cdr to-do)))
(cond ((null? ts)
(loop to-do))
((and (op (car ts) elt-set)
(not (node-changed? (car ts))))
(set-node-changed?! (car ts) #t)
(kids-loop (cdr ts) (cons (car ts) to-do)))
(else
(kids-loop (cdr ts) to-do)))))))))
; The weird function INTEGER-SET-SUBTRACT&IOR-WITH-TEST! takes three integer
; sets, subtracts the second from the first and inclusive OR's the result
; with the third. It returns the resulting set and a flag which is #T if
; the result is not the same as the original third set. The inclusive OR
; may be destructive.
(define (or-update-node-with-kill node elt-set)
(receive (set change?)
(integer-set-subtract&ior-with-test! elt-set
(node-kill-set node)
(node-elt-set node))
(set-node-elt-set! node set)
change?))
(define (or-update-node node elt-set)
(receive (set change?)
(integer-set-ior-with-test! elt-set
(node-elt-set node))
(set-node-elt-set! node set)
change?))
; Implementations using simpler, nondestructive operations (these might be
; done more efficiently if they had access to the underlying representation
; of integer sets).
(define (integer-set-subtract&ior-with-test! set1 set2 set3)
(let ((result (integer-set-ior set3 (integer-set-subtract set1 set2))))
(values result (not (integer-set-equal? set3 result)))))
(define (integer-set-ior-with-test! set1 set3)
(let ((result (integer-set-ior set3 set1)))
(values result (not (integer-set-equal? set3 result)))))
;----------------
; The AND algorithm - keeps a to-do list of nodes whose parents' elements
; have changed, instead of a list of nodes whose elements have changed.
(define (transitive-and-closure! op)
(lambda (nodes)
(let loop ((to-do (filter (lambda (node)
(if (not (null? (node-parents node)))
(begin
(set-node-changed?! node #t)
#t)
#f))
nodes)))
(if (not (null? to-do))
(let ((node (car to-do)))
(set-node-changed?! node #f)
(if (op node)
(let kids-loop ((ts (node-kids node))
(to-do (cdr to-do)))
(cond ((null? ts)
(loop to-do))
((node-changed? (car ts))
(kids-loop (cdr ts) to-do))
(else
(set-node-changed?! (car ts) #t)
(kids-loop (cdr ts) (cons (car ts) to-do)))))
(loop (cdr to-do))))))))
; These are the same as for OR except that we AND together the parents'
; elt-sets instead of using the one provided.
(define (and-update-node-with-kill node)
(receive (set change?)
(integer-set-subtract&ior-with-test! (parents-elt-set node)
(node-kill-set node)
(node-elt-set node))
(set-node-elt-set! node set)
change?))
(define (and-update-node node)
(receive (set change?)
(integer-set-ior-with-test! (parents-elt-set node)
(node-elt-set node))
(set-node-elt-set! node set)
change?))
(define (parents-elt-set node)
(do ((parents (cdr (node-parents node))
(cdr parents))
(elts (node-elt-set (car (node-parents node)))
(integer-set-and elts (node-elt-set (car parents)))))
((null? parents)
elts)))
;------------------------------------------------------------
; Testing
; GRAPH is ((<symbol> name
; (element*) elements
; (element*) kills
; . <symbol*>)*) children
;
'((node1 (elt1 elt2) () node2)
(node2 (elt3) (elt2) node1 node3)
(node3 () () ))
'((a (1) () b)
(b () () ))
'((a (1 2 3 4) (1) b)
(b () (2) c)
(c () (3) d)
(d (5) (4) a))
(define (test-transitive graph down? or? pass?)
(let* ((elts '())
(get-elt (lambda (sym)
(cond ((first (lambda (v)
(eq? sym (vector-ref v 0)))
elts)
=> identity)
(else
(let ((new (vector sym #f)))
(set! elts (cons new elts))
new)))))
(vertices (map (lambda (n)
(vector (car n)
(map get-elt (cadr n))
(map get-elt (caddr n))
#f #f))
graph)))
(for-each (lambda (data vertex)
(vector-set! vertex 3 (map (lambda (s)
(first (lambda (v)
(eq? s (vector-ref v 0)))
vertices))
(cdddr data))))
graph
vertices)
(let ((the-graph ((if down?
make-graph-from-successors
make-graph-from-predecessors)
vertices
(lambda (x) (vector-ref x 3))
(lambda (x) (vector-ref x 4))
(lambda (x v) (vector-set! x 4 v)))))
(if (every? (lambda (n) (null? (caddr n))) graph)
((if or? transitive-or! transitive-and!)
the-graph
(lambda (v) (vector-ref v 1)) ; elts
(lambda (v x) (vector-set! v 1 x)) ; set-elts!
(lambda (e) (vector-ref e 1)) ; elt-hash
(lambda (e x) (vector-set! e 1 x))) ; set-elt-hash!
((if or?
(if pass?
transitive-or-with-pass!
transitive-or-with-kill!)
(if pass?
transitive-and-with-pass!
transitive-and-with-kill!))
the-graph
(lambda (v) (vector-ref v 1)) ; elts
(lambda (v x) (vector-set! v 1 x)) ; set-elts!
(lambda (v) (vector-ref v 2)) ; kills
(lambda (e) (vector-ref e 1)) ; elt-hash
(lambda (e x) (vector-set! e 1 x))))) ; set-elt-hash!
(map (lambda (v)
(list (vector-ref v 0)
(map (lambda (e) (vector-ref e 0))
(vector-ref v 1))))
vertices)))