change path collection for profiling to be counts for uniqe paths

svn: r2373

collects/errortrace/doc.txt

@@ -110,11 +110,11 @@ Profiling records:
    in turn, provide a source location file and position).
 
  * optionally, information about the procedure call path (i.e., a
-   stack trace) for every call to the procedure; follecting this
+   stack trace) for every call to the procedure; collecting this
-   information is expensive. Path information is collected when the
+   information is relatively expensive. Path information is collected
-   `profile-paths-enabled' boolean parameter is #t; the default is #f,
+   when the `profile-paths-enabled' boolean parameter is #t; the
-   but setting the parameter to #t immediately affects all procedure
+   default is #f, but setting the parameter to #t immediately affects
-   instrumented for profiling information:
+   all procedure instrumented for profiling information:
 
 >   (profile-paths-enabled) - returns #t if profiling collects path
     information, #f otherwise
@@ -139,8 +139,9 @@ To retrieve all profiling information accumulated so far, call
 
   * the syntax source of the procedure; and
 
-  * a list of call paths, recorded while `profile-paths-enabled' is
+  * a list of unique call paths recorded while `profile-paths-enabled'
-    set to #t.  Each call path is a list containing two-element lists;
+    is set to #t.  Each call path is a pair of a count (the number of
+    times the path occurred) and a list containing two-element lists;
     each two-element list contains the calling procedure's name or
     source expression and the calling procedure's source file or #f.
 

collects/errortrace/errortrace-lib.ss

@@ -45,10 +45,14 @@
              (set-car! v (add1 (car v)))
              (when (profile-paths-enabled)
                (let ([v (cddddr v)])
-                 (set-car! v (cons (continuation-mark-set->list
+		 (let ([cms
-				    (current-continuation-marks)
+			(continuation-mark-set->list
-				    profile-key)
+			 (current-continuation-marks)
-                                   (car v)))))
+			 profile-key)])
+		   (unless (hash-table? (car v))
+		     (set-car! v (make-hash-table 'equal)))
+		   (hash-table-put! (car v) cms 
+				    (add1 (hash-table-get (car v) cms (lambda () 0)))))))
              (if (unbox b)
                  #f
                  (begin
@@ -74,12 +78,14 @@
               [expr (cadddr (cdr val))]
               [cmss (cadddr (cddr val))])
           (list count time name expr
-                (map (lambda (cms)
+		(if (hash-table? cmss)
-                       (map (lambda (k)
+		    (hash-table-map cmss (lambda (ks v)
-                              (let ([v (cdr (hash-table-get profile-info k))])
+					   (cons v 
-                                (list (caddr v) (cadddr v))))
+						 (map (lambda (k)
-                            cms))
+							(let ([v (cdr (hash-table-get profile-info k))])
-                     cmss))))))
+							  (list (caddr v) (cadddr v))))
+						      ks))))
+		    null))))))
 
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; Stacktrace instrumenter
@@ -247,14 +253,15 @@
          (when paths?
            (for-each
             (lambda (cms)
-              (unless (null? cms)
+              (unless (null? (cdr cms))
-                (printf "  VIA ~e" (caar cms))
+                (printf "  ~e VIA ~e" (car cms) (caadr cms))
                 (for-each
                  (lambda (cm)
                    (printf " <- ~e" (car cm)))
-                 (cdr cms))
+                 (cddr cms))
                 (printf "~n")))
-            (cadddr (cdr c)))))
+	    (quicksort (cadddr (cdr c))
+		       (lambda (a b) (> (car a) (car b)))))))
        counts)
       (printf "Total samples: ~a~n" total)))