suzanne.soy/profile
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

finally, make the topological-sort do a topological sort instead of a BFS

Browse Source 
svn: r14802

original commit: 133f044a3380414b53d374770a4fd88445a2f270
This commit is contained in:
Eli Barzilay 2009-05-14 07:23:09 +00:00
parent 1c08ab0224
commit 70a66f21b9
1 changed files with 43 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/profile/analyzer.ss
View File

@ -144,30 +144,57 @@
nodes nodes
*-node))) *-node)))
;; A simple topological sort of nodes using BFS, starting from node `x' which ;; A simple topological sort of nodes using BFS, starting from node `x' (which
;; will be the special *-node. `subsort' is a `resolver' function to sort ;; will be given as the special *-node). `subsort' is a `resolver' function to
;; nodes on the same level. ;; sort nodes on the same level.
(define (topological-sort x subsort) (define (topological-sort x subsort)
(let loop ([todo (list x)] [seen (list x)]) (let loop ([todo (list x)] [sorted (list x)])
(if (null? todo) (if (null? todo)
'() (reverse sorted)
(let* ([next (append-map (lambda (x) (let* (;; take the next level of nodes
(subsort (map edge-callee (node-callees x)))) [next (append-map (lambda (x) (map edge-callee (node-callees x)))
todo)] todo)]
[next (remq* seen (remove-duplicates next))]) ;; remove visited and duplicates
(append todo (loop next (append next seen))))))) [next (remove-duplicates (remq* sorted next))]
;; leave only nodes with no other incoming edges
[next* (filter (lambda (node)
(andmap (lambda (e) (memq (edge-caller e) sorted))
(node-callers node)))
next)]
;; but if all nodes have other incoming edges, then there must be
;; a cycle, so just do them now (instead of dropping them)
[next (if (and (null? next*) (pair? next)) next next*)]
;; sort using subsort
[next (subsort next)])
(loop next (append (reverse next) sorted))))))
#| #|
(define (node id) (make-node id #f '() 0 0 '() '())) (define-syntax-rule (letnodes [id ...] body ...)
(let ([id (make-node 'id #f '() 0 0 '() '())] ...) body ...))
(define (X . -> . Y) (define (X . -> . Y)
(let ([e (make-edge 0 X 0 Y 0)]) (let ([e (make-edge 0 X 0 Y 0)])
(set-node-callers! Y (cons e (node-callers Y))) (set-node-callers! Y (cons e (node-callers Y)))
(set-node-callees! X (cons e (node-callees X))))) (set-node-callees! X (cons e (node-callees X)))))
(define A (node 'A)) (letnodes [A B C]
(define B (node 'B))
(define C (node 'C))
(A . -> . B) (A . -> . B)
(B . -> . C) (B . -> . C)
(topological-sort A 3) (equal? (topological-sort A values)
(list A B C)))
(letnodes [A B C]
;; check that a cycle doesn't lead to dropping nodes
(A . -> . B)
(A . -> . C)
(B . -> . A)
(B . -> . C)
(C . -> . A)
(C . -> . B)
(null? (remq* (topological-sort A values) (list A B C))))
(letnodes [A B C D]
(A . -> . B)
(B . -> . C)
(C . -> . D)
(A . -> . D)
(equal? (topological-sort A values)
(list A B C D)))
|# |#
;; Groups raw samples by their thread-id, returns a vector with a field for ;; Groups raw samples by their thread-id, returns a vector with a field for