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

Finally it works.

Browse Source 
svn: r15018

original commit: 82e256473d7d6f6720051194325e33931fb86d77
This commit is contained in:
Eli Barzilay 2009-05-30 06:48:49 +00:00
parent 9340664957
commit cb94e5817d
3 changed files with 168 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/profile/utils.ss
View File

@ -63,36 +63,37 @@
(provide topological-sort)
(define (topological-sort root)
;; a general purpose hash for nodes
(define t (make-hasheq))
;; make `t' map a node to an mcons of total input and total output times
;; ignoring edges to/from the *-node and self edges
(define (add! node)
;; Make `nodes+io-times' map a node to an mcons of total input and total
;; output times ignoring edges to/from the *-node and self edges, the order
;; is the reverse of how we scan the graph
(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))))))
(hash-set! t node
(mcons (sum node-callers edge-caller edge-callee-time)
(cons node (mcons (sum node-callers edge-caller edge-callee-time)
(sum node-callees edge-callee edge-caller-time))))
(define nodes+io-times
(let loop ([todo (list root)])
(let loop ([todo (list root)] [r '()])
(if (pair? todo)
(let ([cur (car todo)] [todo (cdr todo)])
(unless (eq? cur root) (add! cur))
(loop (append (filter-map (lambda (e)
(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 (hash-ref t lee #f)) lee)))
(node-callees cur))
todo)))
(and (not (memq lee todo))
(not (assq lee r))
lee)))
(node-callees cur)))
r))
;; note: the result does not include the root node
(hash-map t cons))))
r)))
;; now create a linear order similar to the way section 9.4 describes, except
;; Now create a linear order similar to the way section 9.4 describes, except
;; that this uses the total caller/callee times to get an even better
;; ordering (also, look for sources and sinks in every step)
;; ordering (also, look for sources and sinks in every step). Note that the
;; list we scan is in reverse order.
(define acyclic-order
(let loop ([todo nodes+io-times] [rev-left '()] [right '()])
;; heuristic for best sources: the ones with the lowest intime/outtime
@ -131,19 +132,22 @@
;; all done, get the order
(append (reverse rev-left) right))))
;; we're done, so make `t' map nodes to their callers with only edges that
;; We're done, so make `t' map nodes to their callers with only edges that
;; are consistent with this ordering
(for ([n acyclic-order]) (hash-set! t n '()))
(let loop ([nodes acyclic-order])
(when (pair? nodes)
(let ([ler (car nodes)] [rest (cdr nodes)])
(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 t
(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))))
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

1
collects/tests/profile/main.ss
View File

@ -54,6 +54,7 @@
'ok]
[bad (error 'test ">>> ~s" bad)])
;; demonstrates different edge-caller/lee-times
(match (analyze `(10
[0 0 ,A ,B ,A]
[0 1 ,A ,B ,A]))

162
collects/tests/profile/topsort.ss
View File

@ -3,55 +3,159 @@
(require tests/eli-tester profile/structs profile/utils
scheme/list scheme/match)
(define (connect! from to)
(define edge (make-edge 0 from 0 to 0))
(set-node-callers! to (cons edge (node-callers to )))
(set-node-callees! from (cons edge (node-callees from))))
(define arrow-sym->times
;; arrows with caller/callee times
;; `->' defaults to `1->1', and `N->' defaults to `N->N'
;; note: A 1->2 B means that the caller time is 2 and the callee time is one,
;; since the time are wrt the other node.
(let ([t (make-hasheq)])
(lambda (arr)
(hash-ref! t arr
(lambda ()
(define m
(regexp-match #rx"^(?:([0-9]+)|)->(?:([0-9]+)|)$"
(symbol->string arr)))
(and m
(list (string->number (or (caddr m) (cadr m) "1"))
(string->number (or (cadr m) "1")))))))))
(define (connect! from from-time to to-time)
(if (memq from (map edge-caller (node-callers to)))
(error (format "bad graph spec in tests, ~s->~s already connected" from to))
(let ([edge (make-edge 0 from from-time to to-time)])
(set-node-callers! to (cons edge (node-callers to )))
(set-node-callees! from (cons edge (node-callees from))))))
(define-match-expander arrow
(syntax-rules () [(_ ler lee) (app arrow-sym->times (list ler lee))]))
(define (set=? l1 l2) (null? (append (remq* l1 l2) (remq* l2 l1))))
(define (sort-graph . edges)
(define names (remove-duplicates (remq* '(->) (append* edges))))
(define names
(remove-duplicates (filter (lambda (s) (not (arrow-sym->times s)))
(append* edges))))
(define nodes (map (lambda (sym) (make-node sym #f '() 0 0 '() '())) names))
(define ->node (make-immutable-hasheq (map cons names nodes)))
(for ([edges edges])
(let loop ([xs edges])
(match xs
[(list from '-> to '-> _ ...)
(connect! (hash-ref ->node from) (hash-ref ->node to))
[(list from (arrow ftime ttime) to (arrow _ _) _ ...)
(connect! (hash-ref ->node from) ftime (hash-ref ->node to) ttime)
(loop (cddr xs))]
[(list from '-> to _ ...)
(connect! (hash-ref ->node from) (hash-ref ->node to))
[(list from (arrow ftime ttime) to _ ...)
(connect! (hash-ref ->node from) ftime (hash-ref ->node to) ttime)
(loop (cdddr xs))]
['() (void)])))
(map (lambda (nodes) (map node-id nodes)) (topological-sort (car nodes))))
(let ([sorted (topological-sort (car nodes))])
(unless (set=? nodes (cons (car nodes) (append* sorted)))
(error 'sort-graph
"not all nodes appear in sorted output; expected ~e, got ~e"
nodes (cons (car nodes) (append* sorted))))
(map (lambda (nodes) (map node-id nodes)) sorted)))
(define (same-levels graph levels)
;; `expected' is the desired result, modulo ordering inside the levels
;; can have more than one if there are several valid outputs
(define (same-levels graph expected . more-valid)
(define sorted (sort-graph graph))
(define (set=? l1 l2) (null? (append (remq* l1 l2) (remq* l2 l1))))
(andmap set=? sorted levels))
(or (ormap (lambda (expected)
(and (= (length sorted) (length expected))
(andmap set=? sorted expected)))
(cons expected more-valid))
(error (format "bad result, got ~s" sorted))))
;; to see a result: (sort-graph '(* -> A)) (exit)
(provide topological-sort-tests)
(define (topological-sort-tests)
(test
(same-levels '(* -> A -> B)
'((A) (B)))
;; sanity check: works with an empty stack
;; actually, this version does get stuck in a loop -- which shouldn't happen
;; in reality since there are no *->* edges
;; (same-levels '(* -> *)
;; '())
;; instead, just have a single * node:
(topological-sort (make-node '* #f '() 0 0 '() '()))
=> '()
(same-levels '(* -> A -> B -> *
* -> B -> A -> *)
'((A B)))
(same-levels '(* -> A)
'((A)))
(same-levels '(* -> A -> B -> C
* -> C)
'((A) (B) (C)))
(same-levels '(* -> A -> B -> *)
'((A) (B)))
(same-levels '(* -> A
* -> B
B -> B)
'((A B)))
(same-levels '(* -> A -> *
* -> B -> *
A -> A)
'((A B)))
(same-levels '(* -> A
* -> B -> C
* -> C -> B)
'((A B C)))
;; note that ((B) (A)) would also be consistent, but the code organizes for
;; this result
(same-levels '(* -> A -> B -> A)
'((A) (B)))
;; this is an example using the actual times for the A->B->A case that is
;; tested in main.ss
(same-levels '(* 2->1 A 1->2 B 2->1 A 1->2 *)
'((A) (B)))
(same-levels '(* -> A 2-> B -> A)
'((A) (B)))
(same-levels '(* -> A 2-> B 3-> A)
'((B) (A)))
(same-levels '(* -> A -> B -> C
* -> C)
'((A) (B) (C)))
(same-levels '(* -> A -> B -> C -> * ; check with *s too
* -> C)
'((A) (B) (C)))
(same-levels '(* -> X -> A -> B -> C
X -> C )
'((X) (A) (B) (C)))
(same-levels '(* -> A -> B -> C -> *
* -> C 3-> B -> *)
'((A C) (B)))
(same-levels '(* -> A -> B -> A
* -> C)
'((A C) (B)))
(same-levels '(* -> A -> B -> *
* -> B -> A -> *)
'((A) (B))
'((B) (A)))
(same-levels '(* -> A
* -> B
B -> B)
'((A B)))
(same-levels '(* -> A
* -> B -> C
* -> C -> B)
'((A B) (C))
'((A C) (B)))
;; Note that X could be pushed to the third level, making it closer to D,
;; but this is not done since for a printout it makes more sense to have all
;; the sources at the top. (It might make sense to do this compacting in
;; the gui, but even there it might be more convenient to see all roots at
;; the top.)
(same-levels '(* -> A -> B -> C -> D -> *
* -> X -> D)
'((X A) (B) (C) (D)))
(same-levels '(* -> A1 -> A2 -> A3 -> A4 -> A5
* -> B1 -> B2 -> B3
* -> C1
* -> D1 -> D2 -> D3 -> D4)
'((A1 B1 C1 D1) (A2 B2 D2) (A3 B3 D3) (A4 D4) (A5)))
))