diff --git a/collects/errortrace/doc.txt b/collects/errortrace/doc.txt index fe56c967f3..dd5fb57ea3 100644 --- a/collects/errortrace/doc.txt +++ b/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 - information is expensive. Path information is collected when the - `profile-paths-enabled' boolean parameter is #t; the default is #f, - but setting the parameter to #t immediately affects all procedure - instrumented for profiling information: + stack trace) for every call to the procedure; collecting this + information is relatively expensive. Path information is collected + when the `profile-paths-enabled' boolean parameter is #t; the + default is #f, but setting the parameter to #t immediately affects + 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 - set to #t. Each call path is a list containing two-element lists; + * a list of unique call paths recorded while `profile-paths-enabled' + 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. diff --git a/collects/errortrace/errortrace-lib.ss b/collects/errortrace/errortrace-lib.ss index b63b25aa1b..eacdf92ff7 100644 --- a/collects/errortrace/errortrace-lib.ss +++ b/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 - (current-continuation-marks) - profile-key) - (car v))))) + (let ([cms + (continuation-mark-set->list + (current-continuation-marks) + 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) - (map (lambda (k) - (let ([v (cdr (hash-table-get profile-info k))]) - (list (caddr v) (cadddr v)))) - cms)) - cmss)))))) + (if (hash-table? cmss) + (hash-table-map cmss (lambda (ks v) + (cons v + (map (lambda (k) + (let ([v (cdr (hash-table-get profile-info k))]) + (list (caddr v) (cadddr v)))) + ks)))) + null)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Stacktrace instrumenter @@ -247,14 +253,15 @@ (when paths? (for-each (lambda (cms) - (unless (null? cms) - (printf " VIA ~e" (caar cms)) + (unless (null? (cdr 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)))