Doc and code style improvements in the profiler.
original commit: 826a5f360f6690ba7d6c7ffe268e8dca145220b3
This commit is contained in:
Eli Barzilay
parent
bfba3a953f
commit
69c5f48e9a
|
|
@ -6,8 +6,8 @@
|
|||
|
||||
(provide analyze-samples (all-from-out "structs.rkt"))
|
||||
|
||||
(define-syntax-rule (with-hash <hash> <key> <expr>)
|
||||
(hash-ref! <hash> <key> (lambda () <expr>)))
|
||||
(define-syntax-rule (with-hash <hash> <key> <expr> ...)
|
||||
(hash-ref! <hash> <key> (λ () <expr> ...)))
|
||||
|
||||
;; This function analyzes the output of the sampler. Returns a `profile'
|
||||
;; struct holding a list of `node' values, each one representing a node in the
|
||||
|
|
@ -25,17 +25,17 @@
|
|||
(define id+src->node-hash (make-hasheq))
|
||||
(define (id+src->node id+src)
|
||||
(with-hash id+src->node-hash id+src
|
||||
(node (car id+src) (cdr id+src) '() 0 0 '() '())))
|
||||
(node (car id+src) (cdr id+src) '() 0 0 '() '())))
|
||||
;; special node that is the caller of toplevels and callee of leaves
|
||||
(define *-node (id+src->node '(#f . #f)))
|
||||
(define call->edge
|
||||
(let ([t (make-hasheq)])
|
||||
(lambda (ler lee)
|
||||
(λ (ler lee)
|
||||
(with-hash (with-hash t ler (make-hasheq)) lee
|
||||
(let ([e (edge 0 ler 0 lee 0)])
|
||||
(set-node-callers! lee (cons e (node-callers lee)))
|
||||
(set-node-callees! ler (cons e (node-callees ler)))
|
||||
e)))))
|
||||
(define e (edge 0 ler 0 lee 0))
|
||||
(set-node-callers! lee (cons e (node-callers lee)))
|
||||
(set-node-callees! ler (cons e (node-callees ler)))
|
||||
e))))
|
||||
(define total-time 0)
|
||||
(define thread-times (make-vector (vector-length samples-by-thread) 0))
|
||||
(for ([thread-samples (in-vector samples-by-thread)]
|
||||
|
|
@ -50,12 +50,13 @@
|
|||
edge)
|
||||
(define stack ; the stack snapshot, translated to `node' values
|
||||
(for/list ([id+src (in-list (cdr sample))])
|
||||
(let* ([node (id+src->node id+src)] [tids (node-thread-ids node)])
|
||||
(unless (memq thread-id tids)
|
||||
(set-node-thread-ids! node (cons thread-id tids)))
|
||||
node)))
|
||||
(define node (id+src->node id+src))
|
||||
(define tids (node-thread-ids node))
|
||||
(unless (memq thread-id tids)
|
||||
(set-node-thread-ids! node (cons thread-id tids)))
|
||||
node))
|
||||
(define counts (get-counts stack))
|
||||
(define stack+counts (map (lambda (x) (assq x counts)) stack))
|
||||
(define stack+counts (map (λ (x) (assq x counts)) stack))
|
||||
(define edges
|
||||
(if (null? stack)
|
||||
'()
|
||||
|
|
@ -78,19 +79,19 @@
|
|||
(set-node-total! *-node total-time)
|
||||
;; convert the nodes from the hash to a list, do a topological sort, and then
|
||||
;; sort by total time (combining both guarantees(?) sensible order)
|
||||
(let ([nodes (append-map (lambda (nodes) (sort nodes > #:key node-total))
|
||||
(topological-sort *-node))])
|
||||
;; sort all the edges in the nodes according to total time
|
||||
(for ([n (in-list nodes)])
|
||||
(set-node-callees! n (sort (node-callees n) > #:key edge-callee-time))
|
||||
(set-node-callers! n (sort (node-callers n) > #:key edge-caller-time)))
|
||||
(profile total-time
|
||||
cpu-time
|
||||
(length samples)
|
||||
(for/list ([time (in-vector thread-times)] [n (in-naturals 0)])
|
||||
(cons n time))
|
||||
nodes
|
||||
*-node)))
|
||||
(define nodes (append-map (λ (nodes) (sort nodes > #:key node-total))
|
||||
(topological-sort *-node)))
|
||||
;; sort all the edges in the nodes according to total time
|
||||
(for ([n (in-list nodes)])
|
||||
(set-node-callees! n (sort (node-callees n) > #:key edge-callee-time))
|
||||
(set-node-callers! n (sort (node-callers n) > #:key edge-caller-time)))
|
||||
(profile total-time
|
||||
cpu-time
|
||||
(length samples)
|
||||
(for/list ([time (in-vector thread-times)] [n (in-naturals 0)])
|
||||
(cons n time))
|
||||
nodes
|
||||
*-node))
|
||||
|
||||
;; Groups raw samples by their thread-id, returns a vector with a field for
|
||||
;; each thread id holding the sample data for that thread. The samples in
|
||||
|
|
@ -101,8 +102,9 @@
|
|||
(max (car sample) n)))
|
||||
'()))
|
||||
(for ([sample (in-list samples)])
|
||||
(let ([id (car sample)] [data (cdr sample)])
|
||||
(vector-set! threads id (cons data (vector-ref threads id)))))
|
||||
(define id (car sample))
|
||||
(define data (cdr sample))
|
||||
(vector-set! threads id (cons data (vector-ref threads id))))
|
||||
threads)
|
||||
#|
|
||||
(equal? (split-by-thread '())
|
||||
|
|
|
|||
|
|
@ -21,17 +21,16 @@
|
|||
(and periodic-renderer
|
||||
(let ([delay (car periodic-renderer)]
|
||||
[renderer (cadr periodic-renderer)])
|
||||
(thread (lambda ()
|
||||
(let loop ()
|
||||
(sleep delay)
|
||||
(renderer (analyze-samples (sampler 'get-snapshots)))
|
||||
(loop)))))))
|
||||
(define (loop)
|
||||
(sleep delay)
|
||||
(renderer (analyze-samples (sampler 'get-snapshots)))
|
||||
(loop))
|
||||
(thread loop))))
|
||||
(define (run) (for ([i (in-range rpt)]) (thunk)))
|
||||
(with-handlers ([void (lambda (e)
|
||||
(eprintf "profiled thunk error: ~a\n"
|
||||
(if (exn? e)
|
||||
(exn-message e)
|
||||
(format "~e" e))))])
|
||||
(with-handlers ([void (λ (e) (eprintf "profiled thunk error: ~a\n"
|
||||
(if (exn? e)
|
||||
(exn-message e)
|
||||
(format "~e" e))))])
|
||||
(if threads?
|
||||
(parameterize ([current-custodian cust]) (run))
|
||||
(run)))
|
||||
|
|
@ -47,7 +46,7 @@
|
|||
[(null? xs)
|
||||
(if expr
|
||||
(with-syntax ([expr expr] [kwds (reverse kwds)])
|
||||
#'(profile-thunk (lambda () expr) . kwds))
|
||||
#'(profile-thunk (λ () expr) . kwds))
|
||||
(raise-syntax-error 'profile "missing expression" stx))]
|
||||
[(keyword? (syntax-e (car xs)))
|
||||
(if (pair? (cdr xs))
|
||||
|
|
|
|||
|
|
@ -14,15 +14,16 @@
|
|||
(define node->
|
||||
(let ([t (make-hasheq)])
|
||||
(for ([node (in-list nodes)] [idx (in-naturals 1)])
|
||||
(let ([id (node-id node)] [src (node-src node)])
|
||||
(define id (node-id node))
|
||||
(define src (node-src node))
|
||||
(hash-set! t node
|
||||
(list (format "node~a" idx)
|
||||
(if id
|
||||
(format "~a" id)
|
||||
(regexp-replace #rx"^.*/"
|
||||
(format-source (node-src node))
|
||||
""))))))
|
||||
(lambda (mode node)
|
||||
"")))))
|
||||
(λ (mode node)
|
||||
((case mode [(index) car] [(label) cadr]) (hash-ref t node)))))
|
||||
(define max-self%
|
||||
(/ (for/fold ([m 0]) ([node (in-list nodes)]) (max m (node-self node)))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(provide render)
|
||||
|
||||
(require "analyzer.rkt" "utils.rkt" racket/list)
|
||||
(require "analyzer.rkt" "utils.rkt" racket/list racket/string)
|
||||
|
||||
(define (f:msec msec)
|
||||
(number->string (round (inexact->exact msec))))
|
||||
|
|
@ -14,30 +14,31 @@
|
|||
;; * thunks are used for cells that are ignored when inspecting widths
|
||||
;; * chars are used for filler cells
|
||||
(define (display-line strings)
|
||||
(printf "~a\n" (regexp-replace #rx" +$" (apply string-append strings) "")))
|
||||
(let ([widths (let loop ([table table])
|
||||
(let ([table (filter pair? table)])
|
||||
(if (null? table) '()
|
||||
(cons (apply max (filter-map
|
||||
(lambda (x)
|
||||
(and (string? (car x))
|
||||
(string-length (car x))))
|
||||
table))
|
||||
(loop (map cdr table))))))])
|
||||
(for ([row (in-list table)])
|
||||
(display-line
|
||||
(for/list ([cell (in-list row)]
|
||||
[width (in-list widths)]
|
||||
[align (in-list aligns)])
|
||||
(let* ([cell (cond [(char? cell) (make-string width cell)]
|
||||
[(procedure? cell) (cell)]
|
||||
[else cell])]
|
||||
[pad (make-string (max 0 (- width (string-length cell)))
|
||||
#\space)])
|
||||
(case align
|
||||
[(l) (string-append cell pad)]
|
||||
[(r) (string-append pad cell)]
|
||||
[else (error 'internal-error "poof")])))))))
|
||||
(printf "~a\n" (regexp-replace #rx" +$" (string-append* strings) "")))
|
||||
(define widths
|
||||
(let loop ([table table])
|
||||
(define table* (filter pair? table))
|
||||
(if (null? table*) '()
|
||||
(cons (apply max
|
||||
(filter-map
|
||||
(λ (x) (and (string? (car x)) (string-length (car x))))
|
||||
table*))
|
||||
(loop (map cdr table*))))))
|
||||
(for ([row (in-list table)])
|
||||
(display-line
|
||||
(for/list ([cell (in-list row)]
|
||||
[width (in-list widths)]
|
||||
[align (in-list aligns)])
|
||||
(define cell*
|
||||
(cond [(char? cell) (make-string width cell)]
|
||||
[(procedure? cell) (cell)]
|
||||
[else cell]))
|
||||
(define pad
|
||||
(make-string (max 0 (- width (string-length cell*))) #\space))
|
||||
(case align
|
||||
[(l) (string-append cell* pad)]
|
||||
[(r) (string-append pad cell*)]
|
||||
[else (error 'internal-error "poof")])))))
|
||||
|
||||
(define (render profile
|
||||
#:truncate-source [truncate-source 50]
|
||||
|
|
@ -61,10 +62,10 @@
|
|||
(define node->
|
||||
(let ([t (make-hasheq)])
|
||||
(for ([node (in-list nodes)] [idx (in-naturals 1)])
|
||||
(let ([index (format "[~a]" idx)]
|
||||
[label (format "~a" (or (node-id node) '???))])
|
||||
(hash-set! t node (list index label @string-append{@label @index}))))
|
||||
(lambda (mode node)
|
||||
(define index (format "[~a]" idx))
|
||||
(define label (format "~a" (or (node-id node) '???)))
|
||||
(hash-set! t node (list index label @string-append{@label @index})))
|
||||
(λ (mode node)
|
||||
((case mode [(index) car] [(label) cadr] [(sub-label) caddr])
|
||||
(hash-ref t node)))))
|
||||
(define (sep ch) (list ch ch ch ch ch ch ch ch ch ch))
|
||||
|
|
@ -79,14 +80,14 @@
|
|||
(when (> (length threads+times) 1)
|
||||
@show{ Threads observed: @(length threads+times)})
|
||||
(when (pair? hidden)
|
||||
(let* ([hidden (length hidden)]
|
||||
[nodes (length (profile-nodes profile))]
|
||||
[self% @string-append{self<@(format-percent (or hide-self% 0))}]
|
||||
[subs% @string-append{local<@(format-percent (or hide-subs% 0))}]
|
||||
[%s (cond [(not hide-self%) subs%]
|
||||
[(not hide-subs%) self%]
|
||||
[else @string-append{@self% and @subs%}])])
|
||||
@show{ (Hiding functions with @|%s|: @|hidden| of @nodes hidden)}))
|
||||
(define hidden# (length hidden))
|
||||
(define nodes# (length (profile-nodes profile)))
|
||||
(define self% @string-append{self<@(format-percent (or hide-self% 0))})
|
||||
(define subs% @string-append{local<@(format-percent (or hide-subs% 0))})
|
||||
(define %s (cond [(not hide-self%) subs%]
|
||||
[(not hide-subs%) self%]
|
||||
[else @string-append{@self% and @subs%}]))
|
||||
@show{ (Hiding functions with @|%s|: @hidden# of @nodes# hidden)})
|
||||
(newline)
|
||||
(display-table
|
||||
'(r l r l l r l l l r l l)
|
||||
|
|
@ -133,6 +134,6 @@
|
|||
(,(node-> 'index node)
|
||||
" " ,totalS ,total%
|
||||
" " ,selfS ,self%
|
||||
" " ,(lambda () name+src))
|
||||
" " ,(λ () name+src))
|
||||
,@(sub node-callees edge-callee edge-callee-time)
|
||||
,-sep)))))
|
||||
|
|
|
|||
|
|
@ -56,15 +56,15 @@
|
|||
;; intern the entries (which are (cons id/#f srcloc/#f))
|
||||
(define entry-table (make-hash))
|
||||
(define (intern-entry entry)
|
||||
(let* ([key (or (cdr entry) (car entry))]
|
||||
[en (hash-ref entry-table key #f)])
|
||||
(if en
|
||||
;; ELI: is this sanity check needed?
|
||||
;; (if (equal? en entry)
|
||||
;; en
|
||||
;; (error 'profile "internal error: assumption invalid"))
|
||||
en
|
||||
(begin (hash-set! entry-table key entry) entry))))
|
||||
(define key (or (cdr entry) (car entry)))
|
||||
(define en (hash-ref entry-table key #f))
|
||||
(if en
|
||||
;; ELI: is this sanity check needed?
|
||||
;; (if (equal? en entry)
|
||||
;; en
|
||||
;; (error 'profile "internal error: assumption invalid"))
|
||||
en
|
||||
(begin (hash-set! entry-table key entry) entry)))
|
||||
(define (validate to-track who)
|
||||
(let loop ([t to-track])
|
||||
(cond
|
||||
|
|
@ -74,13 +74,13 @@
|
|||
(raise-type-error
|
||||
who "thread, custodian, or a list of threads/csutodians" to-track)]
|
||||
;; test that it's subordinate
|
||||
[(with-handlers ([exn:fail:contract? (lambda (_) #t)])
|
||||
[(with-handlers ([exn:fail:contract? (λ (_) #t)])
|
||||
(custodian-managed-list t super-cust) #f)
|
||||
(error who "got an insubordinate custodian")])))
|
||||
(define paused 0)
|
||||
(define thread-id
|
||||
(let ([next-id 0] [t (make-weak-hasheq)])
|
||||
(lambda (thd)
|
||||
(λ (thd)
|
||||
(or (hash-ref t thd #f)
|
||||
(let ([id next-id])
|
||||
(set! next-id (add1 next-id))
|
||||
|
|
@ -109,9 +109,9 @@
|
|||
(define start-time (current-process-milliseconds))
|
||||
(define (add-time)
|
||||
(when (paused . <= . 0)
|
||||
(let ([cur (current-process-milliseconds)])
|
||||
(set! cpu-time (+ cpu-time (- cur start-time)))
|
||||
(set! start-time cur))))
|
||||
(define cur (current-process-milliseconds))
|
||||
(set! cpu-time (+ cpu-time (- cur start-time)))
|
||||
(set! start-time cur)))
|
||||
(define (ignore-time)
|
||||
(when (paused . <= . 0)
|
||||
(set! start-time (current-process-milliseconds))))
|
||||
|
|
@ -123,7 +123,7 @@
|
|||
(define sema (make-semaphore 1))
|
||||
(define (sampler-controller msg [arg #f])
|
||||
(define-syntax-rule (w/sema body ...)
|
||||
(call-with-semaphore sema (lambda () body ...)))
|
||||
(call-with-semaphore sema (λ () body ...)))
|
||||
(case msg
|
||||
[(pause) (w/sema (add-time) (set! paused (add1 paused)))]
|
||||
[(resume) (w/sema (set! paused (sub1 paused)) (ignore-time))]
|
||||
|
|
|
|||
|
|
@ -29,26 +29,27 @@ function that consumes a @racket[profile] instance. See the
|
|||
|
||||
Prints the given @racket[profile] results as a textual table.
|
||||
|
||||
The printout begins with some general details about the profile, and
|
||||
then a table that represents the call-graph is printed. Each row in
|
||||
this table looks like:
|
||||
The printout begins with general information about the profile,
|
||||
followed by a table with an entry for each function in the call graph.
|
||||
The entries are displayed in a topological order (roughly, since the
|
||||
graph can have cycles). This means that it is usually easy to find
|
||||
the callers and callees of a function in its close environment.
|
||||
|
||||
Each row in the table has the following format:
|
||||
@verbatim[#:indent 2]{
|
||||
B [M1] M2%
|
||||
[N1] N2(N3%) N4(N5%) A ...path/to/source.rkt:12:34
|
||||
C [M3] M4%}
|
||||
|
||||
where actual numbers appear in the printout. The meaning of the
|
||||
numbers and labels is as follows:
|
||||
with the following meaning of the numbers and labels:
|
||||
@itemize[
|
||||
@item{@tt{A} --- the name of the function that this node represents,
|
||||
followed by the source location for the function if it is known.
|
||||
The name can be ``???'' for anonymous functions, but in this case
|
||||
the source location will identify them.}
|
||||
@item{@tt{N1} --- an index number associated with this node. This is
|
||||
useful in references to this function, since the symbolic names are
|
||||
not unique (and some can be missing). The number itself has no
|
||||
significance.}
|
||||
The name can be ``???'' for anonymous functions, which will be
|
||||
identified with their source location.}
|
||||
@item{@tt{N1} --- an integer label associated with this node in the
|
||||
printout. This label is used to mark references to this function,
|
||||
since symbolic names are not unique (and they can be missing or very
|
||||
long). The labels are assigned from the top.}
|
||||
@item{@tt{N2} --- the time (in milliseconds) that this function has
|
||||
been anywhere in a stack snapshot. This is the total time that the
|
||||
execution was somewhere in this function or in its callees.
|
||||
|
|
|
|||
|
|
@ -59,9 +59,11 @@ can customize the profiling:
|
|||
accumulated data is analyzed (by @racket[analyze-samples]) and the
|
||||
resulting profile value is sent to the @racket[renderer] function.
|
||||
See @secref["renderers"] for available renderers. You can also use
|
||||
@racket[values] as a ``renderer''---in this case the
|
||||
@racket[values] as a ``renderer''---in this case
|
||||
@racket[profile-thunk] returns the analyzed information which can
|
||||
now be rendered multiple times, or saved for future rendering.}
|
||||
now be rendered multiple times, or saved for rendering directly
|
||||
using one of the renderers, perhaps multiple times for different
|
||||
views.}
|
||||
|
||||
@item{To provide feedback information during execution, specify a
|
||||
@racket[periodic-renderer]. This should be a list holding a delay
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@
|
|||
(define-struct node (id src thread-ids total self callers callees)
|
||||
#:mutable
|
||||
#:property prop:custom-write
|
||||
(lambda (node o w?)
|
||||
(λ (node o w?)
|
||||
(fprintf o "#<node:~s>"
|
||||
(or (node-id node) (if (node-src node) '??? 'ROOT)))))
|
||||
|
||||
|
|
@ -49,7 +49,7 @@
|
|||
(define-struct edge (total caller caller-time callee callee-time)
|
||||
#:mutable
|
||||
#:property prop:custom-write
|
||||
(lambda (edge o w?)
|
||||
(λ (edge o w?)
|
||||
(fprintf o "#<edge:~s-~s>"
|
||||
(or (node-id (edge-caller edge)) '???)
|
||||
(or (node-id (edge-callee edge)) '???))))
|
||||
|
|
|
|||
|
|
@ -10,9 +10,8 @@
|
|||
(provide format-percent)
|
||||
(define format-percent
|
||||
(case-lambda
|
||||
[(percent)
|
||||
(let ([percent (inexact->exact (round (* percent 1000)))])
|
||||
(format "~a.~a%" (quotient percent 10) (modulo percent 10)))]
|
||||
[(percent) (define p (inexact->exact (round (* percent 1000))))
|
||||
(format "~a.~a%" (quotient p 10) (modulo p 10))]
|
||||
[(x y) (format-percent (if (zero? y) 0 (/ x y)))]))
|
||||
|
||||
(provide format-source)
|
||||
|
|
@ -36,9 +35,9 @@
|
|||
(define (hide? node)
|
||||
(define (hide-sub? get-subs edge-sub edge-sub-time)
|
||||
(define %s
|
||||
(map (lambda (edge)
|
||||
(let ([total (node-total (edge-sub edge))])
|
||||
(if (zero? total) 0 (/ (edge-sub-time edge) total))))
|
||||
(map (λ (edge)
|
||||
(define total (node-total (edge-sub edge)))
|
||||
(if (zero? total) 0 (/ (edge-sub-time edge) total)))
|
||||
(get-subs node)))
|
||||
(subs% . >= . (apply max %s)))
|
||||
(and (self% . >= . (/ (node-self node) total-time))
|
||||
|
|
@ -54,8 +53,8 @@
|
|||
;; item in the first level, so it is not included in the result. This is done
|
||||
;; by assigning layers to nodes in a similar way to section 9.1 of "Graph
|
||||
;; Drawing: Algorithms for the Visualization of Graphs" by Tollis, Di Battista,
|
||||
;; Eades, and Tamassia. It uses a similar technique to the one described in
|
||||
;; section 9.4 to remove cycles in the input graph, but improved by the fact
|
||||
;; Eades, and Tamassia. It uses a technique similar to the one described in
|
||||
;; section 9.4 for removing cycles in the input graph, but improved by the fact
|
||||
;; that we have weights on input/output edges (this is the only point that is
|
||||
;; specific to the fact that it's a profiler graph). Note that this is useful
|
||||
;; for a graphical rendering of the results, but it's also useful to sort the
|
||||
|
|
@ -69,9 +68,9 @@
|
|||
(define (get-node+io node)
|
||||
(define (sum node-callers/lees edge-caller/lee edge-callee/ler-time)
|
||||
(for/fold ([sum 0]) ([e (in-list (node-callers/lees node))])
|
||||
(let ([n (edge-caller/lee e)])
|
||||
(if (or (eq? n node) (eq? n root)) sum
|
||||
(+ sum (edge-callee/ler-time e))))))
|
||||
(define n (edge-caller/lee e))
|
||||
(if (or (eq? n node) (eq? n root)) sum
|
||||
(+ sum (edge-callee/ler-time e)))))
|
||||
(cons node (mcons (sum node-callers edge-caller edge-callee-time)
|
||||
(sum node-callees edge-callee edge-caller-time))))
|
||||
(define nodes+io-times
|
||||
|
|
@ -80,11 +79,11 @@
|
|||
(let* ([cur (car todo)] [todo (cdr todo)]
|
||||
[r (if (eq? cur root) r (cons (get-node+io cur) r))])
|
||||
(loop (append todo ; append new things in the end, so it's a BFS
|
||||
(filter-map (lambda (e)
|
||||
(let ([lee (edge-callee e)])
|
||||
(and (not (memq lee todo))
|
||||
(not (assq lee r))
|
||||
lee)))
|
||||
(filter-map (λ (e)
|
||||
(define lee (edge-callee e))
|
||||
(and (not (memq lee todo))
|
||||
(not (assq lee r))
|
||||
lee))
|
||||
(node-callees cur)))
|
||||
r))
|
||||
;; note: the result does not include the root node
|
||||
|
|
@ -108,9 +107,9 @@
|
|||
(loop rest (list 1st) ratio)
|
||||
(loop rest (if (ratio . > . best) r (cons 1st r)) best))))))
|
||||
(if (pair? todo)
|
||||
(let* ([sinks (filter (lambda (x) (zero? (mcdr (cdr x)))) todo)]
|
||||
(let* ([sinks (filter (λ (x) (zero? (mcdr (cdr x)))) todo)]
|
||||
[todo (remq* sinks todo)]
|
||||
[sources (filter (lambda (x) (zero? (mcar (cdr x)))) todo)]
|
||||
[sources (filter (λ (x) (zero? (mcar (cdr x)))) todo)]
|
||||
;; if we have no sources and sinks, use the heuristic
|
||||
[sources (if (and (null? sinks) (null? sources))
|
||||
(best-sources) sources)]
|
||||
|
|
@ -121,13 +120,13 @@
|
|||
(for* ([nodes (in-list (list sources sinks))]
|
||||
[n (in-list nodes)])
|
||||
(for ([e (in-list (node-callees n))])
|
||||
(let ([x (assq (edge-callee e) todo)])
|
||||
(when x (set-mcar! (cdr x) (- (mcar (cdr x))
|
||||
(edge-callee-time e))))))
|
||||
(define x (assq (edge-callee e) todo))
|
||||
(when x
|
||||
(set-mcar! (cdr x) (- (mcar (cdr x)) (edge-callee-time e)))))
|
||||
(for ([e (in-list (node-callers n))])
|
||||
(let ([x (assq (edge-caller e) todo)])
|
||||
(when x (set-mcdr! (cdr x) (- (mcdr (cdr x))
|
||||
(edge-caller-time e)))))))
|
||||
(define x (assq (edge-caller e) todo))
|
||||
(when x
|
||||
(set-mcdr! (cdr x) (- (mcdr (cdr x)) (edge-caller-time e))))))
|
||||
(loop todo (append (reverse sources) rev-left) (append sinks right)))
|
||||
;; all done, get the order
|
||||
(append (reverse rev-left) right))))
|
||||
|
|
@ -138,36 +137,37 @@
|
|||
(let ([t (make-hasheq)])
|
||||
(let loop ([nodes acyclic-order])
|
||||
(when (pair? nodes)
|
||||
(let ([ler (car nodes)] [rest (cdr nodes)])
|
||||
(unless (hash-ref t ler #f) (hash-set! t ler '()))
|
||||
(for ([e (in-list (node-callees ler))])
|
||||
(let ([lee (edge-callee e)])
|
||||
(when (memq lee rest) ; only consistent edges
|
||||
;; note that we connect each pair of nodes at most once, and
|
||||
;; never a node with itself
|
||||
(hash-set! t lee (cons ler (hash-ref t lee '()))))))
|
||||
(loop rest))))
|
||||
(define ler (car nodes))
|
||||
(define rest (cdr nodes))
|
||||
(unless (hash-ref t ler #f) (hash-set! t ler '()))
|
||||
(for ([e (in-list (node-callees ler))])
|
||||
(define lee (edge-callee e))
|
||||
(when (memq lee rest) ; only consistent edges
|
||||
;; note that we connect each pair of nodes at most once, and
|
||||
;; never a node with itself
|
||||
(hash-set! t lee (cons ler (hash-ref t lee '())))))
|
||||
(loop rest)))
|
||||
t))
|
||||
|
||||
;; finally, assign layers using the simple method from section 9.1: sources
|
||||
;; are at 0, and other nodes are placed at one layer after their parents
|
||||
(let ([height 0])
|
||||
(for ([node (in-list acyclic-order)])
|
||||
(let loop ([node node])
|
||||
(define x (hash-ref t node))
|
||||
(if (number? x)
|
||||
x
|
||||
(let ([max (add1 (for/fold ([m -1]) ([ler (in-list x)])
|
||||
(max m (loop ler))))])
|
||||
(when (max . > . height) (set! height max))
|
||||
(hash-set! t node max)
|
||||
max))))
|
||||
(let ([layers (make-vector (add1 height) '())])
|
||||
(for ([node (in-list acyclic-order)])
|
||||
(unless (eq? node root) ; filter out the root
|
||||
(let ([l (hash-ref t node)])
|
||||
(vector-set! layers l (cons node (vector-ref layers l))))))
|
||||
;; in almost all cases, the root is the full first layer (in a few cases
|
||||
;; it can be there with another node, eg (* -> A 2-> B 3-> A)), but be
|
||||
;; safe and look for any empty layer
|
||||
(filter pair? (vector->list layers)))))
|
||||
(define height 0)
|
||||
(for ([node (in-list acyclic-order)])
|
||||
(let loop ([node node])
|
||||
(define x (hash-ref t node))
|
||||
(if (number? x)
|
||||
x
|
||||
(let ([max (add1 (for/fold ([m -1]) ([ler (in-list x)])
|
||||
(max m (loop ler))))])
|
||||
(when (max . > . height) (set! height max))
|
||||
(hash-set! t node max)
|
||||
max))))
|
||||
(define layers (make-vector (add1 height) '()))
|
||||
(for ([node (in-list acyclic-order)])
|
||||
(unless (eq? node root) ; filter out the root
|
||||
(define l (hash-ref t node))
|
||||
(vector-set! layers l (cons node (vector-ref layers l)))))
|
||||
;; in almost all cases, the root is the full first layer (in a few cases it
|
||||
;; can be there with another node, eg (* -> A 2-> B 3-> A)), but be safe and
|
||||
;; look for any empty layer
|
||||
(filter pair? (vector->list layers)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user