diff --git a/collects/tests/mzscheme/benchmarks/common/README.txt b/collects/tests/mzscheme/benchmarks/common/README.txt index 3f877ce075..bb4feb2c16 100644 --- a/collects/tests/mzscheme/benchmarks/common/README.txt +++ b/collects/tests/mzscheme/benchmarks/common/README.txt @@ -1,4 +1,22 @@ -Bechmarks obtained from +To run a benchmark: + mzscheme -qu auto.ss ... +where names an implementation as one of + mzscheme + mzscheme3m + bigloo + chicken + gambit + larceny +or a benchmark as one of + conform + cpstack + ctak + ... +Naming no implementation/benchmark causes all of them to be run. +The output is series of lines of the form + [ ( ) ] + +The bechmarks were obtained from http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/code/bench/gabriel/ http://www.ccs.neu.edu/home/will/GC/sourcecode.html diff --git a/collects/tests/mzscheme/benchmarks/common/auto.ss b/collects/tests/mzscheme/benchmarks/common/auto.ss new file mode 100644 index 0000000000..6fc12a023e --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/auto.ss @@ -0,0 +1,204 @@ +#!/bin/sh +#| +exec mzscheme -qu "$0" ${1+"$@"} +|# + +(module auto mzscheme + (require (lib "process.ss") + (lib "cmdline.ss")) + + (define (bytes->number b) + (string->number (bytes->string/latin-1 b))) + + (define ((run-mk script) bm) + (when (file-exists? (symbol->string bm)) + (delete-file (symbol->string bm))) + (parameterize ([current-command-line-arguments (vector (symbol->string bm))]) + (load script))) + + (define (mk-mzscheme bm) + ;; To get compilation time: + (parameterize ([current-namespace (make-namespace)]) + (load (format "~a.ss" bm)))) + + (define (mk-mzc bm) + (system (format "mzc ~a.ss" bm))) + + (define (run-exe bm) + (system (symbol->string bm))) + + (define (run-exe/time bm) + (system (format "time ~a" bm))) + + (define (run-gambit-exe bm) + (system (format "~a -:d-" bm))) + + (define (extract-times bm str) + str) + + (define (extract-gambit-times bm str) + (let ([m (regexp-match (byte-regexp + (bytes-append + #"([0-9]+) ms real.*[^0-9]" + #"([0-9]+) ms cpu.*" + #"(?:no collections|collections? accounting for ([0-9]+) ms.*)")) + str)]) + (map bytes->number + (list (caddr m) + (cadr m) + (or (cadddr m) #"0"))))) + + (define (extract-mzscheme-times bm str) + (let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)]) + (map bytes->number (cdr m)))) + + (define (extract-chicken-times bm str) + (let ([m (regexp-match #rx#"([0-9.]+) seconds.*[^0-9.]([0-9.]+) seconds" str)]) + (list (* 1000 (string->number (format "#e~a" (cadr m)))) + #f + (* 1000 (string->number (format "#e~a" (caddr m))))))) + + (define (extract-time-times bm str) + (let ([m (regexp-match #rx#"real[ \t]+([0-9m.]+)s.*user[ \t]+([0-9m.]+)s.sys[ \t]+([0-9m.]+)s." str)] + [ms->milliseconds (lambda (s) + (let ([m (regexp-match "([0-9]+)m([0-9.]+)" s)]) + (+ (* 60000 (string->number (format "~a" (cadr m)))) + (* 1000 (string->number (format "#e~a" (caddr m)))))))]) + (let ([real (ms->milliseconds (cadr m))] + [user (ms->milliseconds (caddr m))] + [sys (ms->milliseconds (cadddr m))]) + (list (+ user sys) real #f)))) + + (define-struct impl (name make run extract-result skips)) + + (define impls + (list + (make-impl 'mzscheme + mk-mzscheme + (lambda (bm) + (system (format "mzscheme -qu ~a.ss" bm))) + extract-mzscheme-times + '()) + (make-impl 'mzscheme3m + mk-mzscheme + (lambda (bm) + (system (format "mzscheme3m -qu ~a.ss" bm))) + extract-mzscheme-times + '()) + (make-impl 'mzc + mk-mzc + (lambda (bm) + (system (format "mzscheme -mvqe '(load-extension \"~a.dylib\")'" bm))) + extract-mzscheme-times + '()) + (make-impl 'mzscheme-no-jit + mk-mzscheme + (lambda (bm) + (system (format "mzscheme -jqu ~a.ss" bm))) + extract-mzscheme-times + '()) + (make-impl 'chicken + (run-mk "mk-chicken.ss") + run-exe + extract-chicken-times + '(nucleic2)) + (make-impl 'bigloo + (run-mk "mk-bigloo.ss") + run-exe/time + extract-time-times + '(cpstack ctak puzzle triangle)) + (make-impl 'gambit + (run-mk "mk-gambit.ss") + run-gambit-exe + extract-gambit-times + '(nucleic2)))) + + (define benchmarks + '(conform + cpstack + ctak + deriv + dderiv + destruct + div + dynamic + earley + fft + nboyer + nfa + nucleic2 + puzzle + sboyer + sort1 + tak + takl + takr + triangle)) + + (define num-iterations 3) + + (define (run-benchmark impl bm) + (let ([i (ormap (lambda (i) + (and (eq? impl (impl-name i)) + i)) + impls)]) + (if (memq bm (impl-skips i)) + (printf "[~a ~a ~s 0]\n" impl bm '(#f #f #f)) + (let ([start (current-inexact-milliseconds)]) + ((impl-make i) bm) + (let ([end (current-inexact-milliseconds)]) + (let loop ([n num-iterations]) + (unless (zero? n) + (let ([out (open-output-bytes)] + [in (open-input-bytes #"0\n")]) + (unless (parameterize ([current-output-port out] + [current-error-port out] + [current-input-port in]) + ((impl-run i) bm)) + (error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm)) + (printf "[~a ~a ~s ~a]\n" + impl + bm + ((impl-extract-result i) bm (get-output-bytes out)) + (inexact->exact (round (- end start))))) + (loop (sub1 n))))))))) + + (define run-benchmarks #f) + (define run-implementations #f) + + (define args + (command-line + "auto" + (current-command-line-arguments) + (once-each + [("-n" "--iters") n "set number of run iterations" + (let ([v (string->number n)]) + (unless (and (number? v) + (exact? v) + (positive? v)) + (error 'auto "bad interation count: ~a" n)) + (set! num-iterations v))]) + (args impl-or-benchmark impl-or-benchmark))) + + (for-each (lambda (arg) + (let ([s (string->symbol arg)]) + (cond + [(memq s (map impl-name impls)) + (set! run-implementations + (append (or run-implementations null) + (list s)))] + [(memq s benchmarks) + (set! run-benchmarks + (append (or run-benchmarks null) + (list s)))] + [else + (error 'auto "mysterious argument: ~a" arg)]))) + args) + + (map (lambda (impl) + (map (lambda (bm) + (run-benchmark impl bm)) + (or run-benchmarks + benchmarks))) + (or run-implementations + (map impl-name impls)))) diff --git a/collects/tests/mzscheme/benchmarks/common/dderiv.ss b/collects/tests/mzscheme/benchmarks/common/dderiv.ss index 0710bdbba1..4913ebec5f 100644 --- a/collects/tests/mzscheme/benchmarks/common/dderiv.ss +++ b/collects/tests/mzscheme/benchmarks/common/dderiv.ss @@ -1,99 +1,2 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; File: dderiv.sch -; Description: DDERIV benchmark from the Gabriel tests -; Author: Vaughan Pratt -; Created: 8-Apr-85 -; Modified: 10-Apr-85 14:53:29 (Bob Shaw) -; 23-Jul-87 (Will Clinger) -; 9-Feb-88 (Will Clinger) -; Language: Scheme (but see note below) -; Status: Public Domain -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; Note: This benchmark uses property lists. The procedures that must -; be supplied are get and put, where (put x y z) is equivalent to Common -; Lisp's (setf (get x y) z). - -;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt. - -;;; This benchmark is a variant of the simple symbolic derivative program -;;; (DERIV). The main change is that it is `table-driven.' Instead of using a -;;; large COND that branches on the CAR of the expression, this program finds -;;; the code that will take the derivative on the property list of the atom in -;;; the CAR position. So, when the expression is (+ . ), the code -;;; stored under the atom '+ with indicator DERIV will take and -;;; return the derivative for '+. The way that MacLisp does this is with the -;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an -;;; atomic name in that it expects an argument list and the compiler compiles -;;; code, but the name of the function with that code is stored on the -;;; property list of FOO under the indicator BAR, in this case. You may have -;;; to do something like: - -;;; :property keyword is not Common Lisp. - -; Returns the wrong answer for quotients. -; Fortunately these aren't used in the benchmark. - -(module dderiv mzscheme - -(define pg-alist '()) -(define (put sym d what) - (set! pg-alist (cons (cons sym what) pg-alist))) -(define (get sym d) - (cdr (assq sym pg-alist))) - -(define (dderiv-aux a) - (list '/ (dderiv a) a)) - -(define (+dderiv a) - (cons '+ (map dderiv a))) - -(put '+ 'dderiv +dderiv) ; install procedure on the property list - -(define (-dderiv a) - (cons '- (map dderiv a))) - -(put '- 'dderiv -dderiv) ; install procedure on the property list - -(define (*dderiv a) - (list '* (cons '* a) - (cons '+ (map dderiv-aux a)))) - -(put '* 'dderiv *dderiv) ; install procedure on the property list - -(define (/dderiv a) - (list '- - (list '/ - (dderiv (car a)) - (cadr a)) - (list '/ - (car a) - (list '* - (cadr a) - (cadr a) - (dderiv (cadr a)))))) - -(put '/ 'dderiv /dderiv) ; install procedure on the property list - -(define (dderiv a) - (cond - ((not (pair? a)) - (cond ((eq? a 'x) 1) (else 0))) - (else (let ((dderiv (get (car a) 'dderiv))) - (cond (dderiv (dderiv (cdr a))) - (else 'error)))))) - -(define (run) - (do ((i 0 (+ i 1))) - ((= i 10000)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) - (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) - -;;; call: (run) - -(time (run)) -) +(module dderiv "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/div.sch b/collects/tests/mzscheme/benchmarks/common/div.sch new file mode 100644 index 0000000000..c9e8a3650d --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/div.sch @@ -0,0 +1,51 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: div.sch +; Description: DIV benchmarks +; Author: Richard Gabriel +; Created: 8-Apr-85 +; Modified: 19-Jul-85 18:28:01 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. +;;; This file contains a recursive as well as an iterative test. + +(define (create-n n) + (do ((n n (- n 1)) + (a '() (cons '() a))) + ((= n 0) a))) + +(define *ll* (create-n 200)) + +(define (iterative-div2 l) + (do ((l l (cddr l)) + (a '() (cons (car l) a))) + ((null? l) a))) + +(define (recursive-div2 l) + (cond ((null? l) '()) + (else (cons (car l) (recursive-div2 (cddr l)))))) + +(define (test-1 l) + (do ((i 3000 (- i 1))) + ((= i 0)) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l))) + +(define (test-2 l) + (do ((i 3000 (- i 1))) + ((= i 0)) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l))) + +;;; for the iterative test call: (test-1 *ll*) +;;; for the recursive test call: (test-2 *ll*) + +(time (cons (test-1 *ll*) + (test-2 *ll*))) diff --git a/collects/tests/mzscheme/benchmarks/common/div.ss b/collects/tests/mzscheme/benchmarks/common/div.ss index 753fa0bcd5..b87d55a098 100644 --- a/collects/tests/mzscheme/benchmarks/common/div.ss +++ b/collects/tests/mzscheme/benchmarks/common/div.ss @@ -1,54 +1,2 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; File: div.sch -; Description: DIV benchmarks -; Author: Richard Gabriel -; Created: 8-Apr-85 -; Modified: 19-Jul-85 18:28:01 (Bob Shaw) -; 23-Jul-87 (Will Clinger) -; Language: Scheme -; Status: Public Domain -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. -;;; This file contains a recursive as well as an iterative test. -(module div mzscheme -(define (create-n n) - (do ((n n (- n 1)) - (a '() (cons '() a))) - ((= n 0) a))) - -(define *ll* (create-n 200)) - -(define (iterative-div2 l) - (do ((l l (cddr l)) - (a '() (cons (car l) a))) - ((null? l) a))) - -(define (recursive-div2 l) - (cond ((null? l) '()) - (else (cons (car l) (recursive-div2 (cddr l)))))) - -(define (test-1 l) - (do ((i 3000 (- i 1))) - ((= i 0)) - (iterative-div2 l) - (iterative-div2 l) - (iterative-div2 l) - (iterative-div2 l))) - -(define (test-2 l) - (do ((i 3000 (- i 1))) - ((= i 0)) - (recursive-div2 l) - (recursive-div2 l) - (recursive-div2 l) - (recursive-div2 l))) - -;;; for the iterative test call: (test-1 *ll*) -;;; for the recursive test call: (test-2 *ll*) - -(time (test-1 *ll*)) -(time (test-2 *ll*)) -) - +(module div "wrap.ss") \ No newline at end of file diff --git a/collects/tests/mzscheme/benchmarks/common/gambit-prelude.sch b/collects/tests/mzscheme/benchmarks/common/gambit-prelude.sch index cb6f220a8f..26f69d687a 100644 --- a/collects/tests/mzscheme/benchmarks/common/gambit-prelude.sch +++ b/collects/tests/mzscheme/benchmarks/common/gambit-prelude.sch @@ -4,4 +4,4 @@ (extended-bindings) (safe) (interrupts-enabled) -) \ No newline at end of file +) diff --git a/collects/tests/mzscheme/benchmarks/common/input.txt b/collects/tests/mzscheme/benchmarks/common/input.txt new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/input.txt @@ -0,0 +1 @@ +1 diff --git a/collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss b/collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss index 0105f925d0..e5b2e22d45 100644 --- a/collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss +++ b/collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss @@ -11,7 +11,7 @@ (newline)) 'truncate/replace) -(when (system (format "bigloo -o ~a -O6 ~a.scm" +(when (system (format "bigloo -w -o ~a -O6 ~a.scm" name name)) (delete-file (format "~a.scm" name)) (delete-file (format "~a.o" name))) diff --git a/collects/tests/mzscheme/benchmarks/common/mk-chicken.ss b/collects/tests/mzscheme/benchmarks/common/mk-chicken.ss index 91bbaea996..f3fb977c6a 100644 --- a/collects/tests/mzscheme/benchmarks/common/mk-chicken.ss +++ b/collects/tests/mzscheme/benchmarks/common/mk-chicken.ss @@ -2,5 +2,5 @@ (define name (vector-ref (current-command-line-arguments) 0)) -(system (format "csc -no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift ~a.sch" +(system (format "csc -no-warnings -no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift ~a.sch" name)) diff --git a/collects/tests/mzscheme/benchmarks/common/sort1.sch b/collects/tests/mzscheme/benchmarks/common/sort1.sch index b7cea29767..f4e7fd93eb 100644 --- a/collects/tests/mzscheme/benchmarks/common/sort1.sch +++ b/collects/tests/mzscheme/benchmarks/common/sort1.sch @@ -128,6 +128,10 @@ sort)) +(define *rand* 21) +(define (random m) + (set! *rand* (remainder (* *rand* 17) m)) + *rand*) (define (rgen n m) (let loop ((n n) (l '())) diff --git a/collects/tests/mzscheme/benchmarks/common/tabulate.ss b/collects/tests/mzscheme/benchmarks/common/tabulate.ss new file mode 100644 index 0000000000..a0599ccebc --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/tabulate.ss @@ -0,0 +1,91 @@ + +(module tabulate mzscheme + (require (lib "list.ss") + (lib "xml.ss" "xml")) + + (define bm-table (make-hash-table)) + (define impls (make-hash-table)) + + (let loop () + (let ([l (read)]) + (unless (eof-object? l) + (hash-table-put! impls (car l) #t) + (let ([t (hash-table-get bm-table (cadr l) + (lambda () + (let ([t (make-hash-table)]) + (hash-table-put! bm-table (cadr l) t) + t)))]) + (hash-table-put! t (car l) + (cons (cddr l) + (hash-table-get t (car l) null)))) + (loop)))) + + (define bm-runs (hash-table-map bm-table cons)) + + (define (average sel l) + (if (andmap sel l) + (round (/ (apply + (map sel l)) (length l))) + (if (ormap sel l) + (error 'tabulate "inconsistent average info") + #f))) + + (define average-runs + (map (lambda (bm-run) + (cons + (car bm-run) + (map (lambda (runs) + (list (car runs) + (list (average caar (cdr runs)) + (average cadar (cdr runs)) + (average caddar (cdr runs))) + (cadadr runs))) + (hash-table-map (cdr bm-run) cons)))) + bm-runs)) + + (define (symbolstring a) + (symbol->string b))) + + (define sorted-runs + (sort average-runs (lambda (a b) + (symbolstring r) + (if (integer? r) + (number->string r) + (let ([s (format "~a00" (exact->inexact r))]) + (car (regexp-match #rx"^[0-9]*[.].." s))))) + + (empty-tag-shorthand html-empty-tags) + (write-xml/content + (xexpr->xml + `(html + (head (title "Benchmark Results")) + (body + (table + (tr (td nbsp) + (td nbsp) + ,@(map (lambda (impl) + `(td (b ,(symbol->string impl)) nbsp)) + sorted-impls)) + ,@(map (lambda (bm-run) + (let ([fastest (apply min (map (lambda (run) + (or (caadr run) 1000000000)) + (cdr bm-run)))]) + `(tr (td (a ((href ,(format "~a.sch" (car bm-run)))) + ,(symbol->string (car bm-run)))) + (td ((align "right")) + nbsp + ,(format "~a ms" fastest) nbsp nbsp nbsp) + ,@(map (lambda (impl) + (let* ([a (assq impl (cdr bm-run))] + [n (and a (caadr a))]) + `(td ,(if n + (ratio->string (/ n fastest)) + "-")))) + sorted-impls)))) + sorted-runs)))))) + (newline)) diff --git a/collects/tests/mzscheme/benchmarks/common/tak.sch b/collects/tests/mzscheme/benchmarks/common/tak.sch index 6519c5279e..38179fca9a 100644 --- a/collects/tests/mzscheme/benchmarks/common/tak.sch +++ b/collects/tests/mzscheme/benchmarks/common/tak.sch @@ -20,6 +20,4 @@ ;;; call: (tak 18 12 6) -(time (tak 18 12 2)) - - +(time (tak 18 12 (if (with-input-from-file "input.txt" read) 2 0))) diff --git a/collects/tests/mzscheme/benchmarks/common/takr.sch b/collects/tests/mzscheme/benchmarks/common/takr.sch index da55b81256..3d3dcd51db 100644 --- a/collects/tests/mzscheme/benchmarks/common/takr.sch +++ b/collects/tests/mzscheme/benchmarks/common/takr.sch @@ -517,5 +517,5 @@ ;;; call: (tak0 18 12 6) -(time (tak0 18 12 2)) +(time (tak0 18 12 (if (with-input-from-file "input.txt" read) 2 0))) diff --git a/collects/tests/mzscheme/benchmarks/common/triangle.sch b/collects/tests/mzscheme/benchmarks/common/triangle.sch index 53d54de1f3..2523fda56b 100644 --- a/collects/tests/mzscheme/benchmarks/common/triangle.sch +++ b/collects/tests/mzscheme/benchmarks/common/triangle.sch @@ -81,4 +81,4 @@ 'done (begin (gogogo 22) - (loop (sub1 n)))))) + (loop (- n 1))))))