From cb94e5817d527875668c9e3ae95c500cb088514f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 30 May 2009 06:48:49 +0000 Subject: [PATCH] Finally it works. svn: r15018 original commit: 82e256473d7d6f6720051194325e33931fb86d77 --- collects/profile/utils.ss | 64 ++++++------ collects/tests/profile/main.ss | 1 + collects/tests/profile/topsort.ss | 162 ++++++++++++++++++++++++------ 3 files changed, 168 insertions(+), 59 deletions(-) diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index 9961ef0..f355340 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -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 diff --git a/collects/tests/profile/main.ss b/collects/tests/profile/main.ss index df3395d..fd6a2e3 100644 --- a/collects/tests/profile/main.ss +++ b/collects/tests/profile/main.ss @@ -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])) diff --git a/collects/tests/profile/topsort.ss b/collects/tests/profile/topsort.ss index f43dc4a..edadb61 100644 --- a/collects/tests/profile/topsort.ss +++ b/collects/tests/profile/topsort.ss @@ -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))) ))