automate

svn: r4054

collects/tests/mzscheme/benchmarks/common/README.txt

@@ -1,4 +1,22 @@
-Bechmarks obtained from
+To run a benchmark:
+ mzscheme -qu auto.ss <impl-or-benchmark> ...
+where <impl-or-benchmark> names an implementation as one of
+   mzscheme
+   mzscheme3m
+   bigloo
+   chicken
+   gambit
+   larceny
+or a benchmark as one of
+   conform
+   cpstack
+   ctak
+   ...
+Naming no implementation/benchmark causes all of them to be run.
+The output is series of lines of the form
+  [<impl> <benchmark> (<cpu-msec> <real-msec> <gc-msec>) <compile-msec>]
+
+The bechmarks were obtained from
  http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/code/bench/gabriel/
  http://www.ccs.neu.edu/home/will/GC/sourcecode.html
 

collects/tests/mzscheme/benchmarks/common/auto.ss

@@ -0,0 +1,204 @@
+#!/bin/sh
+#|
+exec mzscheme -qu "$0" ${1+"$@"}
+|#
+
+(module auto mzscheme
+  (require (lib "process.ss")
+           (lib "cmdline.ss"))
+
+  (define (bytes->number b)
+    (string->number (bytes->string/latin-1 b)))
+
+  (define ((run-mk script) bm)
+    (when (file-exists? (symbol->string bm))
+      (delete-file (symbol->string bm)))
+    (parameterize ([current-command-line-arguments (vector (symbol->string bm))])
+      (load script)))
+
+  (define (mk-mzscheme bm)
+    ;; To get compilation time:
+    (parameterize ([current-namespace (make-namespace)])
+      (load (format "~a.ss" bm))))
+
+  (define (mk-mzc bm)
+    (system (format "mzc ~a.ss" bm)))
+
+  (define (run-exe bm)
+    (system (symbol->string bm)))
+
+  (define (run-exe/time bm)
+    (system (format "time ~a" bm)))
+
+  (define (run-gambit-exe bm)
+    (system (format "~a -:d-" bm)))
+
+  (define (extract-times bm str)
+    str)
+
+  (define (extract-gambit-times bm str)
+    (let ([m (regexp-match (byte-regexp
+                            (bytes-append
+                             #"([0-9]+) ms real.*[^0-9]"
+                             #"([0-9]+) ms cpu.*"
+                             #"(?:no collections|collections? accounting for ([0-9]+) ms.*)"))
+                           str)])
+      (map bytes->number
+           (list (caddr m)
+                 (cadr m)
+                 (or (cadddr m) #"0")))))
+
+  (define (extract-mzscheme-times bm str)
+    (let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)])
+      (map bytes->number (cdr m))))
+
+  (define (extract-chicken-times bm str)
+    (let ([m (regexp-match #rx#"([0-9.]+) seconds.*[^0-9.]([0-9.]+) seconds" str)])
+      (list (* 1000 (string->number (format "#e~a" (cadr m))))
+            #f
+            (* 1000 (string->number (format "#e~a" (caddr m)))))))
+
+  (define (extract-time-times bm str)
+    (let ([m (regexp-match #rx#"real[ \t]+([0-9m.]+)s.*user[ \t]+([0-9m.]+)s.sys[ \t]+([0-9m.]+)s." str)]
+          [ms->milliseconds (lambda (s)
+                              (let ([m (regexp-match "([0-9]+)m([0-9.]+)" s)])
+                                (+ (* 60000 (string->number (format "~a" (cadr m))))
+                                   (* 1000 (string->number (format "#e~a" (caddr m)))))))])
+      (let ([real (ms->milliseconds (cadr m))]
+            [user (ms->milliseconds (caddr m))]
+            [sys (ms->milliseconds (cadddr m))])
+        (list (+ user sys) real #f))))
+
+  (define-struct impl (name make run extract-result skips))
+
+  (define impls
+    (list
+     (make-impl 'mzscheme
+                mk-mzscheme
+                (lambda (bm)
+                  (system (format "mzscheme -qu ~a.ss" bm)))
+                extract-mzscheme-times
+                '())
+     (make-impl 'mzscheme3m
+                mk-mzscheme
+                (lambda (bm)
+                  (system (format "mzscheme3m -qu ~a.ss" bm)))
+                extract-mzscheme-times
+                '())
+     (make-impl 'mzc
+                mk-mzc
+                (lambda (bm)
+                  (system (format "mzscheme -mvqe '(load-extension \"~a.dylib\")'" bm)))
+                extract-mzscheme-times
+                '())
+     (make-impl 'mzscheme-no-jit
+                mk-mzscheme
+                (lambda (bm)
+                  (system (format "mzscheme -jqu ~a.ss" bm)))
+                extract-mzscheme-times
+                '())
+     (make-impl 'chicken
+                (run-mk "mk-chicken.ss")
+                run-exe
+                extract-chicken-times
+                '(nucleic2))
+     (make-impl 'bigloo
+                (run-mk "mk-bigloo.ss")
+                run-exe/time
+                extract-time-times
+                '(cpstack ctak puzzle triangle))
+     (make-impl 'gambit
+                (run-mk "mk-gambit.ss")
+                run-gambit-exe
+                extract-gambit-times
+                '(nucleic2))))
+
+  (define benchmarks
+    '(conform
+      cpstack
+      ctak
+      deriv
+      dderiv
+      destruct
+      div
+      dynamic
+      earley
+      fft
+      nboyer
+      nfa
+      nucleic2
+      puzzle
+      sboyer
+      sort1
+      tak
+      takl
+      takr
+      triangle))
+
+  (define num-iterations 3)
+
+  (define (run-benchmark impl bm)
+    (let ([i (ormap (lambda (i)
+                      (and (eq? impl (impl-name i))
+                           i))
+                    impls)])
+      (if (memq bm (impl-skips i))
+          (printf "[~a ~a ~s 0]\n" impl bm '(#f #f #f))
+          (let ([start (current-inexact-milliseconds)])
+            ((impl-make i) bm)
+            (let ([end (current-inexact-milliseconds)])
+              (let loop ([n num-iterations])
+                (unless (zero? n)
+                  (let ([out (open-output-bytes)]
+                        [in (open-input-bytes #"0\n")])
+                    (unless (parameterize ([current-output-port out]
+                                           [current-error-port out]
+                                           [current-input-port in])
+                              ((impl-run i) bm))
+                      (error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm))
+                    (printf "[~a ~a ~s ~a]\n"
+                            impl
+                            bm
+                            ((impl-extract-result i) bm (get-output-bytes out))
+                            (inexact->exact (round (- end start)))))
+                  (loop (sub1 n)))))))))
+
+  (define run-benchmarks #f)
+  (define run-implementations #f)
+
+  (define args
+    (command-line
+     "auto"
+     (current-command-line-arguments)
+     (once-each
+      [("-n" "--iters") n "set number of run iterations"
+       (let ([v (string->number n)])
+         (unless (and (number? v)
+                      (exact? v)
+                      (positive? v))
+           (error 'auto "bad interation count: ~a" n))
+         (set! num-iterations v))])
+     (args impl-or-benchmark impl-or-benchmark)))
+
+  (for-each (lambda (arg)
+              (let ([s (string->symbol arg)])
+                (cond
+                 [(memq s (map impl-name impls))
+                  (set! run-implementations
+                        (append (or run-implementations null)
+                                (list s)))]
+                 [(memq s benchmarks)
+                  (set! run-benchmarks
+                        (append (or run-benchmarks null)
+                                (list s)))]
+                 [else
+                  (error 'auto "mysterious argument: ~a" arg)])))
+            args)
+
+  (map (lambda (impl)
+         (map (lambda (bm)
+                (run-benchmark impl bm))
+              (or run-benchmarks
+                  benchmarks)))
+       (or run-implementations
+           (map impl-name impls))))

collects/tests/mzscheme/benchmarks/common/dderiv.ss

@@ -1,99 +1,2 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; File:         dderiv.sch
-; Description:  DDERIV benchmark from the Gabriel tests
-; Author:       Vaughan Pratt
-; Created:      8-Apr-85
-; Modified:     10-Apr-85 14:53:29 (Bob Shaw)
-;               23-Jul-87 (Will Clinger)
-;               9-Feb-88 (Will Clinger)
-; Language:     Scheme (but see note below)
-; Status:       Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 
-; Note:  This benchmark uses property lists.  The procedures that must
-; be supplied are get and put, where (put x y z) is equivalent to Common
-; Lisp's (setf (get x y) z).
-
-;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
- 
-;;; This benchmark is a variant of the simple symbolic derivative program
-;;; (DERIV). The main change is that it is `table-driven.'  Instead of using a
-;;; large COND that branches on the CAR of the expression, this program finds
-;;; the code that will take the derivative on the property list of the atom in
-;;; the CAR position. So, when the expression is (+ . <rest>), the code
-;;; stored under the atom '+ with indicator DERIV will take <rest> and
-;;; return the derivative for '+. The way that MacLisp does this is with the
-;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
-;;; atomic name in that it expects an argument list and the compiler compiles
-;;; code, but the name of the function with that code is stored on the
-;;; property list of FOO under the indicator BAR, in this case. You may have
-;;; to do something like:
- 
-;;; :property keyword is not Common Lisp.
- 
-; Returns the wrong answer for quotients.
-; Fortunately these aren't used in the benchmark.
- 
-(module dderiv mzscheme
-
-(define pg-alist '())
-(define (put sym d what)
-  (set! pg-alist (cons (cons sym what) pg-alist)))
-(define (get sym d)
-  (cdr (assq sym pg-alist)))
-
-(define (dderiv-aux a)
-  (list '/ (dderiv a) a))
- 
-(define (+dderiv a)
-  (cons '+ (map dderiv a)))
- 
-(put '+ 'dderiv +dderiv)    ; install procedure on the property list
- 
-(define (-dderiv a)
-  (cons '- (map dderiv a)))
- 
-(put '- 'dderiv -dderiv)    ; install procedure on the property list
- 
-(define (*dderiv a)
-  (list '* (cons '* a)
-        (cons '+ (map dderiv-aux a))))
- 
-(put '* 'dderiv *dderiv)    ; install procedure on the property list
- 
-(define (/dderiv a)
-  (list '-
-        (list '/
-              (dderiv (car a))
-              (cadr a))
-        (list '/
-              (car a)
-              (list '*
-                    (cadr a)
-                    (cadr a)
-                    (dderiv (cadr a))))))
- 
-(put '/ 'dderiv /dderiv)    ; install procedure on the property list
- 
-(define (dderiv a)
-  (cond
-    ((not (pair? a))
-     (cond ((eq? a 'x) 1) (else 0)))
-    (else (let ((dderiv (get (car a) 'dderiv)))
-         (cond (dderiv (dderiv (cdr a)))
-               (else 'error))))))
- 
-(define (run)
-  (do ((i 0 (+ i 1)))
-      ((= i 10000))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
- 
-;;; call:  (run)
- 
-(time (run))
-)
 
+(module dderiv "wrap.ss")

collects/tests/mzscheme/benchmarks/common/div.sch

@@ -0,0 +1,51 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File:         div.sch
+; Description:  DIV benchmarks
+; Author:       Richard Gabriel
+; Created:      8-Apr-85
+; Modified:     19-Jul-85 18:28:01 (Bob Shaw)
+;               23-Jul-87 (Will Clinger)
+; Language:     Scheme
+; Status:       Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ 
+;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
+;;; This file contains a recursive as well as an iterative test.
+
+(define (create-n n)
+  (do ((n n (- n 1))
+       (a '() (cons '() a)))
+      ((= n 0) a)))
+ 
+(define *ll* (create-n 200))
+ 
+(define (iterative-div2 l)
+  (do ((l l (cddr l))
+       (a '() (cons (car l) a)))
+      ((null? l) a)))
+ 
+(define (recursive-div2 l)
+  (cond ((null? l) '())
+        (else (cons (car l) (recursive-div2 (cddr l))))))
+ 
+(define (test-1 l)
+  (do ((i 3000 (- i 1)))
+      ((= i 0))
+    (iterative-div2 l)
+    (iterative-div2 l)
+    (iterative-div2 l)
+    (iterative-div2 l)))
+ 
+(define (test-2 l)
+  (do ((i 3000 (- i 1)))
+      ((= i 0))
+    (recursive-div2 l)
+    (recursive-div2 l)
+    (recursive-div2 l)
+    (recursive-div2 l)))
+ 
+;;; for the iterative test call: (test-1 *ll*)
+;;; for the recursive test call: (test-2 *ll*)
+ 
+(time (cons (test-1 *ll*)
+            (test-2 *ll*)))

collects/tests/mzscheme/benchmarks/common/div.ss

@@ -1,54 +1,2 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; File:         div.sch
-; Description:  DIV benchmarks
-; Author:       Richard Gabriel
-; Created:      8-Apr-85
-; Modified:     19-Jul-85 18:28:01 (Bob Shaw)
-;               23-Jul-87 (Will Clinger)
-; Language:     Scheme
-; Status:       Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 
-;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
-;;; This file contains a recursive as well as an iterative test.
-
-(module div mzscheme  
-(define (create-n n)
-  (do ((n n (- n 1))
-       (a '() (cons '() a)))
-      ((= n 0) a)))
- 
-(define *ll* (create-n 200))
- 
-(define (iterative-div2 l)
-  (do ((l l (cddr l))
-       (a '() (cons (car l) a)))
-      ((null? l) a)))
- 
-(define (recursive-div2 l)
-  (cond ((null? l) '())
-        (else (cons (car l) (recursive-div2 (cddr l))))))
- 
-(define (test-1 l)
-  (do ((i 3000 (- i 1)))
-      ((= i 0))
-    (iterative-div2 l)
-    (iterative-div2 l)
-    (iterative-div2 l)
-    (iterative-div2 l)))
- 
-(define (test-2 l)
-  (do ((i 3000 (- i 1)))
-      ((= i 0))
-    (recursive-div2 l)
-    (recursive-div2 l)
-    (recursive-div2 l)
-    (recursive-div2 l)))
- 
-;;; for the iterative test call: (test-1 *ll*)
-;;; for the recursive test call: (test-2 *ll*)
- 
-(time (test-1 *ll*))
-(time (test-2 *ll*))
-)
 
+(module div "wrap.ss")

collects/tests/mzscheme/benchmarks/common/input.txt

@@ -0,0 +1 @@
+1

collects/tests/mzscheme/benchmarks/common/mk-bigloo.ss

@@ -11,7 +11,7 @@
     (newline))
   'truncate/replace)
 
-(when (system (format "bigloo -o ~a -O6 ~a.scm"
+(when (system (format "bigloo -w -o ~a -O6 ~a.scm"
                       name name))
   (delete-file (format "~a.scm" name))
   (delete-file (format "~a.o" name)))

collects/tests/mzscheme/benchmarks/common/mk-chicken.ss

@@ -2,5 +2,5 @@
 
 (define name (vector-ref (current-command-line-arguments) 0))
 
-(system (format "csc -no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift ~a.sch" 
+(system (format "csc -no-warnings -no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift ~a.sch" 
                 name))

collects/tests/mzscheme/benchmarks/common/sort1.sch

@@ -128,6 +128,10 @@
 
     sort))
 
+(define *rand* 21)
+(define (random m)
+  (set! *rand* (remainder (* *rand* 17) m))
+  *rand*)
 
 (define (rgen n m)
   (let loop ((n n) (l '()))

collects/tests/mzscheme/benchmarks/common/tabulate.ss

@@ -0,0 +1,91 @@
+
+(module tabulate mzscheme
+  (require (lib "list.ss")
+           (lib "xml.ss" "xml"))
+  
+  (define bm-table (make-hash-table))
+  (define impls (make-hash-table))
+
+  (let loop ()
+    (let ([l (read)])
+      (unless (eof-object? l)
+        (hash-table-put! impls (car l) #t)
+        (let ([t (hash-table-get bm-table (cadr l)
+                                 (lambda ()
+                                   (let ([t (make-hash-table)])
+                                     (hash-table-put! bm-table (cadr l) t)
+                                     t)))])
+          (hash-table-put! t (car l) 
+                           (cons (cddr l)
+                                 (hash-table-get t (car l) null))))
+        (loop))))
+
+  (define bm-runs (hash-table-map bm-table cons))
+
+  (define (average sel l)
+    (if (andmap sel l)
+        (round (/ (apply + (map sel l)) (length l)))
+        (if (ormap sel l)
+            (error 'tabulate "inconsistent average info")
+            #f)))
+  
+  (define average-runs
+    (map (lambda (bm-run)
+           (cons
+            (car bm-run)
+            (map (lambda (runs)
+                   (list (car runs)
+                         (list (average caar (cdr runs))
+                               (average cadar (cdr runs))
+                               (average caddar (cdr runs)))
+                         (cadadr runs)))
+                 (hash-table-map (cdr bm-run) cons))))
+         bm-runs))
+
+  (define (symbol<? a b)
+    (string<? (symbol->string a)
+              (symbol->string b)))
+
+  (define sorted-runs 
+    (sort average-runs (lambda (a b)
+                         (symbol<? (car a) (car b)))))
+
+  (define sorted-impls
+    (sort (hash-table-map impls (lambda (k v) k)) symbol<?))
+
+  (define (ratio->string r)
+    (if (integer? r)
+        (number->string r)
+        (let ([s (format "~a00" (exact->inexact r))])
+          (car (regexp-match #rx"^[0-9]*[.].." s)))))
+
+  (empty-tag-shorthand html-empty-tags)
+  (write-xml/content 
+   (xexpr->xml 
+    `(html
+      (head (title "Benchmark Results"))
+      (body
+       (table
+        (tr (td nbsp) 
+            (td nbsp)
+            ,@(map (lambda (impl)
+                     `(td (b ,(symbol->string impl)) nbsp))
+                   sorted-impls))
+        ,@(map (lambda (bm-run)
+                 (let ([fastest (apply min (map (lambda (run)
+                                                  (or (caadr run) 1000000000))
+                                                (cdr bm-run)))])
+                   `(tr (td (a ((href ,(format "~a.sch" (car bm-run))))
+                               ,(symbol->string (car bm-run))))
+                        (td ((align "right"))
+                            nbsp
+                            ,(format "~a ms" fastest) nbsp nbsp nbsp)
+                        ,@(map (lambda (impl)
+                                 (let* ([a (assq impl (cdr bm-run))]
+                                        [n (and a (caadr a))])
+                                   `(td ,(if n
+                                             (ratio->string (/ n fastest))
+                                             "-"))))
+                               sorted-impls))))
+               sorted-runs))))))
+  (newline))

collects/tests/mzscheme/benchmarks/common/tak.sch

@@ -20,6 +20,4 @@
  
 ;;; call: (tak 18 12 6)
  
-(time (tak 18 12 2))
-
-
+(time (tak 18 12 (if (with-input-from-file "input.txt" read) 2 0)))

collects/tests/mzscheme/benchmarks/common/takr.sch

@@ -517,5 +517,5 @@
  
 ;;; call:  (tak0 18 12 6)
  
-(time (tak0 18 12 2))
+(time (tak0 18 12 (if (with-input-from-file "input.txt" read) 2 0)))
 

collects/tests/mzscheme/benchmarks/common/triangle.sch

@@ -81,4 +81,4 @@
             'done
             (begin
               (gogogo 22)
-              (loop (sub1 n))))))
+              (loop (- n 1))))))