From 1f830cc2c6df8f9f652601850ea8da3ae7933f53 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 25 Aug 2010 10:39:13 -0500 Subject: [PATCH] added a timing test that compares Racket and Redex --- collects/redex/examples/r6rs/r6rs-tests.rkt | 147 ++++++++++++------ .../redex/examples/r6rs/racket-vs-redex.rkt | 14 ++ collects/redex/examples/r6rs/test.rkt | 4 +- 3 files changed, 115 insertions(+), 50 deletions(-) create mode 100644 collects/redex/examples/r6rs/racket-vs-redex.rkt diff --git a/collects/redex/examples/r6rs/r6rs-tests.rkt b/collects/redex/examples/r6rs/r6rs-tests.rkt index 6b0e710d88..c5ad5c215e 100644 --- a/collects/redex/examples/r6rs/r6rs-tests.rkt +++ b/collects/redex/examples/r6rs/r6rs-tests.rkt @@ -19,10 +19,11 @@ (make-r6test `(store () ,t) (list `(uncaught-exception (make-cond ,err))))) -(define (run-a-test test verbose?) - (unless verbose? - (printf ".") - (flush-output)) +(define (run-a-test test verbose? quiet?) + (unless quiet? + (unless verbose? + (printf ".") + (flush-output))) (let ([t (r6test-test test)] [expected (r6test-expected test)]) (set! test-count (+ test-count 1)) @@ -37,17 +38,17 @@ (let* ([results (evaluate reductions t (or verbose? 'dots) - (verify-p* t))] - [rewritten-results (remove-duplicates (map rewrite-actual results))]) - (for-each (verify-a* t) results) - (unless (set-same? expected rewritten-results equal?) - (set! failed-tests (+ failed-tests 1)) - (unless verbose? - (printf "\ntesting ~s ... " t)) - (printf "TEST FAILED!~nexpected:~a\nrewritten-received:~a\nreceived:~a\n\n" - (combine-in-lines expected) - (combine-in-lines rewritten-results) - (combine-in-lines results))))))) + (verify-p* t))]) + (let ([rewritten-results (remove-duplicates (map rewrite-actual results))]) + (for-each (verify-a* t) results) + (unless (set-same? expected rewritten-results equal?) + (set! failed-tests (+ failed-tests 1)) + (unless verbose? + (printf "\ntesting ~s ... " t)) + (printf "TEST FAILED!~nexpected:~a\nrewritten-received:~a\nreceived:~a\n\n" + (combine-in-lines expected) + (combine-in-lines rewritten-results) + (combine-in-lines results)))))))) (define p*-pattern (redex-match lang p*)) (define a*-pattern (redex-match lang a*)) @@ -681,7 +682,7 @@ (make-r6test/v '(car ((lambda (x) (cons x null)) 3)) 3) (make-r6test/v '((lambda (x) x) 3) 3) (make-r6test/v '((lambda (x y) (- x y)) 6 5) 1) - (make-r6test/e '((lambda () (+ x y z)) 3 4 5) + (make-r6test/e '((lambda () (+ 1 2 3)) 3 4 5) "arity mismatch") (make-r6test/v '((lambda (x y z) (+ x y z)) 3 4 5) 12) (make-r6test/v '((lambda (x y) (+ x y)) (+ 1 2) (+ 3 4)) 10) @@ -2018,40 +2019,88 @@ of digits with deconv-base (define the-tests (apply append (map cadr the-sets))) -(define (main [verbose? #f]) - (time - (let () - (define first? #t) - (define (run-a-set name set) - (unless first? - (if verbose? - (printf "\n\n") - (printf "\n"))) - (if verbose? - (printf "~a\n~a tests\n\n" - (apply string (build-list 60 (λ (i) #\-))) - name) - (begin (printf "~a tests " name) - (flush-output))) - (set! first? #f) - (for-each (λ (x) (run-a-test x verbose?)) set)) +(define (main #:verbose? [verbose? #f] #:compare-with-racket? [compare-with-racket? #f]) + (cond + [compare-with-racket? + (let () + + (struct test-exp (redex racket set)) + (define redex-exps '()) + (define r6-module-bodies '()) + (define missing 0) - (set! failed-tests 0) - (set! verified-terms 0) - (test-fns) - (for-each (λ (set) (apply run-a-set set)) the-sets) - (unless verbose? (printf "\n")) - - (if (= 0 failed-tests) - (printf "~a tests, all passed\n" test-count) - (fprintf (current-error-port) "~a tests, ~a tests failed\n" test-count failed-tests)) - (printf "verified that ~a terms are p*\n" verified-terms))) - (when verbose? - (collect-garbage) (collect-garbage) (collect-garbage) - (printf "mem ~s\n" (current-memory-use)) - (let ([v (make-vector 10)]) - (vector-set-performance-stats! v) - (printf "ht searches ~a\nslots searched ~a\n" (vector-ref v 8) (vector-ref v 9))))) + (define (no-bads? x) + (define bads '(begin0 make-cond)) + (let loop ([x x]) + (cond + [(pair? x) (and (loop (car x)) + (loop (cdr x)))] + [(memq x bads) #f] + [else #t]))) + + (for ([set (in-list the-sets)] + [i (in-naturals)]) + (for ([test (in-list (cadr set))] + [j (in-naturals)]) + (match (r6test-test test) + [(and `(store () ,exp) + (? no-bads?)) + (set! r6-module-bodies (cons exp r6-module-bodies)) + (set! redex-exps (cons (r6test-test test) redex-exps))] + [_ (set! missing (+ missing 1))]))) + + (printf "Running ~a tests (skipping ~a)\n" (length redex-exps) missing) + + (define ns (make-base-namespace)) + + ;; initialize the namespace by evaluating a dummy module + (parameterize ([current-namespace ns]) + (eval `(module r6rs-init r6rs (import (rnrs) (rnrs mutable-pairs (6)))))) + + (printf "Running in Racket's R6RS mode...\n") + (parameterize ([current-namespace ns]) + (time (eval `(module r6rs-big r6rs (import (rnrs) (rnrs mutable-pairs (6))) + (define null '()) + ,@r6-module-bodies)))) + + (printf "Running in the Redex model...\n") + (time (for ([test (in-list redex-exps)]) + (evaluate reductions test #f void + #:only-first-answer? #t))))] + [else + (time + (let () + (define first? #t) + (define (run-a-set name set) + (unless first? + (if verbose? + (printf "\n\n") + (printf "\n"))) + (if verbose? + (printf "~a\n~a tests\n\n" + (apply string (build-list 60 (λ (i) #\-))) + name) + (begin (printf "~a tests " name) + (flush-output))) + (set! first? #f) + (for-each (λ (x) (run-a-test x verbose? #f compare-with-racket?)) set)) + + (set! failed-tests 0) + (set! verified-terms 0) + (test-fns) + (for-each (λ (set) (apply run-a-set set)) the-sets) + (unless verbose? (printf "\n")) + + (if (= 0 failed-tests) + (printf "~a tests, all passed\n" test-count) + (fprintf (current-error-port) "~a tests, ~a tests failed\n" test-count failed-tests)) + (printf "verified that ~a terms are p*\n" verified-terms))) + (when verbose? + (collect-garbage) (collect-garbage) (collect-garbage) + (printf "mem ~s\n" (current-memory-use)) + (let ([v (make-vector 10)]) + (vector-set-performance-stats! v) + (printf "ht searches ~a\nslots searched ~a\n" (vector-ref v 8) (vector-ref v 9))))])) (provide main the-tests diff --git a/collects/redex/examples/r6rs/racket-vs-redex.rkt b/collects/redex/examples/r6rs/racket-vs-redex.rkt new file mode 100644 index 0000000000..5c9cdaf0a8 --- /dev/null +++ b/collects/redex/examples/r6rs/racket-vs-redex.rkt @@ -0,0 +1,14 @@ +#lang racket/base + +#| + +This runs (most of) the R6RS test suite in both Racket and Redex +and prints out timing results that compare the two of them. + +It skips a few tests that are testing internal states of the redex +r6rs model since they use features that aren't in r6rs itself. + +|# + +(require "r6rs-tests.rkt") +(main #:compare-with-racket? #t) diff --git a/collects/redex/examples/r6rs/test.rkt b/collects/redex/examples/r6rs/test.rkt index d4019281a3..5e1319102a 100644 --- a/collects/redex/examples/r6rs/test.rkt +++ b/collects/redex/examples/r6rs/test.rkt @@ -23,7 +23,7 @@ (loop (cdr thelist))))) (define-struct (exn:fail:duplicate exn:fail) ()) -(define (evaluate reductions t progress? [intermediate-state-test void]) +(define (evaluate reductions t progress? [intermediate-state-test void] #:only-first-answer? [only-first-answer? #f]) (let ([cache (make-hash)] [count 0] [results (make-hash)]) @@ -48,6 +48,8 @@ (cond [(null? nexts) (hash-set! results t #t)] + [only-first-answer? + (loop (car nexts) (+ depth 1))] [else (uniq t nexts) (for-each (λ (t) (loop t (+ depth 1)))