suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Change the errortrace protocol for `initialize-test-coverage-point' and

Browse Source 
`test-covered' to use just the expression -- looks like there's no
reason to use an additional key.

Also, change its uses to map each syntax to an mcons where its mcar is
used to track coverage.  This is done everywhere, since it turns out to
be much faster to insert a `set-mcar!' with a 3d mpair, rather than a
call to a thunk.

Note that it still uses mpairs as a hack.  It "works" in the same way
that this simplified example does:

  (define-syntax m
    (let ([b (mcons 0 0)])
      (lambda (stx)
        (with-syntax ([b b])
          #'(case-lambda [() (mcar b)]
                         [(x) (set-mcar! b x)])))))

I think that it's fragile, and likely to stop working at some point, but
I don't see anything better for now.
This commit is contained in:
Eli Barzilay 2010-10-04 15:39:45 -04:00
parent ad76c9ea7b
commit 2189957b6f
7 changed files with 141 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/deinprogramm/deinprogramm-langs.rkt
View File

@ -1246,10 +1246,12 @@
;; test coverage ;; test coverage
;; ;;
;; WARNING: much code copied from "collects/lang/htdp-langs.rkt"
(define test-coverage-enabled (make-parameter #t)) (define test-coverage-enabled (make-parameter #t))
(define current-test-coverage-info (make-thread-cell #f)) (define current-test-coverage-info (make-thread-cell #f))
(define (initialize-test-coverage-point key expr) (define (initialize-test-coverage-point expr)
(unless (thread-cell-ref current-test-coverage-info) (unless (thread-cell-ref current-test-coverage-info)
(let ([ht (make-hasheq)]) (let ([ht (make-hasheq)])
(thread-cell-set! current-test-coverage-info ht) (thread-cell-set! current-test-coverage-info ht)
@ -1272,15 +1274,19 @@
(send rep set-test-coverage-info ht on-sd off-sd #f))))))))) (send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
(let ([ht (thread-cell-ref current-test-coverage-info)]) (let ([ht (thread-cell-ref current-test-coverage-info)])
(when ht (when ht
(hash-set! ht key (mcons #f expr))))) (hash-set! ht expr #;(box #f) (mcons #f #f)))))
(define (test-covered key) (define (test-covered expr)
(let ([ht (thread-cell-ref current-test-coverage-info)]) (let* ([ht (or (thread-cell-ref current-test-coverage-info)
(and ht (error 'deinprogramm-langs
(let ([v (hash-ref ht key)]) "internal-error: no test-coverage table"))]
(and v [v (hash-ref ht expr
(with-syntax ([v v]) (lambda ()
#'(set-mcar! v #t))))))) (error 'deinprogramm-langs
"internal-error: expression not found: ~.s"
expr)))])
#; (lambda () (set-box! v #t))
(with-syntax ([v v]) #'(#%plain-app set-mcar! v #t))))
(define-values/invoke-unit et:stacktrace@ (define-values/invoke-unit et:stacktrace@
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))

35
collects/drracket/private/debug.rkt
View File

@ -925,7 +925,7 @@ profile todo:
(define current-test-coverage-info (make-thread-cell #f)) (define current-test-coverage-info (make-thread-cell #f))
(define (initialize-test-coverage-point key expr) (define (initialize-test-coverage-point expr)
(unless (hash? (thread-cell-ref current-test-coverage-info)) (unless (hash? (thread-cell-ref current-test-coverage-info))
(let ([rep (drracket:rep:current-rep)]) (let ([rep (drracket:rep:current-rep)])
(when rep (when rep
@ -938,14 +938,14 @@ profile todo:
(when (hash? ht) (when (hash? ht)
;; if rep isn't around, we don't do test coverage... ;; if rep isn't around, we don't do test coverage...
;; this can happen when check syntax expands, for example ;; this can happen when check syntax expands, for example
(hash-set! ht key (mcons #f expr))))) (hash-set! ht expr #;(box #f) (mcons #f #f)))))
(define (test-covered key) (define (test-covered expr)
(let ([ht (thread-cell-ref current-test-coverage-info)]) (let ([ht (thread-cell-ref current-test-coverage-info)])
(and (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point' (and (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point'
(let ([v (hash-ref ht key #f)]) (let ([v (hash-ref ht expr #f)])
(and v ;; (and v (λ () (set-box! v #t)))
(λ () (set-mcar! v #t))))))) (and v (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))))))
(define test-coverage-interactions-text<%> (define test-coverage-interactions-text<%>
(interface () (interface ()
@ -1075,7 +1075,6 @@ profile todo:
[locked-ht (make-hasheq)] [locked-ht (make-hasheq)]
[already-frozen-ht (make-hasheq)] [already-frozen-ht (make-hasheq)]
[actions-ht (make-hash)] [actions-ht (make-hash)]
[on/syntaxes (hash-map ht (λ (_ pr) pr))]
;; can-annotate : (listof (list boolean srcloc)) ;; can-annotate : (listof (list boolean srcloc))
;; boolean is #t => code was run ;; boolean is #t => code was run
@ -1083,17 +1082,17 @@ profile todo:
;; remove those that cannot be annotated ;; remove those that cannot be annotated
[can-annotate [can-annotate
(filter values (filter values
(map (λ (pr) (hash-map ht
(let ([stx (mcdr pr)]) (λ (stx covered?)
(and (syntax? stx) (and (syntax? stx)
(let ([src (syntax-source stx)] (let ([src (syntax-source stx)]
[pos (syntax-position stx)] [pos (syntax-position stx)]
[span (syntax-span stx)]) [span (syntax-span stx)])
(and pos (and pos
span span
(send (get-defs) port-name-matches? src) (send (get-defs) port-name-matches? src)
(list (mcar pr) (make-srcloc (get-defs) #f #f pos span))))))) (list (mcar covered?)
on/syntaxes))] (make-srcloc (get-defs) #f #f pos span))))))))]
;; filtered : (listof (list boolean srcloc)) ;; filtered : (listof (list boolean srcloc))
;; remove redundant expressions ;; remove redundant expressions

8
collects/errortrace/errortrace-lib.rkt
View File

@ -66,7 +66,7 @@
;; expressions with test suite coverage information. Returning the ;; expressions with test suite coverage information. Returning the
;; first argument means no tests coverage information is collected. ;; first argument means no tests coverage information is collected.
;; test-coverage-point : syntax syntax -> (values syntax info) ;; test-coverage-point : syntax syntax integer -> (values syntax info)
;; sets a test coverage point for a single expression ;; sets a test coverage point for a single expression
(define (test-coverage-point body expr phase) (define (test-coverage-point body expr phase)
(if (and (test-coverage-enabled) (zero? phase)) (if (and (test-coverage-enabled) (zero? phase))
@ -240,10 +240,8 @@
(with-syntax ([key (datum->syntax #f key (quote-syntax here))] (with-syntax ([key (datum->syntax #f key (quote-syntax here))]
[expr expr] [expr expr]
[register-executed-once register-executed-once]);<- 3D! [register-executed-once register-executed-once]);<- 3D!
(syntax #'(begin (register-executed-once 'key)
(begin expr)))
(register-executed-once 'key)
expr))))
expr)) expr))
(define (get-execute-counts) (define (get-execute-counts)

32
collects/errortrace/scribblings/errortrace.scrbl
View File

@ -418,27 +418,31 @@ be wrapped.}
Determines if the test coverage annotation is inserted into the code. Determines if the test coverage annotation is inserted into the code.
This parameter controls how compilation happens---it does not affect the This parameter controls how compilation happens---it does not affect the
dynamic behavior of the already compiled code. If the parameter is set, dynamic behavior of the already compiled code. If the parameter is set,
calls to @schemein[test-covered] are inserted into the code (and code generated by @schemein[test-covered] are inserted into the code (and
@schemein[initialize-test-coverage-point] is called during compilation). @schemein[initialize-test-coverage-point] is called during compilation).
If not, no calls to test-covered are inserted.} If not, no calls to @scheme[test-covered] code are inserted.}
@defproc[(test-covered (key any/c)) (or/c (-> void?) syntax? #f)]{ @defproc[(test-covered (stx any/c)) (or/c syntax? (-> void?) #f)]{
This is called during compilation of the program with a key value once This is called during compilation of the program with an expression for
for each point with the key for that program point that was passed to each point in the program that was passed to
@schemein[initialize-test-coverage-point]. @schemein[initialize-test-coverage-point].
If the result is @scheme[#f], this program point is not If the result is @scheme[#f], this program point is not instrumented. If
instrumented. If the result is syntax, it is inserted into the code, the result is syntax, it is inserted into the code, and if it is a
and if it is a thunk, the thunk is inserted into the code in an thunk, the thunk is inserted into the code in an application (using the
application. In either case, the syntax or the thunk should register thunk directly, as a 3D value). In either case, the syntax or the thunk
that the relevant point was covered.} should register that the relevant point was covered.
@defproc[(initialize-test-coverage-point (key any/c) (stx any/c)) void?]{ Note: using a thunk tends to be slow. Current uses in the Racket code
will create a mutable pair in @scheme[initialize-test-coverage-point],
and @scheme[test-covered] returns syntax that will set its mcar. (This
makes the resulting overhead about 3 times smaller.)}
@defproc[(initialize-test-coverage-point (stx any/c)) void?]{
During compilation of the program, this function is called with each During compilation of the program, this function is called with each
sub-expression of the program. The first argument is a special key sub-expression of the program. The argument is the syntax of this program
used to identify this program point. The second argument is the point, which is usually used as a key to identify this program point.}
syntax of this program point.}
@defthing[profile-key any/c]{ @defthing[profile-key any/c]{

25
collects/errortrace/stacktrace.rkt
View File

@ -85,20 +85,17 @@
(if (and (test-coverage-enabled) (if (and (test-coverage-enabled)
(zero? phase) (zero? phase)
(syntax-position expr)) (syntax-position expr))
(let* ([key (gensym 'test-coverage-point)]) (begin (initialize-test-coverage-point expr)
(initialize-test-coverage-point key expr) (let ([thunk (test-covered expr)])
(let ([thunk (test-covered key)]) (cond [(procedure? thunk)
(cond (with-syntax ([body body]
[(procedure? thunk) [thunk thunk])
(with-syntax ([body body] #'(begin (#%plain-app thunk) body))]
[thunk thunk]) [(syntax? thunk)
#'(begin (#%plain-app thunk) body))] (with-syntax ([body body]
[(syntax? thunk) [thunk thunk])
(with-syntax ([body body] #'(begin thunk body))]
[thunk thunk]) [else body])))
#'(begin thunk body))]
[else
body])))
body)) body))

23
collects/lang/htdp-langs.rkt
View File

@ -1076,7 +1076,7 @@
(define test-coverage-enabled (make-parameter #t)) (define test-coverage-enabled (make-parameter #t))
(define current-test-coverage-info (make-thread-cell #f)) (define current-test-coverage-info (make-thread-cell #f))
(define (initialize-test-coverage-point key expr) (define (initialize-test-coverage-point expr)
(unless (thread-cell-ref current-test-coverage-info) (unless (thread-cell-ref current-test-coverage-info)
(let ([ht (make-hasheq)]) (let ([ht (make-hasheq)])
(thread-cell-set! current-test-coverage-info ht) (thread-cell-set! current-test-coverage-info ht)
@ -1144,16 +1144,19 @@
(send rep set-test-coverage-info ht on-sd off-sd #f))))))))) (send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
(let ([ht (thread-cell-ref current-test-coverage-info)]) (let ([ht (thread-cell-ref current-test-coverage-info)])
(when ht (when ht
(hash-set! ht key (mcons #f expr))))) (hash-set! ht expr #;(box #f) (mcons #f #f)))))
(define (test-covered key) (define (test-covered expr)
(let* ([ht (thread-cell-ref current-test-coverage-info)] (let* ([ht (or (thread-cell-ref current-test-coverage-info)
[v (and ht (hash-ref ht key #f))]) (error 'htdp-langs
(with-syntax ([v v]) "internal-error: no test-coverage table"))]
#'(set-mcar! v #t)) [v (hash-ref ht expr
#; (lambda ()
(and v (error 'htdp-langs
(λ () (set-mcar! v #t))))) "internal-error: expression not found: ~.s"
expr)))])
#; (lambda () (set-box! v #t))
(with-syntax ([v v]) #'(#%plain-app set-mcar! v #t))))
(define-values/invoke-unit et:stacktrace@ (define-values/invoke-unit et:stacktrace@
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))

125
collects/racket/private/sandbox-coverage.rkt
View File

@ -1,70 +1,73 @@
;; This file is is used in the context of sandboxed code, it uses the ;; This file is is used in the context of sandboxed code, it uses the
;; stacktrace interface from errortrace to find uncovered expressions. ;; stacktrace interface from errortrace to find uncovered expressions.
(module sandbox-coverage mzscheme #lang racket/base
(require errortrace/stacktrace mzlib/unit mzlib/list) (require errortrace/stacktrace racket/unit (for-template racket/base))
;; Test coverage run-time support ;; Test coverage run-time support
(define test-coverage-enabled (make-parameter #t)) (define test-coverage-enabled (make-parameter #t))
(define test-coverage-info (make-hash-table)) (define test-coverage-info (make-hasheq))
(define (initialize-test-coverage-point key expr) (define (initialize-test-coverage-point expr)
(hash-table-put! test-coverage-info key (mcons expr #f))) (hash-set! test-coverage-info expr (mcons #f #f)))
(define (test-covered key) (define (test-covered expr)
(let ([mpair (hash-table-get test-coverage-info key)]) (let ([v (hash-ref test-coverage-info expr
(λ () (set-mcdr! mpair #t)))) (lambda ()
(error 'sandbox-coverage
"internal error: no info for ~.s" expr)))])
(and v (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))))
(define (get-uncovered-expressions) (define (get-uncovered-expressions)
(let* ([xs (hash-table-map test-coverage-info (lambda (k v) (let* ([xs (hash-map test-coverage-info
(cons (mcar v) (mcdr v))))] (lambda (k v) (cons k (mcar v))))]
[xs (filter (lambda (x) (syntax-position (car x))) xs)] [xs (filter (lambda (x) (syntax-position (car x))) xs)]
[xs (sort xs (lambda (x1 x2) [xs (sort xs (lambda (x1 x2)
(let ([p1 (syntax-position (car x1))] (let ([p1 (syntax-position (car x1))]
[p2 (syntax-position (car x2))]) [p2 (syntax-position (car x2))])
(or (< p1 p2) ; earlier first (or (< p1 p2) ; earlier first
(and (= p1 p2) (and (= p1 p2)
(> (syntax-span (car x1)) ; wider first (> (syntax-span (car x1)) ; wider first
(syntax-span (car x2))))))))] (syntax-span (car x2))))))))]
[xs (reverse xs)]) [xs (reverse xs)])
(if (null? xs) (if (null? xs)
xs xs
(let loop ([xs (cdr xs)] [r (list (car xs))]) (let loop ([xs (cdr xs)] [r (list (car xs))])
(if (null? xs) (if (null? xs)
(map car (filter (lambda (x) (not (cdr x))) r)) (map car (filter (lambda (x) (not (cdr x))) r))
(loop (cdr xs) (loop (cdr xs)
(cond [(not (and (= (syntax-position (caar xs)) (cond [(not (and (= (syntax-position (caar xs))
(syntax-position (caar r))) (syntax-position (caar r)))
(= (syntax-span (caar xs)) (= (syntax-span (caar xs))
(syntax-span (caar r))))) (syntax-span (caar r)))))
(cons (car xs) r)] (cons (car xs) r)]
[(cdar r) r] [(cdar r) r]
[else (cons (car xs) (cdr r))]))))))) [else (cons (car xs) (cdr r))])))))))
(provide get-uncovered-expressions) (provide get-uncovered-expressions)
;; no profiling ;; no profiling
(define profile-key #f) (define profile-key #f)
(define profiling-enabled (lambda () #f)) (define profiling-enabled (lambda () #f))
(define initialize-profile-point void) (define initialize-profile-point void)
(define register-profile-start void) (define register-profile-start void)
(define register-profile-done void) (define register-profile-done void)
;; no marks ;; no marks
(define (with-mark mark expr) expr) (define (with-mark mark expr) expr)
(define-values/invoke-unit/infer stacktrace@) (define-values/invoke-unit/infer stacktrace@)
(define errortrace-compile-handler (define errortrace-compile-handler
(let ([orig (current-compile)] (let ([orig (current-compile)]
[ns (current-namespace)]) [ns (current-namespace)])
(lambda (e immediate-eval?) (lambda (e immediate-eval?)
(orig (if (and (eq? ns (current-namespace)) (orig (if (and (eq? ns (current-namespace))
(not (compiled-expression? (not (compiled-expression?
(if (syntax? e) (syntax-e e) e)))) (if (syntax? e) (syntax-e e) e))))
(annotate-top (annotate-top
(expand-syntax (if (syntax? e) (expand-syntax (if (syntax? e)
e e
(namespace-syntax-introduce (namespace-syntax-introduce
(datum->syntax-object #f e)))) (datum->syntax #f e))))
(namespace-base-phase)) (namespace-base-phase))
e) e)
immediate-eval?)))) immediate-eval?))))
(current-compile errortrace-compile-handler)) (current-compile errortrace-compile-handler)