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

Use module registry trick to slightly speed up TR tests.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2012-08-22 11:07:39 -04:00
parent 30da0f4bf4
commit 26a57f6420
1 changed files with 10 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/tests/typed-racket/places.rkt
View File

@ -28,12 +28,15 @@
(exn:fail m (current-continuation-marks))] (exn:fail m (current-continuation-marks))]
[(s-exn m) [(s-exn m)
(exn m (current-continuation-marks))])) (exn m (current-continuation-marks))]))
(define (dr p)
(define (dr p [reg-box #f])
(parameterize ([current-namespace (make-base-empty-namespace)]) (parameterize ([current-namespace (make-base-empty-namespace)])
(dynamic-require `(file ,(if (string? p) p (path->string p))) #f))) (dynamic-require `(file ,(if (string? p) p (path->string p))) #f)
(and reg-box (set-box! reg-box (namespace-module-registry (current-namespace))))))
(define (start-worker get-ch name) (define (start-worker get-ch name)
(open-place ch (open-place ch
(define reg (box #f))
(let loop () (let loop ()
(match (place-channel-get get-ch) (match (place-channel-get get-ch)
[(vector 'log name dir res) [(vector 'log name dir res)
@ -41,7 +44,7 @@
(λ (e) (place-channel-put (λ (e) (place-channel-put
res res
(string-append "EXCEPTION: " (exn-message e))))]) (string-append "EXCEPTION: " (exn-message e))))])
(define lg (generate-log/place name dir)) (define lg (generate-log/place name dir reg))
(place-channel-put res lg)) (place-channel-put res lg))
(loop)] (loop)]
[(vector p* res error?) [(vector p* res error?)
@ -54,13 +57,13 @@
[error-display-handler (if error? void (error-display-handler))]) [error-display-handler (if error? void (error-display-handler))])
(with-handlers ([exn? (λ (e) (with-handlers ([exn? (λ (e)
(place-channel-put res (serialize-exn e)))]) (place-channel-put res (serialize-exn e)))])
(dr p) (dr p reg)
(place-channel-put res #t))) (place-channel-put res #t)))
(loop)])))) (loop)]))))
(define comp (compile-zos #f #:module? #t)) (define comp (compile-zos #f #:module? #t))
(define (generate-log/place name dir) (define (generate-log/place name dir [reg-box #f])
;; some tests require other tests, so some fiddling is required ;; some tests require other tests, so some fiddling is required
(define f (build-path dir name)) (define f (build-path dir name))
(with-output-to-string (with-output-to-string
@ -72,6 +75,7 @@
(parameterize (parameterize
([current-namespace (make-base-empty-namespace)] ([current-namespace (make-base-empty-namespace)]
[current-load-relative-directory dir]) [current-load-relative-directory dir])
(dynamic-require f #f)) (dynamic-require f #f)
(and reg-box (set-box! reg-box (namespace-module-registry (current-namespace)))))
;; clean up compiled files in prevision of the next testing run ;; clean up compiled files in prevision of the next testing run
(delete-directory/files (build-path dir "compiled"))))) (delete-directory/files (build-path dir "compiled")))))