Finally it works.

svn: r15018

original commit: 82e256473d7d6f6720051194325e33931fb86d77

collects/profile/utils.ss

@@ -63,36 +63,37 @@
 (provide topological-sort)
 (define (topological-sort root)
 
-  ;; a general purpose hash for nodes
+  ;; Make `nodes+io-times' map a node to an mcons of total input and total
-  (define t (make-hasheq))
+  ;; output times ignoring edges to/from the *-node and self edges, the order
-
+  ;; is the reverse of how we scan the graph
-  ;; make `t' map a node to an mcons of total input and total output times
+  (define (get-node+io node)
-  ;; ignoring edges to/from the *-node and self edges
-  (define (add! 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
+    (cons node (mcons (sum node-callers edge-caller edge-callee-time)
-               (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)])
+        (let* ([cur (car todo)] [todo (cdr todo)]
-          (unless (eq? cur root) (add! cur))
+               [r (if (eq? cur root) r (cons (get-node+io cur) r))])
-          (loop (append (filter-map (lambda (e)
+          (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)))
+                                        (and (not (memq lee todo))
-                                    (node-callees cur))
+                                             (not (assq lee r))
-                        todo)))
+                                             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 '()))
+  (define t
-  (let loop ([nodes acyclic-order])
+    (let ([t (make-hasheq)])
-    (when (pair? nodes)
+      (let loop ([nodes acyclic-order])
-      (let ([ler (car nodes)] [rest (cdr nodes)])
+        (when (pair? nodes)
-        (for ([e (in-list (node-callees ler))])
+          (let ([ler (car nodes)] [rest (cdr nodes)])
-          (let ([lee (edge-callee e)])
+            (unless (hash-ref t ler #f) (hash-set! t ler '()))
-            (when (memq lee rest) ; only consistent edges
+            (for ([e (in-list (node-callees ler))])
-              ;; note that we connect each pair of nodes at most once, and
+              (let ([lee (edge-callee e)])
-              ;; never a node with itself
+                (when (memq lee rest) ; only consistent edges
-              (hash-set! t lee (cons ler (hash-ref t lee))))))
+                  ;; note that we connect each pair of nodes at most once, and
-        (loop rest))))
+                  ;; 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

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]))

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 arrow-sym->times
-  (define edge (make-edge 0 from 0 to 0))
+  ;; arrows with caller/callee times
-  (set-node-callers! to   (cons edge (node-callers to  )))
+  ;; `->' defaults to `1->1', and `N->' defaults to `N->N'
-  (set-node-callees! from (cons edge (node-callees from))))
+  ;; 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 '-> _ ...)
+        [(list from (arrow ftime ttime) to (arrow _ _) _ ...)
-         (connect! (hash-ref ->node from) (hash-ref ->node to))
+         (connect! (hash-ref ->node from) ftime (hash-ref ->node to) ttime)
          (loop (cddr xs))]
-        [(list from '-> to _ ...)
+        [(list from (arrow ftime ttime) to _ ...)
-         (connect! (hash-ref ->node from) (hash-ref ->node 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))))
+  (or (ormap (lambda (expected)
-  (andmap set=? sorted levels))
+               (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)
+   ;; sanity check: works with an empty stack
-                 '((A) (B)))
+   ;; 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 -> *
+   (same-levels '(* -> A)
-                   * -> B -> A -> *)
+                '((A)))
-                 '((A B)))
 
-    (same-levels '(* -> A -> B -> C
+   (same-levels '(* -> A -> B -> *)
-                   * -> C)
+                '((A) (B)))
-                 '((A) (B) (C)))
 
-    (same-levels '(* -> A
+   (same-levels '(* -> A -> *
-                   * -> B
+                  * -> B -> *
-                   B -> B)
+                  A -> A)
-                 '((A B)))
+                '((A B)))
 
-    (same-levels '(* -> A
+   ;; note that ((B) (A)) would also be consistent, but the code organizes for
-                   * -> B -> C
+   ;; this result
-                   * -> C -> B)
+   (same-levels '(* -> A -> B -> A)
-                 '((A B C)))
+                '((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)))
 
     ))