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

Add -v option to TR tests.

Browse Source 
Also, print errors from serialization and place message sending.
This commit is contained in:
Sam Tobin-Hochstadt 2012-08-22 12:29:17 -04:00
parent e9f209977b
commit e207f5c67d
4 changed files with 19 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/tests/typed-racket/main.rkt
View File

@ -71,6 +71,8 @@
(test (test
(build-path path p) (build-path path p)
(λ () (λ ()
(when (verbose?)
(log-warning (format "TR tests: waiting for ~a ~a" dir p)))
(force prm)))))) (force prm))))))
(make-test-suite dir tests))) (make-test-suite dir tests)))
@ -147,5 +149,6 @@
(define (go/text tests) (run-tests tests 'verbose)) (define (go/text tests) (run-tests tests 'verbose))
(provide go go/text just-one places start-workers (provide go go/text just-one places start-workers
verbose?
int-tests unit-tests compile-benchmarks int-tests unit-tests compile-benchmarks
optimization-tests missed-optimization-tests) optimization-tests missed-optimization-tests)

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

@ -2,11 +2,15 @@
(require racket/place typed-racket/optimizer/logging (require racket/place typed-racket/optimizer/logging
unstable/open-place compiler/compiler) unstable/open-place compiler/compiler)
(provide start-worker dr serialize-exn deserialize-exn s-exn? generate-log/place) (provide start-worker dr serialize-exn deserialize-exn s-exn? generate-log/place verbose?)
(define verbose? (make-parameter #f))
(struct s-exn (message) #:prefab) (struct s-exn (message) #:prefab)
(struct s-exn:fail s-exn () #:prefab) (struct s-exn:fail s-exn () #:prefab)
(struct s-exn:fail:syntax s-exn:fail (exprs) #:prefab) (struct s-exn:fail:syntax s-exn:fail (exprs) #:prefab)
(struct s-exn:fail:contract s-exn:fail () #:prefab) (struct s-exn:fail:contract s-exn:fail () #:prefab)
(define (serialize-exn e) (define (serialize-exn e)
(match e (match e
[(exn:fail:syntax msg _ exprs) [(exn:fail:syntax msg _ exprs)
@ -34,7 +38,9 @@
(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)))))) (and reg-box (set-box! reg-box (namespace-module-registry (current-namespace))))))
(define (start-worker get-ch name) (define (start-worker get-ch name)
(define verb (verbose?))
(open-place ch (open-place ch
(define reg (box #f)) (define reg (box #f))
(let loop () (let loop ()
@ -49,14 +55,13 @@
(loop)] (loop)]
[(vector p* res error?) [(vector p* res error?)
(define-values (path p b) (split-path p*)) (define-values (path p b) (split-path p*))
(parameterize ([read-accept-reader #t] (with-handlers ([exn? (λ (e) (place-channel-put res (serialize-exn e)))])
[current-load-relative-directory (parameterize ([read-accept-reader #t]
(path->complete-path path)] [current-load-relative-directory
[current-directory path] (path->complete-path path)]
[current-output-port (open-output-nowhere)] [current-directory path]
[error-display-handler (if error? void (error-display-handler))]) [current-output-port (open-output-nowhere)]
(with-handlers ([exn? (λ (e) [error-display-handler (if error? void (error-display-handler))])
(place-channel-put res (serialize-exn e)))])
(dr p reg) (dr p reg)
(place-channel-put res #t))) (place-channel-put res #t)))
(loop)])))) (loop)]))))

1
collects/tests/typed-racket/run.rkt
View File

@ -14,6 +14,7 @@
(current-namespace (make-base-namespace)) (current-namespace (make-base-namespace))
(command-line (command-line
#:once-each #:once-each
["-v" "verbose" (verbose? #t)]
["--unit" "run the unit tests" (unit? #t)] ["--unit" "run the unit tests" (unit? #t)]
["--int" "run the integration tests" (int? #t)] ["--int" "run the integration tests" (int? #t)]
["--opt" "run the optimization tests" (opt? #t)] ["--opt" "run the optimization tests" (opt? #t)]

2
collects/tests/typed-racket/send-places.rkt
View File

@ -3,7 +3,7 @@
(require "places.rkt") (require "places.rkt")
(require racket/place data/queue racket/async-channel) (require racket/place data/queue racket/async-channel)
(provide generate-log start-workers run-in-other-place places) (provide generate-log start-workers run-in-other-place places verbose?)
(define places (make-parameter (and (place-enabled?) (min 8 (processor-count))))) (define places (make-parameter (and (place-enabled?) (min 8 (processor-count)))))