diff --git a/collects/errortrace/doc.txt b/collects/errortrace/doc.txt index 1c3dd5d31d..36be354b87 100644 --- a/collects/errortrace/doc.txt +++ b/collects/errortrace/doc.txt @@ -53,8 +53,8 @@ default. The `instrumenting-enabled' parameter affects only the way that source code is compiled, not the way that exception information is reported. -> (instrumenting-enabled) - returns #t if error tracing instrumentation is - enabled, #f otherwise +> (instrumenting-enabled) - returns #t if error tracing + instrumentation is enabled, #f otherwise > (instrumenting-enabled on?) - enables/disables error tracing instrumentation @@ -162,32 +162,51 @@ Clears accumulated profile results. Coverage -------- -Errortrace can track expression execution that is useful for checking -test coverage (i.e., simple expression coverage). Enable coverage -checking with the `execute-counts-enabled' boolean parameter (but -setting `instrumentation-enabled' to #f also disables execute -counting): +Errortrace can produce coverage information in two flavors: both count +the number of times each expression in the source was used during +execution. The first flavor uses a simple approach, where each +expression is counted when executed; the second one uses the same +annotations that the profiler uses, so only function bodies are +counted. To see the difference between the two approaches, try this +program: -> (execute-counts-enabled) - returns #t if execute-counting - instrumentation is enabled, #f otherwise -> (execute-counts-enabled on?) - enables/disables execute-counting - instrumentation + (define (foo x) (if x 1 2)) + (equal? (foo #t) 1) -> (get-execute-counts) - returns a list of pairs, one for each - instrumented expression. The first element of the pair is a syntax - object (usually containing source location information) for the - original expression, and the second element of the pair is the - number of times that the expression has been evaluated. These - elements are destructively modified, so to take a snapshot you will - need to copy them. +The first approach will produce exact results, but it is more +expensive; use it when you want to know how covered your code is (when +the expected counts are small). The second approach produces coarser +results (which, in the above case, will miss the `2' expression), but +is less expensive; use it when you want to use the counts for +profiling (when the expected counts are large). -> (annotate-executed-file filename-path) - writes the named file to - the current output port, inserting an additional line between each - source line to reflect execution counts (as reported by - `get-execute-counts'). An expression underlined with "^" has been - executed 0 times; an expression underlined with "." has been - executed 1 time; and an expression underlined with "," has been - executed multiple times. +> (coverage-counts-enabled [on?]) +> (execute-counts-enabled [on?]) + parameters that determine if the first (exact coverage) or second + (profiler-based coverage) are enabled. (Remember that setting + `instrumentation-enabled' to #f also disables both) + +> (get-coverage-counts) +> (get-execute-counts) + returns a list of pairs, one for each instrumented expression. The + first element of the pair is a syntax object (usually containing + source location information) for the original expression, and the + second element of the pair is the number of times that the + expression has been evaluated. These elements are destructively + modified, so to take a snapshot you will need to copy them. + +> (annotate-covered-file filename-path [display-string]) +> (annotate-executed-file filename-path [display-string]) + writes the named file to the current output port, inserting an + additional line between each source line to reflect execution counts + (as reported by `get-coverage-counts' or `get-execute-counts'). The + optional display string is used for the annotation: the first + character is used for expressions that were visited 0 times, the + second character for 1 time, ..., and the last character for + expressions that were visited more times. It can also be #t for a + maximal display ("012...9ABC...Z"), #f for a minimal display + ("#-"). The default for `annotate-covered-file' is #f, and the + default for `annotate-executed-file' is "^.,". _Re-using errortrace handlers_ ----------------------------------- diff --git a/collects/errortrace/errortrace-lib.ss b/collects/errortrace/errortrace-lib.ss index 9f34922bd8..0263d49d1a 100644 --- a/collects/errortrace/errortrace-lib.ss +++ b/collects/errortrace/errortrace-lib.ss @@ -15,11 +15,18 @@ (define test-coverage-info (make-hash-table)) (define (initialize-test-coverage-point key expr) - (hash-table-put! test-coverage-info key (list #f expr))) + (hash-table-put! test-coverage-info key (cons expr 0))) (define (test-covered key) (let ([v (hash-table-get test-coverage-info key)]) - (set-car! v #t))) + (set-cdr! v (add1 (cdr v))))) + + (define (get-coverage-counts) + (hash-table-map test-coverage-info (lambda (k v) v))) + + (define (annotate-covered-file name . more) + (apply annotate-file name (get-coverage-counts) + (if (null? more) '(#f) more))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Profiling run-time support @@ -145,55 +152,81 @@ (define (get-execute-counts) (hash-table-map execute-info (lambda (k v) v))) - (define (annotate-executed-file name) + (define (annotate-executed-file name . more) + (apply annotate-file name (get-execute-counts) + (if (null? more) '("^.,") more))) + + ;; shared functionality for annotate-executed-file and annotate-covered-file + (define (annotate-file name counts display-string) (let ([name (path->complete-path name (current-directory))]) - (let ([here (filter (lambda (s) - (and (equal? name (syntax-source (car s))) - (syntax-position (car s)))) - (get-execute-counts))]) - (let ([sorted - (sort - here - (lambda (a b) - (let ([ap (syntax-position (car a))] - [bp (syntax-position (car b))]) - (or (< ap bp) ; earlier first - (and (= ap bp) - (let ([as (syntax-span (car a))] - [bs (syntax-span (car b))]) - (or (> as bs) ; wider first at same pos - (and (= as bs) - ;; less called for same region last - (> (cdr a) (cdr b))))))))))] - [pic (make-string (file-size name) #\space)]) - ;; fill out picture: - (for-each (lambda (s) - (let ([pos (sub1 (syntax-position (car s)))] - [span (syntax-span (car s))] - [key (case (cdr s) [(0) #\^] [(1) #\.] [else #\,])]) - (let loop ([p pos]) - (unless (= p (+ pos span)) - (string-set! pic p key) - (loop (add1 p)))))) - sorted) - ;; Write annotated file - (with-input-from-file name - (lambda () - (let loop () - (let ([pos (file-position (current-input-port))] - [line (read-line (current-input-port) 'any)]) - (unless (eof-object? line) - (printf "~a~n" line) - (let ([w (string-length line)]) - ;; Blank out leading spaces in pic: - (let loop ([i 0]) - (cond - [(and (< i w) - (char-whitespace? (string-ref line i))) - (string-set! pic (+ pos i) (string-ref line i)) - (loop (add1 i))])) - (printf "~a~n" (substring pic pos (+ pos w)))) - (loop)))))))))) + (let* (;; Filter relevant syntaxes + [here (filter (lambda (s) + (and (equal? name (syntax-source (car s))) + (syntax-position (car s)))) + counts)] + ;; Sort them: earlier first, wider if in same position + [sorted (sort here + (lambda (a b) + (let ([ap (syntax-position (car a))] + [bp (syntax-position (car b))]) + (or (< ap bp) + (and (= ap bp) + (> (syntax-span (car a)) + (syntax-span (car b))))))))] + ;; Merge entries with the same position+span + [sorted (if (null? sorted) + sorted ; guarantee one element for the next case + (let loop ([xs (reverse! sorted)] [r '()]) + (cond [(null? (cdr xs)) (append xs r)] + [(and (= (syntax-position (caar xs)) + (syntax-position (caadr xs))) + (= (syntax-span (caar xs)) + (syntax-span (caadr xs)))) + ;; doesn't matter which syntax object is kept, + ;; we only care about its position+span + (loop (cons (cons (caar xs) + (max (cdar xs) (cdadr xs))) + (cddr xs)) + r)] + [else (loop (cdr xs) (cons (car xs) r))])))] + [pic (make-string (file-size name) #\space)] + [display-string + (case display-string + [(#t) "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"] + [(#f) "#-"] + [else display-string])] + [many-char (string-ref display-string + (sub1 (string-length display-string)))]) + ;; Fill out picture + (for-each (lambda (s) + (let ([pos (sub1 (syntax-position (car s)))] + [span (syntax-span (car s))] + [key (let ([k (cdr s)]) + (if (< k (string-length display-string)) + (string-ref display-string k) + many-char))]) + (let loop ([p pos]) + (unless (= p (+ pos span)) + (string-set! pic p key) + (loop (add1 p)))))) + sorted) + ;; Write annotated file + (with-input-from-file name + (lambda () + (let loop () + (let ([pos (file-position (current-input-port))] + [line (read-line (current-input-port) 'any)]) + (unless (eof-object? line) + (printf "~a\n" line) + (let ([w (string-length line)]) + ;; Blank leading spaces in pic (copy them: works for tabs) + (let loop ([i 0]) + (when (and (< i w) + (char-whitespace? (string-ref line i))) + (string-set! pic (+ pos i) (string-ref line i)) + (loop (add1 i)))) + (printf "~a\n" (substring pic pos (+ pos w)))) + (loop))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Eval handler, exception handler @@ -350,5 +383,9 @@ get-execute-counts annotate-executed-file - annotate-top)) + ;; use names that are consistent with the above + (rename test-coverage-enabled coverage-counts-enabled) + get-coverage-counts + annotate-covered-file + annotate-top)) diff --git a/collects/errortrace/errortrace.ss b/collects/errortrace/errortrace.ss index c4b347d3d6..7376aab8e2 100644 --- a/collects/errortrace/errortrace.ss +++ b/collects/errortrace/errortrace.ss @@ -19,7 +19,11 @@ execute-counts-enabled get-execute-counts - annotate-executed-file) + annotate-executed-file + + coverage-counts-enabled + get-coverage-counts + annotate-covered-file) (current-compile errortrace-compile-handler) (error-display-handler errortrace-error-display-handler)