update benchmark harness
svn: r17840
This commit is contained in:
Matthew Flatt
parent
3068ae4bd5
commit
f07c19b268
|
|
@ -3,6 +3,8 @@
|
|||
exec mzscheme -qu "$0" ${1+"$@"}
|
||||
|#
|
||||
|
||||
;; See "tabulate.ss" for information on the output format
|
||||
|
||||
(module auto scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
mzlib/process
|
||||
|
|
@ -11,6 +13,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
mzlib/compile
|
||||
mzlib/inflate
|
||||
mzlib/date
|
||||
mzlib/port
|
||||
dynext/file
|
||||
syntax/toplevel
|
||||
scheme/runtime-path)
|
||||
|
|
@ -74,18 +77,24 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(define (clean-up-zo bm)
|
||||
(delete-file (build-path "compiled" (format "~a.zo" bm))))
|
||||
|
||||
(define (setup-larceny bm)
|
||||
(setup-sps bm "(larceny benchmarking)"))
|
||||
|
||||
(define (mk-larceny bm)
|
||||
(parameterize ([current-input-port
|
||||
(open-input-string
|
||||
(format (string-append
|
||||
"(compiler-switches 'fast-safe)\n"
|
||||
"(compile-file \"~a.sch\")\n")
|
||||
"(import (larceny compiler))\n"
|
||||
"(compile-library \"~a.sls\")\n")
|
||||
bm))]
|
||||
[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)
|
||||
(delete-file (format "~a.fasl" bm)))
|
||||
(clean-up-sps bm)
|
||||
(delete-file (format "~a.slfasl" bm)))
|
||||
|
||||
(define (mk-mzc bm)
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
|
|
@ -104,16 +113,45 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(system (format "gsi -:d-,m10000 ~a.o1" bm)))
|
||||
|
||||
(define (run-larceny bm)
|
||||
(parameterize ([current-input-port (open-input-string
|
||||
(format "(load \"~a.fasl\")\n"
|
||||
bm))])
|
||||
(system "larceny")))
|
||||
(system "larceny -r6rs -program prog.sps -path ."))
|
||||
|
||||
(define (setup-sps bm lib)
|
||||
(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)
|
||||
(void))
|
||||
(system "ikarus --compile-dependencies prog.sps"))
|
||||
|
||||
(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)
|
||||
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)])
|
||||
(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)
|
||||
(let ([m (regexp-match #rx#"Elapsed time...: ([0-9]+) ms.*Elapsed GC time: ([0-9]+) ms" str)])
|
||||
(list (bytes->number (cadr m))
|
||||
|
|
@ -169,7 +216,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
|
||||
;; 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
|
||||
destruct
|
||||
|
|
@ -183,6 +230,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(define impls
|
||||
(list
|
||||
(make-impl 'mzscheme
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzscheme -u ~a.ss" bm)))
|
||||
|
|
@ -190,6 +238,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
clean-up-nothing
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mz-old
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mz-old -u ~a.ss" bm)))
|
||||
|
|
@ -197,6 +246,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
clean-up-nothing
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mzschemecgc
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzschemecgc -u ~a.ss" bm)))
|
||||
|
|
@ -204,6 +254,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
clean-up-nothing
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mzscheme3m
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzscheme3m -u ~a.ss" bm)))
|
||||
|
|
@ -211,6 +262,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
clean-up-nothing
|
||||
mutable-pair-progs)
|
||||
(make-impl 'plt-r5rs
|
||||
void
|
||||
mk-plt-r5rs
|
||||
(lambda (bm)
|
||||
(system (format "plt-r5rs ~a.scm" bm)))
|
||||
|
|
@ -218,6 +270,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
clean-up-plt-r5rs
|
||||
null)
|
||||
(make-impl 'mzc
|
||||
void
|
||||
mk-mzc
|
||||
(lambda (bm)
|
||||
(system (format "mzscheme -mvqee '(load-extension \"~a\")' '(require ~a)'"
|
||||
|
|
@ -228,6 +281,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(append '(takr takr2)
|
||||
mutable-pair-progs))
|
||||
(make-impl 'mzscheme-j
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzscheme -jqu ~a.ss" bm)))
|
||||
|
|
@ -235,6 +289,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
clean-up-nothing
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mzschemecgc-j
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzschemecgc -jqu ~a.ss" bm)))
|
||||
|
|
@ -242,6 +297,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
clean-up-nothing
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mzschemecgc-tl
|
||||
void
|
||||
mk-mzscheme-tl
|
||||
(lambda (bm)
|
||||
(system (format "mzschemecgc -qr compiled/~a.zo" bm)))
|
||||
|
|
@ -250,37 +306,42 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(append '(nucleic2)
|
||||
mutable-pair-progs))
|
||||
(make-impl 'chicken
|
||||
void
|
||||
(run-mk "mk-chicken.ss")
|
||||
run-exe
|
||||
extract-chicken-times
|
||||
clean-up-bin
|
||||
'(nucleic2))
|
||||
'(scheme2 takr2))
|
||||
(make-impl 'bigloo
|
||||
void
|
||||
(run-mk "mk-bigloo.ss")
|
||||
run-exe/time
|
||||
extract-time-times
|
||||
run-exe
|
||||
extract-bigloo-times
|
||||
clean-up-bin
|
||||
'(cpstack maze maze2 puzzle triangle))
|
||||
'(cpstack takr2))
|
||||
(make-impl 'gambit
|
||||
void
|
||||
(run-mk "mk-gambit.ss")
|
||||
run-gambit-exe
|
||||
extract-gambit-times
|
||||
clean-up-o1
|
||||
'(nucleic2))
|
||||
(make-impl 'larceny
|
||||
setup-larceny
|
||||
mk-larceny
|
||||
run-larceny
|
||||
extract-larceny-times
|
||||
clean-up-fasl
|
||||
'())
|
||||
(make-impl 'ikarus
|
||||
setup-ikarus
|
||||
mk-ikarus
|
||||
run-ikarus
|
||||
extract-ikarus-times
|
||||
clean-up-nothing
|
||||
'(fft))))
|
||||
clean-up-ikarus
|
||||
'(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
|
||||
'(conform
|
||||
|
|
@ -303,6 +364,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
nboyer
|
||||
nestedloop
|
||||
nfa
|
||||
nothing
|
||||
nqueens
|
||||
nucleic2
|
||||
paraffins
|
||||
|
|
@ -329,6 +391,8 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
impls)])
|
||||
(if (memq bm (impl-skips i))
|
||||
(rprintf "[~a ~a ~s #f]\n" impl bm '(#f #f #f))
|
||||
(begin
|
||||
((impl-setup i) bm)
|
||||
(let ([start (current-inexact-milliseconds)])
|
||||
((impl-make i) bm)
|
||||
(let ([end (current-inexact-milliseconds)])
|
||||
|
|
@ -345,7 +409,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
((impl-extract-result i) bm (get-output-bytes out))
|
||||
(inexact->exact (round (- end start)))))
|
||||
(loop (sub1 n)))))
|
||||
((impl-clean-up i) bm)))
|
||||
((impl-clean-up i) bm))))
|
||||
(flush-output)))
|
||||
|
||||
;; Extract command-line arguments --------------------
|
||||
|
|
|
|||
|
|
@ -1,9 +1,16 @@
|
|||
(define orig-time time)
|
||||
|
||||
(define-macro (time expr)
|
||||
`(time-it (lambda () ,expr)))
|
||||
|
||||
(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 bitwise-or bit-or)
|
||||
(define bitwise-and bit-and)
|
||||
(define bitwise-not bit-not)
|
||||
|
|
|
|||
|
|
@ -46,19 +46,13 @@
|
|||
(define (f+dderiv a)
|
||||
(cons '+ (map dderiv a)))
|
||||
|
||||
(put '+ 'dderiv f+dderiv) ; install procedure on the property list
|
||||
|
||||
(define (f-dderiv a)
|
||||
(cons '- (map dderiv a)))
|
||||
|
||||
(put '- 'dderiv f-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 '/
|
||||
|
|
@ -71,8 +65,6 @@
|
|||
(cadr a)
|
||||
(dderiv (cadr a))))))
|
||||
|
||||
(put '/ 'dderiv /dderiv) ; install procedure on the property list
|
||||
|
||||
(define (dderiv a)
|
||||
(cond
|
||||
((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))))
|
||||
|
||||
(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)
|
||||
|
||||
(time (run))
|
||||
|
|
|
|||
|
|
@ -4,45 +4,52 @@
|
|||
|
||||
<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>
|
||||
|
||||
<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>
|
||||
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
|
||||
didn't run in an implementation (and you should assume a benchmark problem,
|
||||
rather than an implementation problem).</p>
|
||||
didn't run in an implementation for some reason (possibly not a good one).</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).
|
||||
Where available, 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>
|
||||
The times are based on the output of the implementation's <tt>time</tt>
|
||||
syntactic form for function.</p>
|
||||
|
||||
<p>Compiler configuration:
|
||||
<p>Machine:
|
||||
<ul>
|
||||
<li> Bigloo (2.8b): <tt>-06 -copt -O3 -copt -fomit-frame-pointer</tt></il>
|
||||
<li> Chicken (2 build 3): <tt>-no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift</tt></il>
|
||||
<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>
|
||||
<li> Larceny (0.92b): default mode — but should use <tt>(benchmark-block-mode #t)</tt> when it works</li>
|
||||
<li> MzScheme (352.5): in <tt>module</tt></li>
|
||||
<li> MacBook Pro, 2.53 GHz, Mac OS X 10.6.2, compiling to 32-bit programs
|
||||
</ul></p>
|
||||
|
||||
<p>Compiler configurations:
|
||||
<ul>
|
||||
<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>
|
||||
These configurations are all "safe mode", but they allow the compiler
|
||||
to assume that built-in Scheme functions are not redefined and (except
|
||||
in the case of Larceny) that no top-level defintion is ever
|
||||
These configurations are all “safe mode,” but they allow the compiler
|
||||
to assume that built-in Scheme functions are not redefined and that no top-level defintion is ever
|
||||
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,
|
||||
but not in a sophisticated way. For example, we do not tweak
|
||||
inlining parameters or specify fixnum arithmetic (where appropriate),
|
||||
which could produce significant improvements from some compilers.</p>
|
||||
|
||||
<p>For a larger set of benchmarks and a more sophisticated use of the compilers,
|
||||
see Marc Feeley's page:
|
||||
<a href="http://www.iro.umontreal.ca/~gambit/bench.html">http://www.iro.umontreal.ca/~gambit/bench.html</a>.
|
||||
<p>For more benchmarks and a more sophisticated use of a few compilers,
|
||||
including fixnum- and flonum-specific arithmetic as well as unsafe modes,
|
||||
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
|
||||
infrastructure, which is available form the PLT SVN repository:</p>
|
||||
|
|
@ -50,8 +57,3 @@ R6RS library (we expect).</P>
|
|||
<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>
|
||||
|
||||
<H1>Results</H1>
|
||||
|
||||
<ul>
|
||||
<li> <a href=machine1.html>machine1</a> ...
|
||||
</ul>
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@
|
|||
(include "bigloo-prelude.sch")
|
||||
(include ,(format "~a.sch" name))))
|
||||
(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
|
||||
(if (memq (string->symbol name)
|
||||
'(ctak))
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@
|
|||
'fail))
|
||||
|
||||
(time (let ((input (string->list (string-append (make-string 133 #\a) "bc"))))
|
||||
(let loop ((n 50000))
|
||||
(let loop ((n 150000))
|
||||
(if (zero? n)
|
||||
'done
|
||||
(begin
|
||||
|
|
|
|||
1
collects/tests/mzscheme/benchmarks/common/nothing.sch
Normal file
1
collects/tests/mzscheme/benchmarks/common/nothing.sch
Normal file
|
|
@ -0,0 +1 @@
|
|||
(time 1)
|
||||
2
collects/tests/mzscheme/benchmarks/common/nothing.ss
Normal file
2
collects/tests/mzscheme/benchmarks/common/nothing.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
(module nothing "wrap.ss")
|
||||
|
|
@ -49,10 +49,6 @@
|
|||
(define-syntax FUTURE (syntax-rules () ((FUTURE 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
|
||||
(syntax-rules ()
|
||||
((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 -----------------------------------------------------------
|
||||
|
||||
(define constant-pi 3.14159265358979323846)
|
||||
|
|
@ -539,8 +337,6 @@
|
|||
|
||||
; -- POINTS -------------------------------------------------------------------
|
||||
|
||||
(def-struct #f pt x y z)
|
||||
|
||||
(define (pt-sub p1 p2)
|
||||
(make-pt (FLOAT- (pt-x p1) (pt-x p2))
|
||||
(FLOAT- (pt-y p1) (pt-y p2))
|
||||
|
|
@ -579,8 +375,6 @@
|
|||
;
|
||||
; 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
|
||||
'#(1.0 0.0 0.0
|
||||
0.0 1.0 0.0
|
||||
|
|
@ -742,21 +536,8 @@
|
|||
|
||||
; 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.
|
||||
|
||||
(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:
|
||||
|
||||
(define rA
|
||||
|
|
@ -3167,38 +2948,6 @@
|
|||
|
||||
; -- 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)
|
||||
(let ((v (car lst)))
|
||||
(if (= id (var-id v))
|
||||
|
|
|
|||
|
|
@ -627,7 +627,7 @@
|
|||
|
||||
(let ((input (with-input-from-file "input.txt" read)))
|
||||
(time
|
||||
(let loop ((n 20) (v 0))
|
||||
(let loop ((n 60) (v 0))
|
||||
(if (zero? n)
|
||||
v
|
||||
(loop (- n 1) (test (if input 0 17)))))))
|
||||
|
|
|
|||
|
|
@ -30,8 +30,9 @@
|
|||
(define *piecemax* (make-vector (+ typemax 1) 0))
|
||||
(define *puzzle* (make-vector (+ size 1)))
|
||||
(define *p* (make-vector (+ typemax 1)))
|
||||
(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
|
||||
(iota (+ typemax 1)))
|
||||
(define nothing
|
||||
(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
|
||||
(iota (+ typemax 1))))
|
||||
|
||||
(define (fit i j)
|
||||
(let ((end (vector-ref *piecemax* i)))
|
||||
|
|
|
|||
|
|
@ -856,6 +856,8 @@
|
|||
(scheme-global-var name)
|
||||
value))
|
||||
|
||||
(define nothing
|
||||
(begin
|
||||
(def-proc 'not (lambda (x) (not x)))
|
||||
(def-proc 'boolean? boolean?)
|
||||
(def-proc 'eqv? eqv?)
|
||||
|
|
@ -1032,7 +1034,7 @@
|
|||
(def-proc 'write write)
|
||||
(def-proc 'display display)
|
||||
(def-proc 'newline newline)
|
||||
(def-proc 'write-char write-char)
|
||||
(def-proc 'write-char write-char)))
|
||||
|
||||
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
|
|
|
|||
|
|
@ -862,6 +862,8 @@
|
|||
(scheme-global-var name)
|
||||
value))
|
||||
|
||||
(define nothing
|
||||
(begin
|
||||
(def-proc 'not (lambda (x) (not x)))
|
||||
(def-proc 'boolean? boolean?)
|
||||
(def-proc 'eqv? eqv?)
|
||||
|
|
@ -1038,7 +1040,7 @@
|
|||
(def-proc 'write write)
|
||||
(def-proc 'display display)
|
||||
(def-proc 'newline newline)
|
||||
(def-proc 'write-char write-char)
|
||||
(def-proc 'write-char write-char)))
|
||||
|
||||
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
|
|
|
|||
|
|
@ -3,28 +3,46 @@
|
|||
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
|
||||
(require mzlib/list
|
||||
xml/xml
|
||||
mzlib/cmdline)
|
||||
mzlib/cmdline
|
||||
(only scheme/list argmin))
|
||||
|
||||
(define base-link-filename (make-parameter #f))
|
||||
(define full-page-mode (make-parameter #f))
|
||||
(define include-links (make-parameter #f))
|
||||
(define nongc (make-parameter #f))
|
||||
(define subtract-nothing (make-parameter #f))
|
||||
(define generate-graph (make-parameter #f))
|
||||
|
||||
(command-line
|
||||
"tabulate"
|
||||
(current-command-line-arguments)
|
||||
(once-each
|
||||
[("--no-links") "suppress benchmark links to SVN"
|
||||
(include-links #f)]
|
||||
[("--graph") "generate graphs instead of tables (unless --multi)"
|
||||
(generate-graph #t)]
|
||||
[("--links") "benchmark links to SVN"
|
||||
(include-links #t)]
|
||||
[("--multi") name "generate multiple pages for different views of data"
|
||||
(base-link-filename name)]
|
||||
[("--nongc") "show times not including GC"
|
||||
(nongc #t)]
|
||||
[("--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 impls (make-hash-table))
|
||||
|
|
@ -54,6 +72,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
|
||||
(define average-runs
|
||||
(map (lambda (bm-run)
|
||||
(let* ([runss (hash-table-map (cdr bm-run) cons)])
|
||||
(cons
|
||||
(car bm-run)
|
||||
(map (lambda (runs)
|
||||
|
|
@ -61,14 +80,47 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(list (average caar (cdr runs))
|
||||
(average cadar (cdr runs))
|
||||
(average caddar (cdr runs)))
|
||||
(cadadr runs)))
|
||||
(hash-table-map (cdr bm-run) cons))))
|
||||
bm-runs))
|
||||
(let ([nothing-compile-time
|
||||
(if (subtract-nothing)
|
||||
(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)
|
||||
(string<? (symbol->string a)
|
||||
(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
|
||||
(sort average-runs (lambda (a b)
|
||||
(symbol<? (car a) (car b)))))
|
||||
|
|
@ -76,6 +128,15 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(define sorted-impls
|
||||
(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)
|
||||
(if (integer? r)
|
||||
(number->string r)
|
||||
|
|
@ -87,63 +148,102 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(size "-2"))
|
||||
,s))
|
||||
|
||||
(define (lookup-color impl)
|
||||
(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)
|
||||
(define (wrap-page relative-to . ps)
|
||||
(if (full-page-mode)
|
||||
(let ([title (format "~a normalized to ~a"
|
||||
(let ([title (format "~a normalized to ~a~a"
|
||||
(or (base-link-filename)
|
||||
"results")
|
||||
(if (string? relative-to)
|
||||
"fastest "
|
||||
"")
|
||||
(or relative-to
|
||||
"fastest"))])
|
||||
`(html
|
||||
(head (title ,title)
|
||||
(body
|
||||
(h1 ,title)
|
||||
(p "See also " (a ((href "index.html"))
|
||||
(p
|
||||
(b ,title ".")
|
||||
" See also " (a ((href "index.html"))
|
||||
"about the benchmarks")
|
||||
".")
|
||||
(p ,p)))))
|
||||
p))
|
||||
,@(map (lambda (p) `(p ,p))
|
||||
ps)))))
|
||||
`(html (nbody ,@ps))))
|
||||
|
||||
(define forever 1000000000)
|
||||
|
||||
(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)
|
||||
(empty-tag-shorthand html-empty-tags)
|
||||
(write-xml/content
|
||||
(xexpr->xml
|
||||
(wrap-page
|
||||
relative-to
|
||||
`(table
|
||||
(tr (td nbsp)
|
||||
(td ((colspan "2") (align "right"))
|
||||
,(if (and (base-link-filename)
|
||||
relative-to)
|
||||
`(a ((href ,(format "~a.html" (base-link-filename))))
|
||||
"fastest")
|
||||
"fastest"))
|
||||
,@(map (lambda (impl)
|
||||
`(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"
|
||||
(define (grouping->suffix grouping)
|
||||
(if (eq? grouping 'impl)
|
||||
""
|
||||
(format "-~a" grouping)))
|
||||
|
||||
(define no-modes? (equal? mode-sorted-impls sorted-impls))
|
||||
|
||||
(define (fixup-filename s)
|
||||
(regexp-replace* #rx"[^.a-zA-Z0-9-]" s (lambda (s)
|
||||
(format "_~x" (char->integer (string-ref s 0))))))
|
||||
|
||||
(define (output-name impl grouping graph?)
|
||||
(fixup-filename
|
||||
(if impl
|
||||
(format "~a-~a~a.html"
|
||||
(base-link-filename)
|
||||
impl)))
|
||||
,s)
|
||||
s)))
|
||||
nbsp))
|
||||
sorted-impls))
|
||||
,@(map (lambda (bm-run)
|
||||
impl
|
||||
(grouping->suffix grouping))
|
||||
(format "~a~a~a.html"
|
||||
(base-link-filename)
|
||||
(grouping->suffix grouping)
|
||||
(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)
|
||||
(or (caadr run) forever))
|
||||
(cdr bm-run)))]
|
||||
|
|
@ -154,7 +254,8 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(let ([v (caddr run)])
|
||||
(or (and v (positive? v) v)
|
||||
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)
|
||||
(if relative-to
|
||||
(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 #f #f #f)))
|
||||
(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)
|
||||
`(a ((href ,(format (string-append "http://svn.plt-scheme.org/plt/trunk/collects/"
|
||||
"tests/mzscheme/benchmarks/common/~a.sch")
|
||||
|
|
@ -187,11 +376,18 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
`(td)
|
||||
`(td ((align "right")
|
||||
(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)))
|
||||
'"-")
|
||||
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)
|
||||
(let ([s (if (= n base)
|
||||
"1"
|
||||
|
|
@ -214,20 +410,67 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
"-"))
|
||||
null)
|
||||
nbsp))))
|
||||
sorted-impls))))))
|
||||
sorted-runs)))))
|
||||
(if (eq? grouping 'mode)
|
||||
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))
|
||||
|
||||
(if (base-link-filename)
|
||||
(for-each (lambda (impl)
|
||||
(with-output-to-file (if impl
|
||||
(format "~a-~a.html"
|
||||
(base-link-filename)
|
||||
impl)
|
||||
(format "~a.html"
|
||||
(base-link-filename)))
|
||||
(lambda () (generate-page impl))
|
||||
(begin
|
||||
(for-each (lambda (grouping)
|
||||
(for-each
|
||||
(lambda (impl)
|
||||
(let ([fn (output-name impl grouping #f)])
|
||||
(fprintf (current-error-port) "Generating ~a\n" fn)
|
||||
(with-output-to-file fn
|
||||
(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))
|
||||
(cons #f sorted-impls))
|
||||
(generate-page #f)))
|
||||
(generate-page #f 'impl (generate-graph) #f)))
|
||||
|
||||
|
|
|
|||
|
|
@ -15,38 +15,17 @@
|
|||
(define *board* (make-vector 16 1))
|
||||
(define *sequence* (make-vector 14 0))
|
||||
(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))
|
||||
(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))
|
||||
(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 *final* '())
|
||||
(vector-set! *board* 5 0)
|
||||
|
||||
(define (last-position)
|
||||
(do ((i 1 (+ i 1)))
|
||||
((or (= i 16) (= 1 (vector-ref *board* i)))
|
||||
(if (= i 16) 0 i))))
|
||||
|
||||
(define (try i depth)
|
||||
(define (ttry i depth)
|
||||
(cond ((= depth 14)
|
||||
(let ((lp (last-position)))
|
||||
(if (not (member lp *final*))
|
||||
|
|
@ -63,7 +42,7 @@
|
|||
(vector-set! *sequence* depth i)
|
||||
(do ((j 0 (+ j 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 *b* i) 1)
|
||||
(vector-set! *board* (vector-ref *c* i) 0) '())
|
||||
|
|
@ -72,11 +51,33 @@
|
|||
(define (gogogo i)
|
||||
(let ((*answer* '())
|
||||
(*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))
|
||||
|
||||
(time (let loop ((n 10000))
|
||||
(time (let loop ((n 100000))
|
||||
(if (zero? n)
|
||||
'done
|
||||
(begin
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user