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

update benchmark harness

Browse Source 
svn: r17840
This commit is contained in:
Matthew Flatt 2010-01-26 20:17:44 +00:00
parent 3068ae4bd5
commit f07c19b268
15 changed files with 564 additions and 490 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
collects/tests/mzscheme/benchmarks/common/auto.ss
View File

@ -3,6 +3,8 @@
exec mzscheme -qu "$0" ${1+"$@"} exec mzscheme -qu "$0" ${1+"$@"}
|# |#
;; See "tabulate.ss" for information on the output format
(module auto scheme/base (module auto scheme/base
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
mzlib/process mzlib/process
@ -11,6 +13,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
mzlib/compile mzlib/compile
mzlib/inflate mzlib/inflate
mzlib/date mzlib/date
mzlib/port
dynext/file dynext/file
syntax/toplevel syntax/toplevel
scheme/runtime-path) scheme/runtime-path)
@ -74,18 +77,24 @@ exec mzscheme -qu "$0" ${1+"$@"}
(define (clean-up-zo bm) (define (clean-up-zo bm)
(delete-file (build-path "compiled" (format "~a.zo" bm)))) (delete-file (build-path "compiled" (format "~a.zo" bm))))
(define (setup-larceny bm)
(setup-sps bm "(larceny benchmarking)"))
(define (mk-larceny bm) (define (mk-larceny bm)
(parameterize ([current-input-port (parameterize ([current-input-port
(open-input-string (open-input-string
(format (string-append (format (string-append
"(compiler-switches 'fast-safe)\n" "(import (larceny compiler))\n"
"(compile-file \"~a.sch\")\n") "(compile-library \"~a.sls\")\n")
bm))] bm))]
[current-output-port (open-output-bytes)]) [current-output-port (open-output-bytes)])
(system "larceny"))) (system "larceny -err5rs")
;; Make sure compiled version is used:
(delete-file (format "~a.sls" bm))))
(define (clean-up-fasl bm) (define (clean-up-fasl bm)
(delete-file (format "~a.fasl" bm))) (clean-up-sps bm)
(delete-file (format "~a.slfasl" bm)))
(define (mk-mzc bm) (define (mk-mzc bm)
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
@ -104,16 +113,45 @@ exec mzscheme -qu "$0" ${1+"$@"}
(system (format "gsi -:d-,m10000 ~a.o1" bm))) (system (format "gsi -:d-,m10000 ~a.o1" bm)))
(define (run-larceny bm) (define (run-larceny bm)
(parameterize ([current-input-port (open-input-string (system "larceny -r6rs -program prog.sps -path ."))
(format "(load \"~a.fasl\")\n"
bm))]) (define (setup-sps bm lib)
(system "larceny"))) (with-output-to-file "prog.sps"
#:exists 'truncate
(lambda ()
(printf "(import (~a))\n" bm)
(printf "(bm-!-go)\n")))
(with-output-to-file (format "~a.sls" bm)
#:exists 'truncate
(lambda ()
(printf "(library (~a)\n" bm)
(printf " (export bm-!-go)\n")
(printf " (import (rnrs) (rnrs mutable-pairs) (rnrs mutable-strings) (rnrs r5rs) ~a)\n" lib)
(printf " (define (bm-!-go) 'ok)\n")
(call-with-input-file (format "~a.sch" bm)
(lambda (in)
(copy-port in (current-output-port))))
(printf ")\n"))))
(define (clean-up-sps bm)
(delete-file "prog.sps")
(let ([f (format "~a.sls" bm)])
(when (file-exists? f)
(delete-file f))))
(define (setup-ikarus bm)
(setup-sps bm "(ikarus)")
(system "rm -rf ~/.ikarus"))
(define (mk-ikarus bm) (define (mk-ikarus bm)
(void)) (system "ikarus --compile-dependencies prog.sps"))
(define (run-ikarus bm) (define (run-ikarus bm)
(system (format "ikarus ~a.sch < /dev/null" bm))) (system "ikarus --r6rs-script prog.sps"))
(define (clean-up-ikarus bm)
(clean-up-sps bm)
(system "rm -rf ~/.ikarus"))
(define (extract-times bm str) (define (extract-times bm str)
str) str)
@ -134,6 +172,15 @@ exec mzscheme -qu "$0" ${1+"$@"}
(let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)]) (let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)])
(map bytes->number (cdr m)))) (map bytes->number (cdr m))))
(define (extract-bigloo-times bm str)
(let ([m (regexp-match #rx#"real: ([0-9]+) sys: ([0-9]+) user: ([0-9]+)" str)]
;; `time' result is 10s of milliseconds? OS ticks, maybe?
[msec/tick 10])
(list (* msec/tick (+ (bytes->number (caddr m))
(bytes->number (cadddr m))))
(* msec/tick (bytes->number (cadr m)))
0)))
(define (extract-larceny-times bm str) (define (extract-larceny-times bm str)
(let ([m (regexp-match #rx#"Elapsed time...: ([0-9]+) ms.*Elapsed GC time: ([0-9]+) ms" str)]) (let ([m (regexp-match #rx#"Elapsed time...: ([0-9]+) ms.*Elapsed GC time: ([0-9]+) ms" str)])
(list (bytes->number (cadr m)) (list (bytes->number (cadr m))
@ -169,7 +216,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
;; Table of implementatons and benchmarks ------------------------------ ;; Table of implementatons and benchmarks ------------------------------
(define-struct impl (name make run extract-result clean-up skips)) (define-struct impl (name setup make run extract-result clean-up skips))
(define mutable-pair-progs '(conform (define mutable-pair-progs '(conform
destruct destruct
@ -183,6 +230,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
(define impls (define impls
(list (list
(make-impl 'mzscheme (make-impl 'mzscheme
void
mk-mzscheme mk-mzscheme
(lambda (bm) (lambda (bm)
(system (format "mzscheme -u ~a.ss" bm))) (system (format "mzscheme -u ~a.ss" bm)))
@ -190,6 +238,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
clean-up-nothing clean-up-nothing
mutable-pair-progs) mutable-pair-progs)
(make-impl 'mz-old (make-impl 'mz-old
void
mk-mzscheme mk-mzscheme
(lambda (bm) (lambda (bm)
(system (format "mz-old -u ~a.ss" bm))) (system (format "mz-old -u ~a.ss" bm)))
@ -197,6 +246,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
clean-up-nothing clean-up-nothing
mutable-pair-progs) mutable-pair-progs)
(make-impl 'mzschemecgc (make-impl 'mzschemecgc
void
mk-mzscheme mk-mzscheme
(lambda (bm) (lambda (bm)
(system (format "mzschemecgc -u ~a.ss" bm))) (system (format "mzschemecgc -u ~a.ss" bm)))
@ -204,6 +254,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
clean-up-nothing clean-up-nothing
mutable-pair-progs) mutable-pair-progs)
(make-impl 'mzscheme3m (make-impl 'mzscheme3m
void
mk-mzscheme mk-mzscheme
(lambda (bm) (lambda (bm)
(system (format "mzscheme3m -u ~a.ss" bm))) (system (format "mzscheme3m -u ~a.ss" bm)))
@ -211,6 +262,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
clean-up-nothing clean-up-nothing
mutable-pair-progs) mutable-pair-progs)
(make-impl 'plt-r5rs (make-impl 'plt-r5rs
void
mk-plt-r5rs mk-plt-r5rs
(lambda (bm) (lambda (bm)
(system (format "plt-r5rs ~a.scm" bm))) (system (format "plt-r5rs ~a.scm" bm)))
@ -218,6 +270,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
clean-up-plt-r5rs clean-up-plt-r5rs
null) null)
(make-impl 'mzc (make-impl 'mzc
void
mk-mzc mk-mzc
(lambda (bm) (lambda (bm)
(system (format "mzscheme -mvqee '(load-extension \"~a\")' '(require ~a)'" (system (format "mzscheme -mvqee '(load-extension \"~a\")' '(require ~a)'"
@ -228,6 +281,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
(append '(takr takr2) (append '(takr takr2)
mutable-pair-progs)) mutable-pair-progs))
(make-impl 'mzscheme-j (make-impl 'mzscheme-j
void
mk-mzscheme mk-mzscheme
(lambda (bm) (lambda (bm)
(system (format "mzscheme -jqu ~a.ss" bm))) (system (format "mzscheme -jqu ~a.ss" bm)))
@ -235,6 +289,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
clean-up-nothing clean-up-nothing
mutable-pair-progs) mutable-pair-progs)
(make-impl 'mzschemecgc-j (make-impl 'mzschemecgc-j
void
mk-mzscheme mk-mzscheme
(lambda (bm) (lambda (bm)
(system (format "mzschemecgc -jqu ~a.ss" bm))) (system (format "mzschemecgc -jqu ~a.ss" bm)))
@ -242,6 +297,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
clean-up-nothing clean-up-nothing
mutable-pair-progs) mutable-pair-progs)
(make-impl 'mzschemecgc-tl (make-impl 'mzschemecgc-tl
void
mk-mzscheme-tl mk-mzscheme-tl
(lambda (bm) (lambda (bm)
(system (format "mzschemecgc -qr compiled/~a.zo" bm))) (system (format "mzschemecgc -qr compiled/~a.zo" bm)))
@ -250,37 +306,42 @@ exec mzscheme -qu "$0" ${1+"$@"}
(append '(nucleic2) (append '(nucleic2)
mutable-pair-progs)) mutable-pair-progs))
(make-impl 'chicken (make-impl 'chicken
void
(run-mk "mk-chicken.ss") (run-mk "mk-chicken.ss")
run-exe run-exe
extract-chicken-times extract-chicken-times
clean-up-bin clean-up-bin
'(nucleic2)) '(scheme2 takr2))
(make-impl 'bigloo (make-impl 'bigloo
void
(run-mk "mk-bigloo.ss") (run-mk "mk-bigloo.ss")
run-exe/time run-exe
extract-time-times extract-bigloo-times
clean-up-bin clean-up-bin
'(cpstack maze maze2 puzzle triangle)) '(cpstack takr2))
(make-impl 'gambit (make-impl 'gambit
void
(run-mk "mk-gambit.ss") (run-mk "mk-gambit.ss")
run-gambit-exe run-gambit-exe
extract-gambit-times extract-gambit-times
clean-up-o1 clean-up-o1
'(nucleic2)) '(nucleic2))
(make-impl 'larceny (make-impl 'larceny
setup-larceny
mk-larceny mk-larceny
run-larceny run-larceny
extract-larceny-times extract-larceny-times
clean-up-fasl clean-up-fasl
'()) '())
(make-impl 'ikarus (make-impl 'ikarus
setup-ikarus
mk-ikarus mk-ikarus
run-ikarus run-ikarus
extract-ikarus-times extract-ikarus-times
clean-up-nothing clean-up-ikarus
'(fft)))) '(takr))))
(define obsolte-impls '(mzscheme mzscheme-j mzschemecgc-tl mzc mz-old)) (define obsolte-impls '(mzscheme3m mzschemecgc mzscheme-j mzschemecgc-j mzschemecgc-tl mzc mz-old))
(define benchmarks (define benchmarks
'(conform '(conform
@ -303,6 +364,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
nboyer nboyer
nestedloop nestedloop
nfa nfa
nothing
nqueens nqueens
nucleic2 nucleic2
paraffins paraffins
@ -329,6 +391,8 @@ exec mzscheme -qu "$0" ${1+"$@"}
impls)]) impls)])
(if (memq bm (impl-skips i)) (if (memq bm (impl-skips i))
(rprintf "[~a ~a ~s #f]\n" impl bm '(#f #f #f)) (rprintf "[~a ~a ~s #f]\n" impl bm '(#f #f #f))
(begin
((impl-setup i) bm)
(let ([start (current-inexact-milliseconds)]) (let ([start (current-inexact-milliseconds)])
((impl-make i) bm) ((impl-make i) bm)
(let ([end (current-inexact-milliseconds)]) (let ([end (current-inexact-milliseconds)])
@ -345,7 +409,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
((impl-extract-result i) bm (get-output-bytes out)) ((impl-extract-result i) bm (get-output-bytes out))
(inexact->exact (round (- end start))))) (inexact->exact (round (- end start)))))
(loop (sub1 n))))) (loop (sub1 n)))))
((impl-clean-up i) bm))) ((impl-clean-up i) bm))))
(flush-output))) (flush-output)))
;; Extract command-line arguments -------------------- ;; Extract command-line arguments --------------------

11
collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch
View File

@ -1,9 +1,16 @@
(define orig-time time)
(define-macro (time expr) (define-macro (time expr)
`(time-it (lambda () ,expr))) `(time-it (lambda () ,expr)))
(define (time-it thunk) (define (time-it thunk)
(thunk)) (multiple-value-bind (res rtime stime utime)
(orig-time thunk)
(print "real: " rtime " sys: " stime " user: " utime)
res))
(define (error . x) #f) (define (error . x) #f)
(define bitwise-or bit-or)
(define bitwise-and bit-and)
(define bitwise-not bit-not)

16
collects/tests/mzscheme/benchmarks/common/dderiv.sch
View File

@ -46,19 +46,13 @@
(define (f+dderiv a) (define (f+dderiv a)
(cons '+ (map dderiv a))) (cons '+ (map dderiv a)))
(put '+ 'dderiv f+dderiv) ; install procedure on the property list
(define (f-dderiv a) (define (f-dderiv a)
(cons '- (map dderiv a))) (cons '- (map dderiv a)))
(put '- 'dderiv f-dderiv) ; install procedure on the property list
(define (*dderiv a) (define (*dderiv a)
(list '* (cons '* a) (list '* (cons '* a)
(cons '+ (map dderiv-aux a)))) (cons '+ (map dderiv-aux a))))
(put '* 'dderiv *dderiv) ; install procedure on the property list
(define (/dderiv a) (define (/dderiv a)
(list '- (list '-
(list '/ (list '/
@ -71,8 +65,6 @@
(cadr a) (cadr a)
(dderiv (cadr a)))))) (dderiv (cadr a))))))
(put '/ 'dderiv /dderiv) ; install procedure on the property list
(define (dderiv a) (define (dderiv a)
(cond (cond
((not (pair? a)) ((not (pair? a))
@ -90,6 +82,14 @@
(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))))
(put '+ 'dderiv f+dderiv) ; install procedure on the property list
(put '- 'dderiv f-dderiv) ; install procedure on the property list
(put '* 'dderiv *dderiv) ; install procedure on the property list
(put '/ 'dderiv /dderiv) ; install procedure on the property list
;;; call: (run) ;;; call: (run)
(time (run)) (time (run))

52
collects/tests/mzscheme/benchmarks/common/index-template.html
View File

@ -4,45 +4,52 @@
<H1>About the Benchmarks</H1> <H1>About the Benchmarks</H1>
<p>The pages linked below show some benchmark results on a collection of fairly standard <p>The <a href="Benchmarks.html">benchmark page</a> shows some benchmark results on a collection of fairly standard
(mostly Gabriel) Scheme benchmarks.</p> (mostly Gabriel) Scheme benchmarks.</p>
<p>Tables show relative performance, with the actual time for the fastest <p>Tables show relative performance, with the actual time for the fastest
run shown on the left. So, by default, <font color=forestgreen><b>1</b></font> run shown on the left. So, by default, <font color=forestgreen><b>1</b></font>
is the fastest, but select any implementation to normalize the table with is the fastest, but select any implementation to normalize the table with
respect to that implementation's speed. A <tt>--</tt> appears when a benchmark respect to that implementation's speed. A <tt>--</tt> appears when a benchmark
didn't run in an implementation (and you should assume a benchmark problem, didn't run in an implementation for some reason (possibly not a good one).</p>
rather than an implementation problem).</p>
<p><font color="gray" size="-1">Small gray numbers are (relative) compile times.</font></p> <p><font color="gray" size="-1">Small gray numbers are (relative)
compile times, where the compile time for the <tt>nothing</tt>
benchmark is subtracted from every other benchmark's compile
time.</font></p>
<p>Run times are averaged over three runs. All reported times are CPU time (system plus user). <p>Run times are averaged over three runs. All reported times are CPU time (system plus user).
Where available, the times are based on the output of the implementation's <tt>time</tt> The times are based on the output of the implementation's <tt>time</tt>
syntactic form, otherwise <tt>/usr/bin/time</tt> is used.</p> syntactic form for function.</p>
<p>Compiler configuration: <p>Machine:
<ul> <ul>
<li> Bigloo (2.8b): <tt>-06 -copt -O3 -copt -fomit-frame-pointer</tt></il> <li> MacBook Pro, 2.53 GHz, Mac OS X 10.6.2, compiling to 32-bit programs
<li> Chicken (2 build 3): <tt>-no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift</tt></il> </ul></p>
<li> Gambit (4.0 beta 17): <tt>(declare (block) (standard-bindings) (extended-bindings) (safe) (interrupts-enabled))</tt>,
installed with <tt>--enable-single-host</tt>, compiled with <tt>-dynamic</tt>, compiled and run with <tt>-:m10000</tt></li> <p>Compiler configurations:
<li> Larceny (0.92b): default mode &mdash; but should use <tt>(benchmark-block-mode #t)</tt> when it works</li> <ul>
<li> MzScheme (352.5): in <tt>module</tt></li> <li> Bigloo (3.3a): <tt>-06 -call/cc -copt -O3 -copt -fomit-frame-pointer</tt></il>
<li> Chicken (4.3.0): <tt>-no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift</tt></il>
<li> Gambit (4.6.0): <tt>(declare (block) (standard-bindings) (extended-bindings) (safe) (interrupts-enabled))</tt>,
compiled and run with <tt>-:m10000</tt></li>
<li> Ikarus (0.0.4-rc1+ rev 1870): in R6RS library</li>
<li> Larceny (0.97): in R6RS library</li>
<li> PLT (4.2.4): in <tt>module</tt></li>
</ul> </ul>
These configurations are all "safe mode", but they allow the compiler These configurations are all &ldquo;safe mode,&rdquo; but they allow the compiler
to assume that built-in Scheme functions are not redefined and (except to assume that built-in Scheme functions are not redefined and that no top-level defintion is ever
in the case of Larceny) that no top-level defintion is ever
changed. Such assumptions correspond to putting the benchmark in an changed. Such assumptions correspond to putting the benchmark in an
R6RS library (we expect).</P> R6RS library.</P>
<p>In general, we attempt to use the various implementations in a compentent way, <p>In general, we attempt to use the various implementations in a compentent way,
but not in a sophisticated way. For example, we do not tweak but not in a sophisticated way. For example, we do not tweak
inlining parameters or specify fixnum arithmetic (where appropriate), inlining parameters or specify fixnum arithmetic (where appropriate),
which could produce significant improvements from some compilers.</p> which could produce significant improvements from some compilers.</p>
<p>For a larger set of benchmarks and a more sophisticated use of the compilers, <p>For more benchmarks and a more sophisticated use of a few compilers,
see Marc Feeley's page: including fixnum- and flonum-specific arithmetic as well as unsafe modes,
<a href="http://www.iro.umontreal.ca/~gambit/bench.html">http://www.iro.umontreal.ca/~gambit/bench.html</a>. see <a href="../log1/Gambit_20benchmarks.html">this other page</a>.</p>
<p>For further details on the benchmarks here, see the benchmark source and <p>For further details on the benchmarks here, see the benchmark source and
infrastructure, which is available form the PLT SVN repository:</p> infrastructure, which is available form the PLT SVN repository:</p>
@ -50,8 +57,3 @@ R6RS library (we expect).</P>
<p align=center> <p align=center>
<a href="http://svn.plt-scheme.org/plt/trunk/collects/tests/mzscheme/benchmarks/common/">http://svn.plt-scheme.org/plt/trunk/collects/tests/mzscheme/benchmarks/common/</a></P> <a href="http://svn.plt-scheme.org/plt/trunk/collects/tests/mzscheme/benchmarks/common/">http://svn.plt-scheme.org/plt/trunk/collects/tests/mzscheme/benchmarks/common/</a></P>
<H1>Results</H1>
<ul>
<li> <a href=machine1.html>machine1</a> ...
</ul>

4
collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss
View File

@ -9,9 +9,9 @@
(include "bigloo-prelude.sch") (include "bigloo-prelude.sch")
(include ,(format "~a.sch" name)))) (include ,(format "~a.sch" name))))
(newline)) (newline))
'truncate/replace) #:exists 'truncate/replace)
(when (system (format "bigloo -w -o ~a -copt -O3 -copt -fomit-frame-pointer -O6 ~a~a.scm" (when (system (format "bigloo -w -o ~a -copt -m32 -call/cc -copt -O3 -copt -fomit-frame-pointer -O6 ~a~a.scm"
name name
(if (memq (string->symbol name) (if (memq (string->symbol name)
'(ctak)) '(ctak))

2
collects/tests/mzscheme/benchmarks/common/nfa.sch
View File

@ -42,7 +42,7 @@
'fail)) 'fail))
(time (let ((input (string->list (string-append (make-string 133 #\a) "bc")))) (time (let ((input (string->list (string-append (make-string 133 #\a) "bc"))))
(let loop ((n 50000)) (let loop ((n 150000))
(if (zero? n) (if (zero? n)
'done 'done
(begin (begin

1
collects/tests/mzscheme/benchmarks/common/nothing.sch Normal file
View File

@ -0,0 +1 @@
(time 1)

2
collects/tests/mzscheme/benchmarks/common/nothing.ss Normal file
View File

@ -0,0 +1,2 @@
(module nothing "wrap.ss")

251
collects/tests/mzscheme/benchmarks/common/nucleic2.sch
View File

@ -49,10 +49,6 @@
(define-syntax FUTURE (syntax-rules () ((FUTURE x) x))) (define-syntax FUTURE (syntax-rules () ((FUTURE x) x)))
(define-syntax TOUCH (syntax-rules () ((TOUCH x) x))) (define-syntax TOUCH (syntax-rules () ((TOUCH x) x)))
(define-syntax def-macro (syntax-rules () ((def-macro stuff ...) #t)))
(define-syntax def-struct (syntax-rules () ((def-macro stuff ...) #t)))
(define-syntax def-nuc (syntax-rules () ((def-nuc stuff ...) #t)))
(define-syntax define-structure (define-syntax define-structure
(syntax-rules () (syntax-rules ()
((define-structure #f ((define-structure #f
@ -320,204 +316,6 @@
) )
; -- SYSTEM DEPENDENT CODE ----------------------------------------------------
; The code in this section is not portable. It must be adapted to
; the Scheme system you are using.
; ********** GAMBIT 2.2
'; Add a single-quote at the start of this line if you are NOT using Gambit
(begin
(declare ; Compiler declarations for fast code:
(multilisp) ; - Enable the FUTURE special-form
(block) ; - Assume this file contains the entire program
(standard-bindings) ; - Assume standard bindings (this permits open-coding)
(extended-bindings) ; - Same for extensions (such as "##flonum.+")
(fixnum) ; - Use fixnum arithmetic by default
(not safe) ; - Remove all runtime type checks
)
(define-macro (def-macro form . body)
`(DEFINE-MACRO ,form (LET () ,@body)))
(def-macro (FLOAT+ x . l) `(,(string->symbol "##flonum.+") ,x ,@l))
(def-macro (FLOAT- x . l) `(,(string->symbol "##flonum.-") ,x ,@l))
(def-macro (FLOAT* x . l) `(,(string->symbol "##flonum.*") ,x ,@l))
(def-macro (FLOAT/ x . l) `(,(string->symbol "##flonum./") ,x ,@l))
(def-macro (FLOAT= x y) `(,(string->symbol "##flonum.=") ,x ,y))
(def-macro (FLOAT< x y) `(,(string->symbol "##flonum.<") ,x ,y))
(def-macro (FLOAT<= x y) `(not (,(string->symbol "##flonum.<") ,y ,x)))
(def-macro (FLOAT> x y) `(,(string->symbol "##flonum.<") ,y ,x))
(def-macro (FLOAT>= x y) `(not (,(string->symbol "##flonum.<") ,x ,y)))
(def-macro (FLOATsin x) `(,(string->symbol "##flonum.sin") ,x))
(def-macro (FLOATcos x) `(,(string->symbol "##flonum.cos") ,x))
(def-macro (FLOATatan x) `(,(string->symbol "##flonum.atan") ,x))
(def-macro (FLOATsqrt x) `(,(string->symbol "##flonum.sqrt") ,x))
)
; ********** MIT-SCHEME
'; Remove the single-quote from this line if you are using MIT-Scheme
(begin
(declare (usual-integrations))
(define-macro (def-macro form . body)
`(DEFINE-MACRO ,form (LET () ,@body)))
(def-macro (nary-function op1 op2 args)
(if (null? (cdr args))
`(,op1 ,@args)
(let loop ((args args))
(if (null? (cdr args))
(car args)
(loop (cons (list op2 (car args) (cadr args)) (cddr args)))))))
(def-macro (FLOAT+ x . l) `(nary-function begin flo:+ ,(cons x l)))
(def-macro (FLOAT- x . l) `(nary-function flo:negate flo:- ,(cons x l)))
(def-macro (FLOAT* x . l) `(nary-function begin flo:* ,(cons x l)))
(def-macro (FLOAT/ x . l) `(nary-function error flo:/ ,(cons x l)))
(def-macro (FLOAT= x y) `(flo:= ,x ,y))
(def-macro (FLOAT< x y) `(flo:< ,x ,y))
(def-macro (FLOAT<= x y) `(not (flo:< ,y ,x)))
(def-macro (FLOAT> x y) `(flo:< ,y ,x))
(def-macro (FLOAT>= x y) `(not (flo:< ,x ,y)))
(def-macro (FLOATsin x) `(flo:sin ,x))
(def-macro (FLOATcos x) `(flo:cos ,x))
(def-macro (FLOATatan x) `(flo:atan ,x))
(def-macro (FLOATsqrt x) `(flo:sqrt ,x))
(def-macro (FUTURE x) x)
(def-macro (TOUCH x) x)
)
; ********** SCM
'; Remove the single-quote from this line if you are using SCM
(begin
(defmacro def-macro (form . body)
`(DEFMACRO ,(car form) ,(cdr form) (LET () ,@body)))
(def-macro (FLOAT+ x . l) `(+ ,x ,@l))
(def-macro (FLOAT- x . l) `(- ,x ,@l))
(def-macro (FLOAT* x . l) `(* ,x ,@l))
(def-macro (FLOAT/ x . l) `(/ ,x ,@l))
(def-macro (FLOAT= x y) `(= ,x ,y))
(def-macro (FLOAT< x y) `(< ,x ,y))
(def-macro (FLOAT<= x y) `(not (< ,y ,x)))
(def-macro (FLOAT> x y) `(< ,y ,x))
(def-macro (FLOAT>= x y) `(not (< ,x ,y)))
(def-macro (FLOATsin x) `(sin ,x))
(def-macro (FLOATcos x) `(cos ,x))
(def-macro (FLOATatan x) `(atan ,x))
(def-macro (FLOATsqrt x) `(sqrt ,x))
(def-macro (FUTURE x) x)
(def-macro (TOUCH x) x)
)
; -- STRUCTURE DEFINITION MACRO -----------------------------------------------
; The macro "def-struct" provides a simple mechanism to define record
; structures out of vectors. The first argument to "def-struct" is a boolean
; indicating whether the vector should be tagged (to allow the type of the
; structure to be tested). The second argument is the name of the structure.
; The remaining arguments are the names of the structure's fields. A call
; to "def-struct" defines macros to
;
; 1) construct a record object of this type
; 2) fetch and store each field
; 3) test a record to see if it is of this type (only if tags are used)
; 4) define subclasses of this record with additional fields
;
; The call "(def-struct #t foo a b c)" will define the following macros:
;
; (make-foo x y) -- make a record
; (make-constant-foo x y) -- make a record (args must be constants)
; (foo? x) -- test a record
; (foo-a x) -- get field "a"
; (foo-b x) -- get field "b"
; (foo-a-set! x y) -- mutate field "a"
; (foo-b-set! x y) -- mutate field "b"
; (def-foo tag? name fields...) -- define subclass of "foo"
(def-macro (def-struct tag? name . fields)
`(DEF-SUBSTRUCT () () 0 ,tag? ,name ,@fields))
(def-macro (def-substruct sup-fields sup-tags sup-length tag? name . fields)
(define (err)
(error "Ill-formed `def-substruct'") #f)
(define (sym . strings)
(string->symbol (apply string-append strings)))
(if (symbol? name)
(let* ((name-str (symbol->string name))
(tag (sym "." name-str "."))
(all-tags (append sup-tags
(if tag?
(list (cons tag sup-length))
'()))))
(let loop ((l1 fields)
(l2 '())
(l3 '())
(i (+ sup-length (if tag? 1 0))))
(if (pair? l1)
(let ((rest (cdr l1)) (field (car l1)))
(if (symbol? field)
(let* ((field-str (symbol->string field))
(field-ref (sym name-str "-" field-str))
(field-set! (sym name-str "-" field-str "-set!")))
(loop rest
(cons `(DEF-MACRO (,field-set! X Y)
`(VECTOR-SET! ,X ,,i ,Y))
(cons `(DEF-MACRO (,field-ref X)
`(VECTOR-REF ,X ,,i))
l2))
(cons (cons field i) l3)
(+ i 1)))
(err)))
(let ((all-fields (append sup-fields (reverse l3))))
`(BEGIN
,@l2
(DEFINE ,(sym "fields-of-" name-str)
',all-fields)
(DEF-MACRO (,(sym "def-" name-str) TAG? NAME . FIELDS)
`(DEF-SUBSTRUCT ,',all-fields ,',all-tags ,',i
,TAG? ,NAME ,@FIELDS))
(DEF-MACRO (,(sym "make-constant-" name-str) . REST)
(DEFINE (ADD-TAGS I TAGS LST)
(COND ((NULL? TAGS)
LST)
((= I (CDAR TAGS))
(CONS (CAAR TAGS)
(ADD-TAGS (+ I 1) (CDR TAGS) LST)))
(ELSE
(CONS (CAR LST)
(ADD-TAGS (+ I 1) TAGS (CDR LST))))))
`'#(,@(ADD-TAGS 0 ',all-tags REST)))
(DEF-MACRO (,(sym "make-" name-str) . REST)
(DEFINE (ADD-TAGS I TAGS LST)
(COND ((NULL? TAGS)
LST)
((= I (CDAR TAGS))
(CONS `',(CAAR TAGS)
(ADD-TAGS (+ I 1) (CDR TAGS) LST)))
(ELSE
(CONS (CAR LST)
(ADD-TAGS (+ I 1) TAGS (CDR LST))))))
`(VECTOR ,@(ADD-TAGS 0 ',all-tags REST)))
,@(if tag?
`((DEF-MACRO (,(sym name-str "?") X)
`(EQ? (VECTOR-REF ,X ,,sup-length) ',',tag)))
'())
',name)))))
(err)))
; -- MATH UTILITIES ----------------------------------------------------------- ; -- MATH UTILITIES -----------------------------------------------------------
(define constant-pi 3.14159265358979323846) (define constant-pi 3.14159265358979323846)
@ -539,8 +337,6 @@
; -- POINTS ------------------------------------------------------------------- ; -- POINTS -------------------------------------------------------------------
(def-struct #f pt x y z)
(define (pt-sub p1 p2) (define (pt-sub p1 p2)
(make-pt (FLOAT- (pt-x p1) (pt-x p2)) (make-pt (FLOAT- (pt-x p1) (pt-x p2))
(FLOAT- (pt-y p1) (pt-y p2)) (FLOAT- (pt-y p1) (pt-y p2))
@ -579,8 +375,6 @@
; ;
; The components tx, ty, and tz are the translation vector. ; The components tx, ty, and tz are the translation vector.
(def-struct #f tfo a b c d e f g h i tx ty tz)
(define tfo-id ; the identity transformation matrix (define tfo-id ; the identity transformation matrix
'#(1.0 0.0 0.0 '#(1.0 0.0 0.0
0.0 1.0 0.0 0.0 1.0 0.0
@ -742,21 +536,8 @@
; Define part common to all 4 nucleotide types. ; Define part common to all 4 nucleotide types.
(def-struct #f nuc
dgf-base-tfo ; defines the standard position for wc and wc-dumas
P-O3*-275-tfo ; defines the standard position for the connect function
P-O3*-180-tfo
P-O3*-60-tfo
P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2* H2** O2* H2* C3*
H3* O3* N1 N3 C2 C4 C5 C6)
; Define remaining atoms for each nucleotide type. ; Define remaining atoms for each nucleotide type.
(def-nuc #t rA N6 N7 N9 C8 H2 H61 H62 H8)
(def-nuc #t rC N4 O2 H41 H42 H5 H6)
(def-nuc #t rG N2 N7 N9 C8 O6 H1 H21 H22 H8)
(def-nuc #t rU O2 O4 H3 H5 H6)
; Database of nucleotide conformations: ; Database of nucleotide conformations:
(define rA (define rA
@ -3167,38 +2948,6 @@
; -- PARTIAL INSTANTIATIONS --------------------------------------------------- ; -- PARTIAL INSTANTIATIONS ---------------------------------------------------
(def-struct #f var id tfo nuc)
; Add a single-quote at the start of this line if you want lazy computation
(begin
(def-macro (mk-var i tfo nuc)
`(make-var ,i ,tfo ,nuc))
(def-macro (absolute-pos var p)
`(tfo-apply (var-tfo ,var) ,p))
(def-macro (lazy-computation-of expr)
expr)
)
'; Remove the single-quote from this line if you want lazy computation
(begin
(def-macro (mk-var i tfo nuc)
`(make-var ,i ,tfo (make-relative-nuc ,tfo ,nuc)))
(def-macro (absolute-pos var p)
`(force ,p))
(def-macro (lazy-computation-of expr)
`(delay ,expr))
)
(def-macro (atom-pos atom var)
`(let ((v ,var))
(absolute-pos v (,atom (var-nuc v)))))
(define (get-var id lst) (define (get-var id lst)
(let ((v (car lst))) (let ((v (car lst)))
(if (= id (var-id v)) (if (= id (var-id v))

2
collects/tests/mzscheme/benchmarks/common/peval.sch
View File

@ -627,7 +627,7 @@
(let ((input (with-input-from-file "input.txt" read))) (let ((input (with-input-from-file "input.txt" read)))
(time (time
(let loop ((n 20) (v 0)) (let loop ((n 60) (v 0))
(if (zero? n) (if (zero? n)
v v
(loop (- n 1) (test (if input 0 17))))))) (loop (- n 1) (test (if input 0 17)))))))

3
collects/tests/mzscheme/benchmarks/common/puzzle.sch
View File

@ -30,8 +30,9 @@
(define *piecemax* (make-vector (+ typemax 1) 0)) (define *piecemax* (make-vector (+ typemax 1) 0))
(define *puzzle* (make-vector (+ size 1))) (define *puzzle* (make-vector (+ size 1)))
(define *p* (make-vector (+ typemax 1))) (define *p* (make-vector (+ typemax 1)))
(define nothing
(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1)))) (for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
(iota (+ typemax 1))) (iota (+ typemax 1))))
(define (fit i j) (define (fit i j)
(let ((end (vector-ref *piecemax* i))) (let ((end (vector-ref *piecemax* i)))

4
collects/tests/mzscheme/benchmarks/common/scheme.sch
View File

@ -856,6 +856,8 @@
(scheme-global-var name) (scheme-global-var name)
value)) value))
(define nothing
(begin
(def-proc 'not (lambda (x) (not x))) (def-proc 'not (lambda (x) (not x)))
(def-proc 'boolean? boolean?) (def-proc 'boolean? boolean?)
(def-proc 'eqv? eqv?) (def-proc 'eqv? eqv?)
@ -1032,7 +1034,7 @@
(def-proc 'write write) (def-proc 'write write)
(def-proc 'display display) (def-proc 'display display)
(def-proc 'newline newline) (def-proc 'newline newline)
(def-proc 'write-char write-char) (def-proc 'write-char write-char)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

4
collects/tests/mzscheme/benchmarks/common/scheme2.sch
View File

@ -862,6 +862,8 @@
(scheme-global-var name) (scheme-global-var name)
value)) value))
(define nothing
(begin
(def-proc 'not (lambda (x) (not x))) (def-proc 'not (lambda (x) (not x)))
(def-proc 'boolean? boolean?) (def-proc 'boolean? boolean?)
(def-proc 'eqv? eqv?) (def-proc 'eqv? eqv?)
@ -1038,7 +1040,7 @@
(def-proc 'write write) (def-proc 'write write)
(def-proc 'display display) (def-proc 'display display)
(def-proc 'newline newline) (def-proc 'newline newline)
(def-proc 'write-char write-char) (def-proc 'write-char write-char)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

369
collects/tests/mzscheme/benchmarks/common/tabulate.ss
View File

@ -3,28 +3,46 @@
exec mzscheme -qu "$0" ${1+"$@"} exec mzscheme -qu "$0" ${1+"$@"}
|# |#
;; Input format is a sequence of S-expression forms:
;; (<impl> <benchmark> (<cpu-msec> <real-msec> <gc-cpu-msec>) <compile-msec>)
;; where
;; * <impl> is a symbol for an implementation; it can optionally be of the form
;; <sys>@<mode>, where each <sys> is tried in each <mode>
;; * <benchmark> is a symbol for the benchmark
;; * <cpu-msec> and <real-msec> are the run times (CPU and real) in milliseconds
;; * <gc-cpu-msec> can be #f, or it can be a portion of <cpu-msec> spent GCing
;; * <compile-msec> should be the same for each entry of a particular <impl>
;; and <benchmark> combination; it is the time to compile the benchmark
(module tabulate mzscheme (module tabulate mzscheme
(require mzlib/list (require mzlib/list
xml/xml xml/xml
mzlib/cmdline) mzlib/cmdline
(only scheme/list argmin))
(define base-link-filename (make-parameter #f)) (define base-link-filename (make-parameter #f))
(define full-page-mode (make-parameter #f)) (define full-page-mode (make-parameter #f))
(define include-links (make-parameter #f)) (define include-links (make-parameter #f))
(define nongc (make-parameter #f)) (define nongc (make-parameter #f))
(define subtract-nothing (make-parameter #f))
(define generate-graph (make-parameter #f))
(command-line (command-line
"tabulate" "tabulate"
(current-command-line-arguments) (current-command-line-arguments)
(once-each (once-each
[("--no-links") "suppress benchmark links to SVN" [("--graph") "generate graphs instead of tables (unless --multi)"
(include-links #f)] (generate-graph #t)]
[("--links") "benchmark links to SVN"
(include-links #t)]
[("--multi") name "generate multiple pages for different views of data" [("--multi") name "generate multiple pages for different views of data"
(base-link-filename name)] (base-link-filename name)]
[("--nongc") "show times not including GC" [("--nongc") "show times not including GC"
(nongc #t)] (nongc #t)]
[("--index") "generate full page with an index.html link" [("--index") "generate full page with an index.html link"
(full-page-mode #t)])) (full-page-mode #t)]
[("--nothing") "subtract compilation time of nothing benchmark"
(subtract-nothing #t)]))
(define bm-table (make-hash-table)) (define bm-table (make-hash-table))
(define impls (make-hash-table)) (define impls (make-hash-table))
@ -54,6 +72,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
(define average-runs (define average-runs
(map (lambda (bm-run) (map (lambda (bm-run)
(let* ([runss (hash-table-map (cdr bm-run) cons)])
(cons (cons
(car bm-run) (car bm-run)
(map (lambda (runs) (map (lambda (runs)
@ -61,14 +80,47 @@ exec mzscheme -qu "$0" ${1+"$@"}
(list (average caar (cdr runs)) (list (average caar (cdr runs))
(average cadar (cdr runs)) (average cadar (cdr runs))
(average caddar (cdr runs))) (average caddar (cdr runs)))
(cadadr runs))) (let ([nothing-compile-time
(hash-table-map (cdr bm-run) cons)))) (if (subtract-nothing)
bm-runs)) (let ([a (hash-table-get
(hash-table-get bm-table 'nothing #hash())
(car runs)
#f)])
(if a
(cadadr a)
0))
0)])
(max (- (or (cadadr runs) 0)
nothing-compile-time)
0))))
runss))))
(if (subtract-nothing)
(filter (lambda (v)
(not (eq? (car v) 'nothing)))
bm-runs)
bm-runs)))
(define (symbol<? a b) (define (symbol<? a b)
(string<? (symbol->string a) (string<? (symbol->string a)
(symbol->string b))) (symbol->string b)))
(define (mode<? a b)
(let ([am (extract-column a 'mode)]
[bm (extract-column b 'mode)])
(if (equal? am bm)
(symbol<? a b)
(string<? am bm))))
(define (extract-column impl grouping)
(let ([s (symbol->string impl)])
(cond
[(regexp-match #rx"^(.*)@(.*)" s)
=> (lambda (m)
(if (eq? grouping 'impl)
(cadr m)
(caddr m)))]
[else s])))
(define sorted-runs (define sorted-runs
(sort average-runs (lambda (a b) (sort average-runs (lambda (a b)
(symbol<? (car a) (car b))))) (symbol<? (car a) (car b)))))
@ -76,6 +128,15 @@ exec mzscheme -qu "$0" ${1+"$@"}
(define sorted-impls (define sorted-impls
(sort (hash-table-map impls (lambda (k v) k)) symbol<?)) (sort (hash-table-map impls (lambda (k v) k)) symbol<?))
(define mode-sorted-impls
(sort (hash-table-map impls (lambda (k v) k))
mode<?))
(define (opposite grouping)
(if (eq? grouping 'mode)
'impl
'mode))
(define (ratio->string r) (define (ratio->string r)
(if (integer? r) (if (integer? r)
(number->string r) (number->string r)
@ -87,63 +148,102 @@ exec mzscheme -qu "$0" ${1+"$@"}
(size "-2")) (size "-2"))
,s)) ,s))
(define (lookup-color impl) (define (wrap-page relative-to . ps)
(let loop ([impls sorted-impls][odd? #f])
(if (eq? (car impls) impl)
(if odd?
"#EEEEFF"
"#DDFFDD")
(loop (cdr impls) (not odd?)))))
(define (wrap-page relative-to p)
(if (full-page-mode) (if (full-page-mode)
(let ([title (format "~a normalized to ~a" (let ([title (format "~a normalized to ~a~a"
(or (base-link-filename) (or (base-link-filename)
"results") "results")
(if (string? relative-to)
"fastest "
"")
(or relative-to (or relative-to
"fastest"))]) "fastest"))])
`(html `(html
(head (title ,title) (head (title ,title)
(body (body
(h1 ,title) (p
(p "See also " (a ((href "index.html")) (b ,title ".")
" See also " (a ((href "index.html"))
"about the benchmarks") "about the benchmarks")
".") ".")
(p ,p))))) ,@(map (lambda (p) `(p ,p))
p)) ps)))))
`(html (nbody ,@ps))))
(define forever 1000000000) (define forever 1000000000)
(define (ntime v) (define (ntime v)
(and (caadr v) (- (caadr v) (caddr (cadr v))))) (and (caadr v) (- (caadr v) (or (caddr (cadr v)) 0))))
(define (generate-page relative-to) (define (grouping->suffix grouping)
(empty-tag-shorthand html-empty-tags) (if (eq? grouping 'impl)
(write-xml/content ""
(xexpr->xml (format "-~a" grouping)))
(wrap-page
relative-to (define no-modes? (equal? mode-sorted-impls sorted-impls))
`(table
(tr (td nbsp) (define (fixup-filename s)
(td ((colspan "2") (align "right")) (regexp-replace* #rx"[^.a-zA-Z0-9-]" s (lambda (s)
,(if (and (base-link-filename) (format "_~x" (char->integer (string-ref s 0))))))
relative-to)
`(a ((href ,(format "~a.html" (base-link-filename)))) (define (output-name impl grouping graph?)
"fastest") (fixup-filename
"fastest")) (if impl
,@(map (lambda (impl) (format "~a-~a~a.html"
`(td ((colspan "2") (align "right"))
(b ,(let ([s (symbol->string impl)])
(if (and (base-link-filename)
(not (eq? impl relative-to)))
`(a ((href ,(format "~a-~a.html"
(base-link-filename) (base-link-filename)
impl))) impl
,s) (grouping->suffix grouping))
s))) (format "~a~a~a.html"
nbsp)) (base-link-filename)
sorted-impls)) (grouping->suffix grouping)
,@(map (lambda (bm-run) (if graph? "-plot" "")))))
(define (resolve-relative-to relative-to grouping runs)
(if (string? relative-to)
;; Find fastest among entries matching `relative-to':
(car (argmin (lambda (run)
(or (caadr run) forever))
(cons (list #f (list #f #f #f) #f)
(filter (lambda (run)
(equal? relative-to (extract-column (car run) grouping)))
runs))))
;; Nothing to resolve:
relative-to))
(define (extract-variants grouping impls)
(let ([ht (make-hash-table 'equal)])
(for-each (lambda (impl)
(hash-table-put! ht (extract-column impl grouping) #t))
impls)
(hash-table-map ht (lambda (k v) k))))
(define just-impls (sort (extract-variants 'impl sorted-impls) string<?))
(define all-colors (list "#EEEEDD" "#EEEEFF" "#EEDDEE" "#FFEEEE"
"#EEEEEE" "#DDEEEE"))
(define (lookup-color impl)
(let ([s (extract-column impl 'impl)])
(let loop ([impls just-impls]
[colors all-colors])
(cond
[(null? colors) (loop impls all-colors)]
[(null? impls) (car colors)]
[(equal? (car impls) s) (car colors)]
[else (loop (cdr impls) (cdr colors))]))))
(define (darken c)
(regexp-replace*
#rx"F"
(regexp-replace*
#rx"E"
(regexp-replace*
#rx"D"
c
"A")
"B")
"F"))
(define (call-with-bm-info bm-run relative-to grouping proc)
(let ([fastest (apply min (map (lambda (run) (let ([fastest (apply min (map (lambda (run)
(or (caadr run) forever)) (or (caadr run) forever))
(cdr bm-run)))] (cdr bm-run)))]
@ -154,7 +254,8 @@ exec mzscheme -qu "$0" ${1+"$@"}
(let ([v (caddr run)]) (let ([v (caddr run)])
(or (and v (positive? v) v) (or (and v (positive? v) v)
forever))) forever)))
(cdr bm-run)))]) (cdr bm-run)))]
[relative-to (resolve-relative-to relative-to grouping (cdr bm-run))])
(let-values ([(base n-base c-base) (let-values ([(base n-base c-base)
(if relative-to (if relative-to
(let ([a (assq relative-to (cdr bm-run))]) (let ([a (assq relative-to (cdr bm-run))])
@ -162,6 +263,94 @@ exec mzscheme -qu "$0" ${1+"$@"}
(values (caadr a) (ntime a) (caddr a)) (values (caadr a) (ntime a) (caddr a))
(values #f #f #f))) (values #f #f #f)))
(values fastest n-fastest c-fastest))]) (values fastest n-fastest c-fastest))])
(proc fastest n-fastest c-fastest relative-to
base n-base c-base))))
(define (generate-page relative-to grouping graph? has-other?)
(empty-tag-shorthand html-empty-tags)
(write-xml/content
(xexpr->xml
(wrap-page
relative-to
(if (not graph?)
`(table
,@(if no-modes?
null
(list
`(tr
(td (i ,(if (eq? grouping 'mode)
"mode"
"impl")))
(td nbsp)
(td nbsp)
,@(let loop ([impls (if (eq? grouping 'mode)
mode-sorted-impls
sorted-impls)])
(if (null? impls)
null
(let* ([impl (car impls)]
[s (extract-column impl grouping)]
[count (let loop ([impls (cdr impls)])
(cond
[(null? impls) 0]
[(not (equal? s (extract-column (car impls) grouping)))
0]
[else (add1 (loop (cdr impls)))]))])
(cons
`(td ((colspan ,(number->string (* 2 (+ 1 count))))
(align "center")
(bgcolor "#DDDDFF"))
(b ,(if (equal? s relative-to)
s
`(a ([href ,(fixup-filename
(format "~a-~a~a.html"
(base-link-filename)
s
(grouping->suffix grouping)))])
,s))))
(loop (list-tail impls (+ 1 count))))))))))
(tr (td ,(if no-modes?
'nbsp
`(i (a ([href ,(output-name #f (opposite grouping) #f)])
,(if (eq? grouping 'mode)
"impl"
"mode")))))
(td ((colspan "2") (align "right"))
,(if (and (base-link-filename)
relative-to)
`(a ((href ,(fixup-filename
(format "~a~a.html"
(base-link-filename)
(grouping->suffix grouping)))))
"fastest")
"fastest"))
,@(map (lambda (impl)
`(td ((colspan "2") (align "right"))
(b ,(let ([s (extract-column impl (opposite grouping))])
(if (and (base-link-filename)
(not (eq? impl relative-to)))
`(a ((href ,(fixup-filename
(format "~a-~a~a.html"
(base-link-filename)
impl
(grouping->suffix grouping)))))
,s)
s)))
nbsp))
(if (eq? grouping 'mode)
mode-sorted-impls
sorted-impls))
,@(if has-other?
`((td nbsp nbsp (a ((href ,(output-name #f 'impl #t))) "To plots")))
null))
,@(map (lambda (bm-run)
(define orig-relative-to relative-to)
(call-with-bm-info
bm-run
relative-to
grouping
(lambda (fastest n-fastest c-fastest relative-to
base n-base c-base)
`(tr (td ,(if (include-links) `(tr (td ,(if (include-links)
`(a ((href ,(format (string-append "http://svn.plt-scheme.org/plt/trunk/collects/" `(a ((href ,(format (string-append "http://svn.plt-scheme.org/plt/trunk/collects/"
"tests/mzscheme/benchmarks/common/~a.sch") "tests/mzscheme/benchmarks/common/~a.sch")
@ -187,11 +376,18 @@ exec mzscheme -qu "$0" ${1+"$@"}
`(td) `(td)
`(td ((align "right") `(td ((align "right")
(bgcolor ,(lookup-color impl))) (bgcolor ,(lookup-color impl)))
,(if (and (caddr a) c-base (positive? c-base)) ,(if (and a (caddr a) c-base (positive? c-base))
(small (ratio->string (/ (caddr a) c-base))) (small (ratio->string (/ (caddr a) c-base)))
'"-") '"-")
nbsp)) nbsp))
(td ((bgcolor ,(lookup-color impl))) (td ((bgcolor ,(if (and n base (= n base)
(or (not orig-relative-to)
(and (string? orig-relative-to)
(equal? (extract-column impl grouping)
orig-relative-to))))
"white"
(lookup-color impl)))
(align "right"))
,(if (and n base) ,(if (and n base)
(let ([s (if (= n base) (let ([s (if (= n base)
"1" "1"
@ -214,20 +410,67 @@ exec mzscheme -qu "$0" ${1+"$@"}
"-")) "-"))
null) null)
nbsp)))) nbsp))))
sorted-impls)))))) (if (eq? grouping 'mode)
sorted-runs))))) mode-sorted-impls
sorted-impls)))))))
sorted-runs))
`(table
((style "border-spacing: 0px 3px;"))
(tr (td ((colspan "2"))
"Longer is better."
,@(if has-other?
`(nbsp nbsp (a ((href ,(output-name #f 'impl #f))) "Back to tables"))
null)))
,@(map (lambda (bm-run)
(call-with-bm-info
bm-run
relative-to
grouping
(lambda (fastest n-fastest c-fastest relative-to
base n-base c-base)
`(tr ((style "background-color: #eeeeee"))
(td ((valign "top")) ,(symbol->string (car bm-run)))
(td
(table
((style "border-spacing: 0px;"))
,@(map (lambda (impl)
(let* ([a (assq impl (cdr bm-run))]
[n (and a (caadr a))]
[n2 (and a (ntime a))])
`(tr (td (span ((style "font-size: small;"))
,(symbol->string impl))
nbsp)
(td ((style "padding: 0em;"))
,(if (and n base)
(let ([col (darken (lookup-color impl))])
`(span ((style ,(format "background-color: ~a; color: ~a;" col col)))
,(format (make-string (max (floor (* 60 (if (zero? n) 1 (/ base n))))
1)
#\x))))
"")))))
sorted-impls)))))))
sorted-runs))))))
(newline)) (newline))
(if (base-link-filename) (if (base-link-filename)
(for-each (lambda (impl) (begin
(with-output-to-file (if impl (for-each (lambda (grouping)
(format "~a-~a.html" (for-each
(base-link-filename) (lambda (impl)
impl) (let ([fn (output-name impl grouping #f)])
(format "~a.html" (fprintf (current-error-port) "Generating ~a\n" fn)
(base-link-filename))) (with-output-to-file fn
(lambda () (generate-page impl)) (lambda () (generate-page impl grouping #f #t))
'truncate)))
(append (cons #f sorted-impls)
(if no-modes?
null
(extract-variants grouping sorted-impls)))))
(if no-modes?
'(impl)
'(impl mode)))
(with-output-to-file (output-name #f 'impl #t)
(lambda () (generate-page #f 'impl #t #t))
'truncate)) 'truncate))
(cons #f sorted-impls)) (generate-page #f 'impl (generate-graph) #f)))
(generate-page #f)))

51
collects/tests/mzscheme/benchmarks/common/triangle.sch
View File

@ -15,38 +15,17 @@
(define *board* (make-vector 16 1)) (define *board* (make-vector 16 1))
(define *sequence* (make-vector 14 0)) (define *sequence* (make-vector 14 0))
(define *a* (make-vector 37)) (define *a* (make-vector 37))
(for-each (lambda (i x) (vector-set! *a* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(1 2 4 3 5 6 1 3 6 2 5 4 11 12
13 7 8 4 4 7 11 8 12 13 6 10
15 9 14 13 13 14 15 9 10
6 6))
(define *b* (make-vector 37)) (define *b* (make-vector 37))
(for-each (lambda (i x) (vector-set! *b* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(2 4 7 5 8 9 3 6 10 5 9 8
12 13 14 8 9 5 2 4 7 5 8
9 3 6 10 5 9 8 12 13 14
8 9 5 5))
(define *c* (make-vector 37)) (define *c* (make-vector 37))
(for-each (lambda (i x) (vector-set! *c* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(4 7 11 8 12 13 6 10 15 9 14 13
13 14 15 9 10 6 1 2 4 3 5 6 1
3 6 2 5 4 11 12 13 7 8 4 4))
(define *answer* '()) (define *answer* '())
(define *final* '()) (define *final* '())
(vector-set! *board* 5 0)
(define (last-position) (define (last-position)
(do ((i 1 (+ i 1))) (do ((i 1 (+ i 1)))
((or (= i 16) (= 1 (vector-ref *board* i))) ((or (= i 16) (= 1 (vector-ref *board* i)))
(if (= i 16) 0 i)))) (if (= i 16) 0 i))))
(define (try i depth) (define (ttry i depth)
(cond ((= depth 14) (cond ((= depth 14)
(let ((lp (last-position))) (let ((lp (last-position)))
(if (not (member lp *final*)) (if (not (member lp *final*))
@ -63,7 +42,7 @@
(vector-set! *sequence* depth i) (vector-set! *sequence* depth i)
(do ((j 0 (+ j 1)) (do ((j 0 (+ j 1))
(depth (+ depth 1))) (depth (+ depth 1)))
((or (= j 36) (try j depth)) #f)) ((or (= j 36) (ttry j depth)) #f))
(vector-set! *board* (vector-ref *a* i) 1) (vector-set! *board* (vector-ref *a* i) 1)
(vector-set! *board* (vector-ref *b* i) 1) (vector-set! *board* (vector-ref *b* i) 1)
(vector-set! *board* (vector-ref *c* i) 0) '()) (vector-set! *board* (vector-ref *c* i) 0) '())
@ -72,11 +51,33 @@
(define (gogogo i) (define (gogogo i)
(let ((*answer* '()) (let ((*answer* '())
(*final* '())) (*final* '()))
(try i 1))) (ttry i 1)))
(for-each (lambda (i x) (vector-set! *a* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(1 2 4 3 5 6 1 3 6 2 5 4 11 12
13 7 8 4 4 7 11 8 12 13 6 10
15 9 14 13 13 14 15 9 10
6 6))
(for-each (lambda (i x) (vector-set! *b* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(2 4 7 5 8 9 3 6 10 5 9 8
12 13 14 8 9 5 2 4 7 5 8
9 3 6 10 5 9 8 12 13 14
8 9 5 5))
(for-each (lambda (i x) (vector-set! *c* i x))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36)
'(4 7 11 8 12 13 6 10 15 9 14 13
13 14 15 9 10 6 1 2 4 3 5 6 1
3 6 2 5 4 11 12 13 7 8 4 4))
(vector-set! *board* 5 0)
;;; call: (gogogo 22)) ;;; call: (gogogo 22))
(time (let loop ((n 10000)) (time (let loop ((n 100000))
(if (zero? n) (if (zero? n)
'done 'done
(begin (begin