suzanne.soy/typed-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.

original commit: e207f5c67df7d8ee1a6605d3ee62ba39787d16e0
This commit is contained in:
Sam Tobin-Hochstadt 2012-08-22 12:29:17 -04:00
parent cfe59c4980
commit 616b1c2fb6
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
(build-path path p)
(λ ()
(when (verbose?)
(log-warning (format "TR tests: waiting for ~a ~a" dir p)))
(force prm))))))
(make-test-suite dir tests)))
@ -147,5 +149,6 @@
(define (go/text tests) (run-tests tests 'verbose))
(provide go go/text just-one places start-workers
verbose?
int-tests unit-tests compile-benchmarks
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
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:fail s-exn () #:prefab)
(struct s-exn:fail:syntax s-exn:fail (exprs) #:prefab)
(struct s-exn:fail:contract s-exn:fail () #:prefab)
(define (serialize-exn e)
(match e
[(exn:fail:syntax msg _ exprs)
@ -34,7 +38,9 @@
(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 verb (verbose?))
(open-place ch
(define reg (box #f))
(let loop ()
@ -49,14 +55,13 @@
(loop)]
[(vector p* res error?)
(define-values (path p b) (split-path p*))
(parameterize ([read-accept-reader #t]
[current-load-relative-directory
(path->complete-path path)]
[current-directory path]
[current-output-port (open-output-nowhere)]
[error-display-handler (if error? void (error-display-handler))])
(with-handlers ([exn? (λ (e)
(place-channel-put res (serialize-exn e)))])
(with-handlers ([exn? (λ (e) (place-channel-put res (serialize-exn e)))])
(parameterize ([read-accept-reader #t]
[current-load-relative-directory
(path->complete-path path)]
[current-directory path]
[current-output-port (open-output-nowhere)]
[error-display-handler (if error? void (error-display-handler))])
(dr p reg)
(place-channel-put res #t)))
(loop)]))))

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

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