From 2c85b7a7951b29089b6989fc37f639076ae05895 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 1 Apr 2009 00:15:20 +0000 Subject: [PATCH] improved performance of the teaching languages svn: r14394 --- collects/deinprogramm/deinprogramm-langs.ss | 8 ++++--- collects/drscheme/private/debug.ss | 7 +++--- .../errortrace/scribblings/errortrace.scrbl | 13 +++++++---- collects/errortrace/stacktrace.ss | 23 +++++++++++++------ collects/lang/htdp-langs.ss | 11 +++++---- collects/scheme/private/sandbox-coverage.ss | 3 ++- 6 files changed, 43 insertions(+), 22 deletions(-) diff --git a/collects/deinprogramm/deinprogramm-langs.ss b/collects/deinprogramm/deinprogramm-langs.ss index a89e851fc1..c9de0aaa40 100644 --- a/collects/deinprogramm/deinprogramm-langs.ss +++ b/collects/deinprogramm/deinprogramm-langs.ss @@ -1282,9 +1282,11 @@ (define (test-covered key) (let ([ht (thread-cell-ref current-test-coverage-info)]) - (when ht - (let ([v (hash-ref ht key)]) - (set-mcar! v #t))))) + (and ht + (let ([v (hash-ref ht key)]) + (and v + (with-syntax ([v v]) + #'(set-mcar! v #t))))))) (define-values/invoke-unit et:stacktrace@ (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 132a23caa6..4c055625cd 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -899,9 +899,10 @@ profile todo: (define (test-covered key) (let ([ht (thread-cell-ref current-test-coverage-info)]) - (when (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point' - (let ([v (hash-ref ht key)]) - (set-mcar! v #t))))) + (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))))))) (define test-coverage-interactions-text<%> (interface () diff --git a/collects/errortrace/scribblings/errortrace.scrbl b/collects/errortrace/scribblings/errortrace.scrbl index 87305e95de..e9f1d518f2 100644 --- a/collects/errortrace/scribblings/errortrace.scrbl +++ b/collects/errortrace/scribblings/errortrace.scrbl @@ -350,11 +350,16 @@ calls to @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.} -@defproc[(test-covered (key any/c)) void?]{ +@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 +@schemein[initialize-test-coverage-point]. -During execution of the program, this is called for each point with -the key for that program point 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.} @defproc[(initialize-test-coverage-point (key any/c) (stx any/c)) void?]{ diff --git a/collects/errortrace/stacktrace.ss b/collects/errortrace/stacktrace.ss index c4fb5478ef..2330bbc144 100644 --- a/collects/errortrace/stacktrace.ss +++ b/collects/errortrace/stacktrace.ss @@ -83,14 +83,23 @@ ;; test-coverage-point : syntax syntax -> syntax ;; sets a test coverage point for a single expression (define (test-coverage-point body expr phase) - (if (and (test-coverage-enabled) (zero? phase)) - (let ([key (gensym 'test-coverage-point)]) + (if (and (test-coverage-enabled) + (zero? phase) + (syntax-position expr)) + (let* ([key (gensym 'test-coverage-point)]) (initialize-test-coverage-point key expr) - (with-syntax ([key (datum->syntax - #f key (quote-syntax here))] - [body body] - [test-covered test-covered]) - #'(begin (#%plain-app test-covered 'key) body))) + (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]))) body)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 65ffafd3f9..f472763c63 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -1102,10 +1102,13 @@ (hash-set! ht key (mcons #f expr))))) (define (test-covered key) - (let ([ht (thread-cell-ref current-test-coverage-info)]) - (when ht - (let ([v (hash-ref ht key)]) - (set-mcar! v #t))))) + (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-values/invoke-unit et:stacktrace@ (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) diff --git a/collects/scheme/private/sandbox-coverage.ss b/collects/scheme/private/sandbox-coverage.ss index 4a9c1e3453..6b3e891ae4 100644 --- a/collects/scheme/private/sandbox-coverage.ss +++ b/collects/scheme/private/sandbox-coverage.ss @@ -9,7 +9,8 @@ (define (initialize-test-coverage-point key expr) (hash-table-put! test-coverage-info key (mcons expr #f))) (define (test-covered key) - (set-mcdr! (hash-table-get test-coverage-info key) #t)) + (let ([mpair (hash-table-get test-coverage-info key)]) + (λ () (set-mcdr! mpair #t)))) (define (get-uncovered-expressions) (let* ([xs (hash-table-map test-coverage-info (lambda (k v)