Change the errortrace protocol for `initialize-test-coverage-point' and
`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:
parent
ad76c9ea7b
commit
2189957b6f
|
@ -1246,10 +1246,12 @@
|
|||
;; test coverage
|
||||
;;
|
||||
|
||||
;; WARNING: much code copied from "collects/lang/htdp-langs.rkt"
|
||||
|
||||
(define test-coverage-enabled (make-parameter #t))
|
||||
(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)
|
||||
(let ([ht (make-hasheq)])
|
||||
(thread-cell-set! current-test-coverage-info ht)
|
||||
|
@ -1272,15 +1274,19 @@
|
|||
(send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
|
||||
(let ([ht (thread-cell-ref current-test-coverage-info)])
|
||||
(when ht
|
||||
(hash-set! ht key (mcons #f expr)))))
|
||||
(hash-set! ht expr #;(box #f) (mcons #f #f)))))
|
||||
|
||||
(define (test-covered key)
|
||||
(let ([ht (thread-cell-ref current-test-coverage-info)])
|
||||
(and ht
|
||||
(let ([v (hash-ref ht key)])
|
||||
(and v
|
||||
(with-syntax ([v v])
|
||||
#'(set-mcar! v #t)))))))
|
||||
(define (test-covered expr)
|
||||
(let* ([ht (or (thread-cell-ref current-test-coverage-info)
|
||||
(error 'deinprogramm-langs
|
||||
"internal-error: no test-coverage table"))]
|
||||
[v (hash-ref ht expr
|
||||
(lambda ()
|
||||
(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@
|
||||
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))
|
||||
|
|
|
@ -925,7 +925,7 @@ profile todo:
|
|||
|
||||
(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))
|
||||
(let ([rep (drracket:rep:current-rep)])
|
||||
(when rep
|
||||
|
@ -938,14 +938,14 @@ profile todo:
|
|||
(when (hash? ht)
|
||||
;; if rep isn't around, we don't do test coverage...
|
||||
;; 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)])
|
||||
(and (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point'
|
||||
(let ([v (hash-ref ht key #f)])
|
||||
(and v
|
||||
(λ () (set-mcar! v #t)))))))
|
||||
(let ([v (hash-ref ht expr #f)])
|
||||
;; (and v (λ () (set-box! v #t)))
|
||||
(and v (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))))))
|
||||
|
||||
(define test-coverage-interactions-text<%>
|
||||
(interface ()
|
||||
|
@ -1075,7 +1075,6 @@ profile todo:
|
|||
[locked-ht (make-hasheq)]
|
||||
[already-frozen-ht (make-hasheq)]
|
||||
[actions-ht (make-hash)]
|
||||
[on/syntaxes (hash-map ht (λ (_ pr) pr))]
|
||||
|
||||
;; can-annotate : (listof (list boolean srcloc))
|
||||
;; boolean is #t => code was run
|
||||
|
@ -1083,17 +1082,17 @@ profile todo:
|
|||
;; remove those that cannot be annotated
|
||||
[can-annotate
|
||||
(filter values
|
||||
(map (λ (pr)
|
||||
(let ([stx (mcdr pr)])
|
||||
(and (syntax? stx)
|
||||
(let ([src (syntax-source stx)]
|
||||
[pos (syntax-position stx)]
|
||||
[span (syntax-span stx)])
|
||||
(and pos
|
||||
span
|
||||
(send (get-defs) port-name-matches? src)
|
||||
(list (mcar pr) (make-srcloc (get-defs) #f #f pos span)))))))
|
||||
on/syntaxes))]
|
||||
(hash-map ht
|
||||
(λ (stx covered?)
|
||||
(and (syntax? stx)
|
||||
(let ([src (syntax-source stx)]
|
||||
[pos (syntax-position stx)]
|
||||
[span (syntax-span stx)])
|
||||
(and pos
|
||||
span
|
||||
(send (get-defs) port-name-matches? src)
|
||||
(list (mcar covered?)
|
||||
(make-srcloc (get-defs) #f #f pos span))))))))]
|
||||
|
||||
;; filtered : (listof (list boolean srcloc))
|
||||
;; remove redundant expressions
|
||||
|
|
|
@ -66,7 +66,7 @@
|
|||
;; expressions with test suite coverage information. Returning the
|
||||
;; 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
|
||||
(define (test-coverage-point body expr phase)
|
||||
(if (and (test-coverage-enabled) (zero? phase))
|
||||
|
@ -240,10 +240,8 @@
|
|||
(with-syntax ([key (datum->syntax #f key (quote-syntax here))]
|
||||
[expr expr]
|
||||
[register-executed-once register-executed-once]);<- 3D!
|
||||
(syntax
|
||||
(begin
|
||||
(register-executed-once 'key)
|
||||
expr))))
|
||||
#'(begin (register-executed-once 'key)
|
||||
expr)))
|
||||
expr))
|
||||
|
||||
(define (get-execute-counts)
|
||||
|
|
|
@ -418,27 +418,31 @@ be wrapped.}
|
|||
Determines if the test coverage annotation is inserted into the code.
|
||||
This parameter controls how compilation happens---it does not affect the
|
||||
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).
|
||||
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)]{
|
||||
This is called during compilation of the program with a key value once
|
||||
for each point with the key for that program point that was passed to
|
||||
@defproc[(test-covered (stx any/c)) (or/c syntax? (-> void?) #f)]{
|
||||
This is called during compilation of the program with an expression for
|
||||
each point in the program that was passed to
|
||||
@schemein[initialize-test-coverage-point].
|
||||
|
||||
If the result is @scheme[#f], this program point is not
|
||||
instrumented. If the result is syntax, it is inserted into the code,
|
||||
and if it is a thunk, the thunk is inserted into the code in an
|
||||
application. In either case, the syntax or the thunk should register
|
||||
that the relevant point was covered.}
|
||||
If the result is @scheme[#f], this program point is not instrumented. If
|
||||
the result is syntax, it is inserted into the code, and if it is a
|
||||
thunk, the thunk is inserted into the code in an application (using the
|
||||
thunk directly, as a 3D value). In either case, the syntax or the thunk
|
||||
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
|
||||
sub-expression of the program. The first argument is a special key
|
||||
used to identify this program point. The second argument is the
|
||||
syntax of this program point.}
|
||||
sub-expression of the program. The argument is the syntax of this program
|
||||
point, which is usually used as a key to identify this program point.}
|
||||
|
||||
@defthing[profile-key any/c]{
|
||||
|
||||
|
|
|
@ -85,20 +85,17 @@
|
|||
(if (and (test-coverage-enabled)
|
||||
(zero? phase)
|
||||
(syntax-position expr))
|
||||
(let* ([key (gensym 'test-coverage-point)])
|
||||
(initialize-test-coverage-point key expr)
|
||||
(let ([thunk (test-covered key)])
|
||||
(cond
|
||||
[(procedure? thunk)
|
||||
(with-syntax ([body body]
|
||||
[thunk thunk])
|
||||
#'(begin (#%plain-app thunk) body))]
|
||||
[(syntax? thunk)
|
||||
(with-syntax ([body body]
|
||||
[thunk thunk])
|
||||
#'(begin thunk body))]
|
||||
[else
|
||||
body])))
|
||||
(begin (initialize-test-coverage-point expr)
|
||||
(let ([thunk (test-covered expr)])
|
||||
(cond [(procedure? thunk)
|
||||
(with-syntax ([body body]
|
||||
[thunk thunk])
|
||||
#'(begin (#%plain-app thunk) body))]
|
||||
[(syntax? thunk)
|
||||
(with-syntax ([body body]
|
||||
[thunk thunk])
|
||||
#'(begin thunk body))]
|
||||
[else body])))
|
||||
body))
|
||||
|
||||
|
||||
|
|
|
@ -1076,7 +1076,7 @@
|
|||
(define test-coverage-enabled (make-parameter #t))
|
||||
(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)
|
||||
(let ([ht (make-hasheq)])
|
||||
(thread-cell-set! current-test-coverage-info ht)
|
||||
|
@ -1144,16 +1144,19 @@
|
|||
(send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
|
||||
(let ([ht (thread-cell-ref current-test-coverage-info)])
|
||||
(when ht
|
||||
(hash-set! ht key (mcons #f expr)))))
|
||||
(hash-set! ht expr #;(box #f) (mcons #f #f)))))
|
||||
|
||||
(define (test-covered key)
|
||||
(let* ([ht (thread-cell-ref current-test-coverage-info)]
|
||||
[v (and ht (hash-ref ht key #f))])
|
||||
(with-syntax ([v v])
|
||||
#'(set-mcar! v #t))
|
||||
#;
|
||||
(and v
|
||||
(λ () (set-mcar! v #t)))))
|
||||
(define (test-covered expr)
|
||||
(let* ([ht (or (thread-cell-ref current-test-coverage-info)
|
||||
(error 'htdp-langs
|
||||
"internal-error: no test-coverage table"))]
|
||||
[v (hash-ref ht expr
|
||||
(lambda ()
|
||||
(error 'htdp-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@
|
||||
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))
|
||||
|
|
|
@ -1,70 +1,73 @@
|
|||
;; This file is is used in the context of sandboxed code, it uses the
|
||||
;; stacktrace interface from errortrace to find uncovered expressions.
|
||||
(module sandbox-coverage mzscheme
|
||||
(require errortrace/stacktrace mzlib/unit mzlib/list)
|
||||
#lang racket/base
|
||||
(require errortrace/stacktrace racket/unit (for-template racket/base))
|
||||
|
||||
;; Test coverage run-time support
|
||||
(define test-coverage-enabled (make-parameter #t))
|
||||
(define test-coverage-info (make-hash-table))
|
||||
(define (initialize-test-coverage-point key expr)
|
||||
(hash-table-put! test-coverage-info key (mcons expr #f)))
|
||||
(define (test-covered key)
|
||||
(let ([mpair (hash-table-get test-coverage-info key)])
|
||||
(λ () (set-mcdr! mpair #t))))
|
||||
;; Test coverage run-time support
|
||||
(define test-coverage-enabled (make-parameter #t))
|
||||
(define test-coverage-info (make-hasheq))
|
||||
(define (initialize-test-coverage-point expr)
|
||||
(hash-set! test-coverage-info expr (mcons #f #f)))
|
||||
(define (test-covered expr)
|
||||
(let ([v (hash-ref test-coverage-info expr
|
||||
(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)
|
||||
(let* ([xs (hash-table-map test-coverage-info (lambda (k v)
|
||||
(cons (mcar v) (mcdr v))))]
|
||||
[xs (filter (lambda (x) (syntax-position (car x))) xs)]
|
||||
[xs (sort xs (lambda (x1 x2)
|
||||
(let ([p1 (syntax-position (car x1))]
|
||||
[p2 (syntax-position (car x2))])
|
||||
(or (< p1 p2) ; earlier first
|
||||
(and (= p1 p2)
|
||||
(> (syntax-span (car x1)) ; wider first
|
||||
(syntax-span (car x2))))))))]
|
||||
[xs (reverse xs)])
|
||||
(if (null? xs)
|
||||
xs
|
||||
(let loop ([xs (cdr xs)] [r (list (car xs))])
|
||||
(if (null? xs)
|
||||
(map car (filter (lambda (x) (not (cdr x))) r))
|
||||
(loop (cdr xs)
|
||||
(cond [(not (and (= (syntax-position (caar xs))
|
||||
(syntax-position (caar r)))
|
||||
(= (syntax-span (caar xs))
|
||||
(syntax-span (caar r)))))
|
||||
(cons (car xs) r)]
|
||||
[(cdar r) r]
|
||||
[else (cons (car xs) (cdr r))])))))))
|
||||
(define (get-uncovered-expressions)
|
||||
(let* ([xs (hash-map test-coverage-info
|
||||
(lambda (k v) (cons k (mcar v))))]
|
||||
[xs (filter (lambda (x) (syntax-position (car x))) xs)]
|
||||
[xs (sort xs (lambda (x1 x2)
|
||||
(let ([p1 (syntax-position (car x1))]
|
||||
[p2 (syntax-position (car x2))])
|
||||
(or (< p1 p2) ; earlier first
|
||||
(and (= p1 p2)
|
||||
(> (syntax-span (car x1)) ; wider first
|
||||
(syntax-span (car x2))))))))]
|
||||
[xs (reverse xs)])
|
||||
(if (null? xs)
|
||||
xs
|
||||
(let loop ([xs (cdr xs)] [r (list (car xs))])
|
||||
(if (null? xs)
|
||||
(map car (filter (lambda (x) (not (cdr x))) r))
|
||||
(loop (cdr xs)
|
||||
(cond [(not (and (= (syntax-position (caar xs))
|
||||
(syntax-position (caar r)))
|
||||
(= (syntax-span (caar xs))
|
||||
(syntax-span (caar r)))))
|
||||
(cons (car xs) r)]
|
||||
[(cdar r) r]
|
||||
[else (cons (car xs) (cdr r))])))))))
|
||||
|
||||
(provide get-uncovered-expressions)
|
||||
(provide get-uncovered-expressions)
|
||||
|
||||
;; no profiling
|
||||
(define profile-key #f)
|
||||
(define profiling-enabled (lambda () #f))
|
||||
(define initialize-profile-point void)
|
||||
(define register-profile-start void)
|
||||
(define register-profile-done void)
|
||||
;; no marks
|
||||
(define (with-mark mark expr) expr)
|
||||
;; no profiling
|
||||
(define profile-key #f)
|
||||
(define profiling-enabled (lambda () #f))
|
||||
(define initialize-profile-point void)
|
||||
(define register-profile-start void)
|
||||
(define register-profile-done void)
|
||||
;; no marks
|
||||
(define (with-mark mark expr) expr)
|
||||
|
||||
(define-values/invoke-unit/infer stacktrace@)
|
||||
(define-values/invoke-unit/infer stacktrace@)
|
||||
|
||||
(define errortrace-compile-handler
|
||||
(let ([orig (current-compile)]
|
||||
[ns (current-namespace)])
|
||||
(lambda (e immediate-eval?)
|
||||
(orig (if (and (eq? ns (current-namespace))
|
||||
(not (compiled-expression?
|
||||
(if (syntax? e) (syntax-e e) e))))
|
||||
(annotate-top
|
||||
(expand-syntax (if (syntax? e)
|
||||
e
|
||||
(namespace-syntax-introduce
|
||||
(datum->syntax-object #f e))))
|
||||
(namespace-base-phase))
|
||||
e)
|
||||
immediate-eval?))))
|
||||
(define errortrace-compile-handler
|
||||
(let ([orig (current-compile)]
|
||||
[ns (current-namespace)])
|
||||
(lambda (e immediate-eval?)
|
||||
(orig (if (and (eq? ns (current-namespace))
|
||||
(not (compiled-expression?
|
||||
(if (syntax? e) (syntax-e e) e))))
|
||||
(annotate-top
|
||||
(expand-syntax (if (syntax? e)
|
||||
e
|
||||
(namespace-syntax-introduce
|
||||
(datum->syntax #f e))))
|
||||
(namespace-base-phase))
|
||||
e)
|
||||
immediate-eval?))))
|
||||
|
||||
(current-compile errortrace-compile-handler))
|
||||
(current-compile errortrace-compile-handler)
|
||||
|
|
Loading…
Reference in New Issue
Block a user