even more benchmark scaffolding

svn: r17884

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

@@ -157,6 +157,89 @@ exec mzscheme -qu "$0" ${1+"$@"}
     (clean-up-sps bm)
     (system "rm -rf ~/.ikarus"))
 
+  (define (run-scheme48 bm)
+    (parameterize ([current-input-port
+                    (open-input-string
+                     (format
+                      ",bench on\n,open time bitwise\n,load \"scheme48-prelude.sch\"\n,load \"~a.sch\"\n,exit\n"
+                      bm))])
+      (system "scheme48 -h 20000000")))
+
+  (define (extract-scheme48-times bm str)
+    (let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+)" str)]
+          ;; `time' result is 10s of milliseconds? OS ticks, maybe?
+          [msec/tick 10])
+      (list (bytes->number (cadr m))
+            (bytes->number (caddr m))
+            0)))
+
+  (define (mk-mit bm)
+    (with-output-to-file (format "~a.scm" bm)
+      #:exists 'truncate
+      (lambda ()
+        (printf "(declare (usual-integrations))\n")
+        (call-with-input-file "mit-prelude.sch" 
+          (lambda (in) (copy-port in (current-output-port))))
+        (call-with-input-file (format "~a.sch" bm)
+          (lambda (in) (copy-port in (current-output-port))))))
+    (parameterize ([current-input-port 
+                    (open-input-string
+                     (format "(cf \"~a\")\n" bm))]
+                   [current-output-port (open-output-nowhere)])
+      (system "mit-scheme")))
+
+  (define (run-mit bm)
+    (parameterize ([current-input-port 
+                    (open-input-string
+                     (format "(load \"~a\")\n(exit)\ny\n" bm))])
+      (system "mit-scheme --heap 12000")))
+
+  (define (clean-up-mit bm)
+    (delete-file (format "~a.com" bm))
+    (delete-file (format "~a.ext" bm))
+    (delete-file (format "~a.bci" bm))
+    (delete-file (format "~a.bin" bm))
+    (delete-file (format "~a.scm" bm)))
+
+  (define (extract-mit-times bm str)
+    (let ([m (regexp-match #rx#"cpu: ([0-9]+) real: ([0-9]+) gc: ([0-9]+)" str)]
+          ;; `time' result is 10s of milliseconds? OS ticks, maybe?
+          [msec/tick 10])
+      (list (bytes->number (cadr m))
+            (bytes->number (caddr m))
+            (bytes->number (cadddr m)))))
+
+  (define (run-petite bm)
+    (parameterize ([current-input-port
+                    (open-input-string
+                     (format
+                      "(load \"petite-prelude.sch\")\n(load \"~a.sch\")\n(exit)\n"
+                      bm))])
+      (system "petite")))
+
+  (define (extract-petite-times bm str)
+    (let ([m (regexp-match #rx#"([0-9]+) ms elapsed cpu time(?:, including ([0-9]+) ms collecting)?[ \n]* ([0-9]+) ms elapsed real time" str)])
+      (list (bytes->number (cadr m))
+            (bytes->number (cadddr m))
+            (if (caddr m) (bytes->number (caddr m)) 0))))
+
+  (define (run-guile bm)
+    (parameterize ([current-input-port
+                    (open-input-string
+                     (format
+                      "(load \"guile-prelude.sch\")\n(load \"~a.sch\")\n"
+                      bm))])
+      (system "guile")))
+
+  (define (extract-guile-times bm str)
+    (let ([m (regexp-match #rx#"user: ([0-9]+) system: ([0-9]+) real: ([0-9]+) gc: ([0-9]+)" str)]
+          ;; `time' result is 10s of milliseconds? OS ticks, maybe?
+          [msec/tick 10])
+      (list (+ (bytes->number (cadr m))
+               (bytes->number (caddr m)))
+            (bytes->number (cadddr m))
+            (bytes->number (cadddr (cdr m))))))
+
   (define (extract-times bm str)
     str)
 
@@ -345,7 +428,36 @@ exec mzscheme -qu "$0" ${1+"$@"}
                 run-ikarus
                 extract-ikarus-times
                 clean-up-ikarus
-                '(takr))))
+                '(takr))
+     (make-impl 'mit
+                void
+                mk-mit
+                run-mit
+                extract-mit-times
+                clean-up-mit
+                '(nucleic2 puzzle takr2))
+     (make-impl 'scheme48
+                void
+                void
+                run-scheme48
+                extract-scheme48-times
+                void
+                '())
+     (make-impl 'petite
+                void
+                void
+                run-petite
+                extract-petite-times
+                void
+                '())
+     (make-impl 'guile
+                void
+                void
+                run-guile
+                extract-guile-times
+                void
+                '(dynamic dynamic2))
+))
 
   (define obsolte-impls '(mzscheme3m mzschemecgc mzscheme-j mzschemecgc-j mzschemecgc-tl mzc mz-old))
 

collects/tests/mzscheme/benchmarks/common/guile-prelude.sch

@@ -0,0 +1,29 @@
+
+(use-syntax (ice-9 syncase))
+
+(define (msecs v)
+  (quotient (* v 1000) internal-time-units-per-second))
+
+(define (time* thunk)
+  (let ((start (times))
+        (start-gc (gc-run-time)))
+    (let ((v (thunk)))
+      (let ((end (times))
+            (end-gc (gc-run-time)))
+        (display "user: ")
+        (display (msecs (- (tms:utime end) (tms:utime start))))
+        (display " system: ")
+        (display (msecs (- (tms:stime end) (tms:stime start))))
+        (display " real: ")
+        (display (msecs (- (tms:stime end) (tms:stime start))))
+        (display " gc: ")
+        (display (msecs (- end-gc start-gc)))
+        (newline)))))
+
+(define-syntax time
+  (syntax-rules ()
+    ((_ expr) (time* (lambda () expr)))))
+
+(define bitwise-and logand)
+(define bitwise-ior logior)
+(define bitwise-not lognot)

collects/tests/mzscheme/benchmarks/common/index-template.html

@@ -1,11 +1,14 @@
 <html>
-<head><title>Some Scheme Benchmarks</title></head>
+<head><title>Some Scheme Benchmarks: Compilers</title></head>
 <body>
 
 <H1>About the Benchmarks</H1>
 
-<p>The <a href="Benchmarks.html">benchmark page</a> shows some benchmark results on a collection of fairly standard
+<p>The <a href="Benchmarks.html">benchmark page</a> shows some
-   (mostly Gabriel) Scheme benchmarks.</p>
+   benchmark results on a collection of fairly standard (mostly
+   Gabriel) Scheme benchmarks. (See also the
+   extended <a href="../log3/Benchmarks.html">compilers and
+   interepreters</a> results.)</p>
 
 <p>Tables show relative performance, with the actual time for the
    fastest run shown on the left. So, by
@@ -22,7 +25,7 @@ time.</font></p>
 
 <p>Run times are averaged over three runs. All reported times are CPU time (system plus user).
    The times are based on the output of the implementation's <tt>time</tt> 
-   syntactic form for function.</p>
+   syntactic form or similar functions.</p>
 
 <p>Machine:
 <ul>
@@ -31,12 +34,13 @@ time.</font></p>
 
 <p>Compiler configurations:
 <ul>
-<li> Bigloo (3.3a): <tt>-06 -call/cc -copt -O3 -copt -fomit-frame-pointer</tt></il>
+<li> Bigloo (3.3a): <tt>-06 -call/cc -copt -O3 -copt -fomit-frame-pointer</tt></li>
-<li> Chicken (4.3.0): <tt>-no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift</tt></il>
+<li> Chicken (4.3.0): <tt>-no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift</tt></li>
 <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> MIT (7.7.90+): <tt>(declare (usual-integrations))</tt>; run with <tt>--heap 12000</tt></li>
 <li> PLT (4.2.4): in <tt>module</tt>; for benchmarks that use <tt>set-car!</tt> and <tt>set-cdr!</tt>, 
      PLT's R5RS support is used</li>
 </ul>

collects/tests/mzscheme/benchmarks/common/mit-prelude.sch

@@ -0,0 +1,31 @@
+
+(declare (usual-integrations))
+
+(define-syntax time
+  (syntax-rules ()
+    ((_ expr)
+     (with-timings
+      (lambda () expr)
+      (lambda (run-time gc-time real-time)
+        (display "cpu: ")
+        (display run-time)
+        (display " real: ")
+        (display real-time)
+        (display " gc: ")
+        (display gc-time)
+        (newline))))))
+
+(define-integrable (bitwise-and a b)
+  (if (and (fix:fixnum? a)
+           (fix:fixnum? b))
+      (fix:and a b)
+      0))
+(define-integrable (bitwise-ior a b)
+  (if (and (fix:fixnum? a)
+           (fix:fixnum? b))
+      (fix:or a b)
+      0))
+(define-integrable (bitwise-not a)
+  (if (fix:fixnum? a)
+      (fix:not a)
+      0))

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

@@ -3505,4 +3505,4 @@
 
 ; To run program, evaluate: (run)
 
-(time (let loop ([i 10]) (if (zero? i) 'done (begin (run) (loop (- i 1))))))
+(time (let loop ((i 10)) (if (zero? i) 'done (begin (run) (loop (- i 1))))))

collects/tests/mzscheme/benchmarks/common/petite-prelude.sch

@@ -0,0 +1,4 @@
+
+(define bitwise-and logand)
+(define bitwise-ior logior)
+(define bitwise-not lognot)

collects/tests/mzscheme/benchmarks/common/scheme48-prelude.sch

@@ -0,0 +1,22 @@
+(define (time* thunk)
+   (let ((start-cpu (run-time))
+         (start-real (real-time)))
+     (let ((result (thunk)))
+       (let ((end-cpu (run-time))
+             (end-real (real-time)))
+         (let ((cpu (- end-cpu start-cpu))
+               (real (- end-real start-real)))
+           (display "cpu time: ")
+           (display cpu)
+           (display " real time: ")
+           (display real)
+           (newline)
+           result)))))
+
+(define-syntax time
+  (syntax-rules ()
+    ((_ expr) (time* (lambda () expr)))))
+
+(define (error . args) (+ 1 args))
+
+

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

@@ -26,6 +26,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
   (define nongc (make-parameter #f))
   (define subtract-nothing (make-parameter #f))
   (define generate-graph (make-parameter #f))
+  (define no-compile-time (make-parameter #f))
 
   (command-line
    "tabulate"
@@ -37,6 +38,8 @@ exec mzscheme -qu "$0" ${1+"$@"}
      (include-links #t)]
     [("--multi") name "generate multiple pages for different views of data"
      (base-link-filename name)]
+    [("--no-compile-time") "do not show compile times"
+     (no-compile-time #t)]
     [("--nongc") "show times not including GC"
      (nongc #t)]
     [("--index") "generate full page with an index.html link"
@@ -87,7 +90,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
                                                 (car runs)
                                                 #f)])
                                         (if a
-                                            (cadadr a)
+                                            (cadar a)
                                             0))
                                       0)])
                              (max (- (or (cadadr runs) 0)
@@ -266,6 +269,27 @@ exec mzscheme -qu "$0" ${1+"$@"}
         (proc fastest n-fastest c-fastest relative-to
               base n-base c-base))))
 
+  (define (bar-group name content)
+    `(tr ((style "background-color: #eeeeee"))
+         (td ((valign "top")) ,(symbol->string name))
+         (td
+          (table
+           ((style "border-spacing: 0px;"))
+           ,@(content)))))
+
+  (define (bar-plot impl n ratio)
+    `(tr (td (span ((style "font-size: small;")) 
+                   ,(symbol->string impl))
+             nbsp)
+         (td ((style "padding: 0em;"))
+             ,(if (and n ratio)
+                  (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 ratio)))
+                                                      1)
+                                                 #\x))))
+                  ""))))
+
   (define (generate-page relative-to grouping graph? has-other?)
     (empty-tag-shorthand html-empty-tags)
     (write-xml/content 
@@ -297,7 +321,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
                                                 0]
                                                [else (add1 (loop (cdr impls)))]))])
                                 (cons
-                                 `(td ((colspan ,(number->string (* 2 (+ 1 count))))
+                                 `(td ((colspan ,(number->string (* (if (no-compile-time) 1 2) (+ 1 count))))
                                        (align "center")
                                        (bgcolor "#DDDDFF"))
                                       (b ,(if (equal? s relative-to)
@@ -315,7 +339,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
                                  ,(if (eq? grouping 'mode)
                                       "impl"
                                       "mode")))))
-                 (td ((colspan "2") (align "right")) 
+                 (td ((colspan ,(if (no-compile-time) "1" "2")) (align "right")) 
                      ,(if (and (base-link-filename)
                                relative-to)
                           `(a ((href ,(fixup-filename
@@ -325,7 +349,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
                               "fastest")
                           "fastest"))
                  ,@(map (lambda (impl)
-                          `(td ((colspan "2") (align "right")) 
+                          `(td ((colspan ,(if (no-compile-time) "1" "2")) (align "right")) 
                                (b ,(let ([s (extract-column impl (opposite grouping))])
                                      (if (and (base-link-filename)
                                               (not (eq? impl relative-to)))
@@ -357,12 +381,14 @@ exec mzscheme -qu "$0" ${1+"$@"}
                                                            (car bm-run))))
                                            ,(symbol->string (car bm-run)))
                                        (symbol->string (car bm-run))))
-                              (td ((align "right"))
+                              ,@(if (no-compile-time)
-                                  nbsp
+                                    null
-                                  ,(small (if (= c-fastest forever)
+                                    `((td ((align "right"))
-                                              " "
+                                          nbsp
-                                              (number->string c-fastest)))
+                                          ,(small (if (= c-fastest forever)
-                                  nbsp)
+                                                      " "
+                                                      (number->string c-fastest)))
+                                          nbsp)))
                               (td ((align "right"))
                                   ,(format "~a ms" fastest)
                                   nbsp nbsp)
@@ -372,14 +398,17 @@ exec mzscheme -qu "$0" ${1+"$@"}
                                         (let* ([a (assq impl (cdr bm-run))]
                                                [n (and a (caadr a))]
                                                [n2 (and a (ntime a))])
-                                          `(,(if (= c-fastest forever)
+                                          `(,@(if (no-compile-time)
-                                                 `(td)
+                                                  null
-                                                 `(td ((align "right")
+                                                  (list
-                                                       (bgcolor ,(lookup-color impl)))
+                                                   (if (= c-fastest forever)
-                                                      ,(if (and a (caddr a) c-base (positive? c-base))
+                                                       `(td)
-                                                           (small (ratio->string (/ (caddr a) c-base)))
+                                                       `(td ((align "right")
-                                                           '"-")
+                                                             (bgcolor ,(lookup-color impl)))
-                                                      nbsp))
+                                                            ,(if (and a (caddr a) c-base (positive? c-base))
+                                                                 (small (ratio->string (/ (caddr a) c-base)))
+                                                                 '"-")
+                                                            nbsp))))
                                             (td ((bgcolor ,(if (and n base (= n base)
                                                                     (or (not orig-relative-to)
                                                                         (and (string? orig-relative-to)
@@ -421,6 +450,36 @@ exec mzscheme -qu "$0" ${1+"$@"}
                      ,@(if has-other?
                            `(nbsp nbsp (a ((href ,(output-name #f 'impl #f))) "Back to tables"))
                            null)))
+             ,(let* ([bm-runs (filter (lambda (bm-run)
+                                        (andmap (lambda (impl)
+                                                  (let ([a (assq impl (cdr bm-run))])
+                                                    (and a (caadr a))))
+                                                sorted-impls))
+                                      sorted-runs)]
+                     [rel-vals (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)
+                                         (map (lambda (impl)
+                                                (let* ([a (assq impl (cdr bm-run))]
+                                                       [n (and a (caadr a))])
+                                                  (list impl (if (zero? n) 1 (/ base n)))))
+                                              sorted-impls))))
+                                    bm-runs)]
+                     [avgs (map (lambda (impl)
+                                  (let ([vals (map (lambda (rel-val) (cadr (assq impl rel-val)))
+                                                   rel-vals)])
+                                    (sqrt (apply + (map (lambda (x) (* x x)) vals)))))
+                                sorted-impls)]
+                     [max-avg (apply max avgs)])
+                (bar-group 'geometric-mean
+                           (lambda ()
+                             (map (lambda (impl avg)
+                                    (bar-plot impl 1 (inexact->exact (/ avg max-avg))))
+                                  sorted-impls avgs))))
              ,@(map (lambda (bm-run)
                       (call-with-bm-info
                        bm-run
@@ -428,27 +487,16 @@ exec mzscheme -qu "$0" ${1+"$@"}
                        grouping
                        (lambda (fastest n-fastest c-fastest relative-to
                                         base n-base c-base)
-                         `(tr ((style "background-color: #eeeeee"))
+                         (bar-group
-                              (td ((valign "top")) ,(symbol->string (car bm-run)))
+                          (car bm-run)
-                              (td
+                          (lambda () 
-                               (table
+                            (map (lambda (impl)
-                                ((style "border-spacing: 0px;"))
+                                   (let* ([a (assq impl (cdr bm-run))]
-                                ,@(map (lambda (impl)
+                                          [n (and a (caadr a))]
-                                         (let* ([a (assq impl (cdr bm-run))]
+                                          [n2 (and a (ntime a))])
-                                                [n (and a (caadr a))]
+                                     (bar-plot impl n (and n base (not (zero? n))
-                                                [n2 (and a (ntime a))])
+                                                           (/ base n)))))
-                                           `(tr (td (span ((style "font-size: small;")) 
+                                 sorted-impls))))))
-                                                          ,(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))