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

Adapt the optimizer's test harness for the new logging strategy.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-05-31 18:02:48 -04:00
parent 7347da4919
commit a2afe2c285
1 changed files with 39 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
collects/tests/typed-scheme/optimizer/run.rkt
View File

@ -5,24 +5,46 @@
(provide optimization-tests missed-optimization-tests (provide optimization-tests missed-optimization-tests
test-opt test-missed-optimization) test-opt test-missed-optimization)
(define (generate-log name dir flags) (define (with-logging-to-port port level proc)
(let* ([logger (current-logger)]
[receiver (make-log-receiver logger level)]
[stop-key (gensym)]
[t (thread (lambda ()
(let loop ()
(let ([l (sync receiver)])
(unless (eq? (vector-ref l 2) stop-key)
(displayln (vector-ref l 1) ; actual message
port)
(loop))))))])
(begin0 (proc)
(log-message logger level "" stop-key) ; stop the receiver thread
(thread-wait t))))
;; TODO put in unstable somewhere
(define (generate-log name dir)
;; some tests require other tests, so some fiddling is required ;; some tests require other tests, so some fiddling is required
(parameterize ([current-load-relative-directory dir] (let* ([log-port (open-output-string)]
[current-command-line-arguments flags]) [out-string
(let ((log-string
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(parameterize ([current-namespace (make-base-empty-namespace)]) (with-logging-to-port log-port 'warning ; catch opt logs
(dynamic-require (build-path (current-load-relative-directory) (lambda ()
name) (parameterize
#f)))))) ([current-namespace (make-base-empty-namespace)]
[current-load-relative-directory dir])
(dynamic-require
(build-path (current-load-relative-directory) name)
#f))))))])
;; have the log as an sexp, since that's what the expected log is ;; have the log as an sexp, since that's what the expected log is
(with-input-from-string (string-append "(" log-string ")") (with-input-from-string
read)))) (string-append "(" (get-output-string log-port) ; join log and results
" " out-string ")")
read)))
;; we log optimizations and compare to an expected log to make sure that all ;; we log optimizations and compare to an expected log to make sure that all
;; the optimizations we expected did indeed happen ;; the optimizations we expected did indeed happen
(define (compare-logs name dir flags) (define (compare-logs name dir)
(test-suite "Log Comparison" (test-suite "Log Comparison"
(check-equal? (check-equal?
;; ugly, but otherwise rackunit spews the entire logs to ;; ugly, but otherwise rackunit spews the entire logs to
@ -30,7 +52,7 @@
#t #t
(equal? (equal?
;; actual log ;; actual log
(generate-log name dir flags) (generate-log name dir)
;; expected log ;; expected log
(with-input-from-file (build-path dir name) (with-input-from-file (build-path dir name)
(lambda () ; from the test file (lambda () ; from the test file
@ -43,9 +65,9 @@
;; these two return lists of tests to be run for that category of tests ;; these two return lists of tests to be run for that category of tests
(define (test-opt name) (define (test-opt name)
(list (compare-logs name tests-dir '#("--log-optimizations")))) (list (compare-logs name tests-dir)))
(define (test-missed-optimization name) (define (test-missed-optimization name)
(list (compare-logs name missed-optimizations-dir '#("--log-missed-optimizations")))) (list (compare-logs name missed-optimizations-dir)))
;; proc returns the list of tests to be run on each file ;; proc returns the list of tests to be run on each file
(define (mk-suite suite-name dir proc) (define (mk-suite suite-name dir proc)