shootout benchmarks

svn: r10839

collects/tests/mzscheme/benchmarks/shootout/hello.ss

@@ -0,0 +1,2 @@
+#lang scheme/base
+(display "hello world\n")

collects/tests/mzscheme/benchmarks/shootout/k-nucleotide.ss

@@ -1,25 +1,20 @@
 ;;   The Computer Language Shootout
 ;;   http://shootout.alioth.debian.org/
 
-(module k-nucleotide mzscheme
-  (require mzlib/list
-           mzlib/string
-           (only srfi/13 string-pad-right))
+#lang scheme/base
 
-  (define (all-counts len dna)
-    (let ([table (make-hash-table)]
+(define (all-counts len dna)
+  (let ([table (make-hasheq)]
         [seq (make-string len)])
-      (let loop ([s (- (string-length dna) len)])
+    (for ([s (in-range (- (string-length dna) len) -1 -1)])
       (string-copy! seq 0 dna s (+ s len))
       (let ([key (string->symbol seq)])
-          (let ([cnt (hash-table-get table key 0)])
-            (hash-table-put! table key (add1 cnt))))
-        (unless (zero? s)
-          (loop (sub1 s))))
+        (let ([cnt (hash-ref table key 0)])
+          (hash-set! table key (add1 cnt)))))
     table))
 
-  (define (write-freqs table)
-    (let* ([content (hash-table-map table cons)]
+(define (write-freqs table)
+  (let* ([content (hash-map table cons)]
          [total (exact->inexact (apply + (map cdr content)))])
     (for-each
      (lambda (a)
@@ -28,34 +23,33 @@
                (real->decimal-string (* 100 (/ (cdr a) total)) 3)))
      (sort content (lambda (a b) (> (cdr a) (cdr b)))))))
 
-  (define (write-one-freq table key)
-    (let ([cnt (hash-table-get table key 0)])
+(define (write-one-freq table key)
+  (let ([cnt (hash-ref table key 0)])
     (printf "~a\t~a\n" cnt key)))
 
-  (define dna
-    (begin
+(define dna
+  (let ([in (current-input-port)])
     ;; Skip to ">THREE ..."
-      (regexp-match #rx#"(?m:^>THREE.*$)" (current-input-port))
+    (regexp-match #rx#"(?m:^>THREE.*$)" in)
     (let ([s (open-output-string)])
       ;; Copy everything but newlines to s:
       (let loop ()
-          (when (regexp-match #rx#"\n" (current-input-port) 0 #f s)
+        (when (regexp-match #rx#"\n" in 0 #f s)
           (loop)))
       ;; Extract the string from s:
       (string-upcase (get-output-string s)))))
 
-  ;; 1-nucleotide counts:
-  (write-freqs (all-counts 1 dna))
-  (newline)
+;; 1-nucleotide counts:
+(write-freqs (all-counts 1 dna))
+(newline)
 
-  ;; 2-nucleotide counts:
-  (write-freqs (all-counts 2 dna))
-  (newline)
+;; 2-nucleotide counts:
+(write-freqs (all-counts 2 dna))
+(newline)
 
-  ;; Specific sequences:
-  (for-each (lambda (seq)
+;; Specific sequences:
+(for-each (lambda (seq)
             (write-one-freq (all-counts (string-length seq) dna)
                             (string->symbol seq)))
           '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))
 
-  )

collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss

@@ -5,11 +5,8 @@
 ;; Derived from the Chicken variant, which was
 ;; Contributed by Anthony Borla
 
-;; Note: as of version 350, this benchmark spends much of
-;;  its time GCing; it runs 2 times as fast in mzscheme3m.
-
 ;; The version that uses complex number is a little
-;; more elegant, but slower:
+;; more elegant, but much slower:
 ;;  (define (mandelbrot iterations x y n ci)
 ;;    (let ((c (+ (- (/ (* 2.0 x) n) 1.5) 
 ;;                (* ci 0.0+1.0i))))
@@ -19,18 +16,16 @@
 ;;	 [(> (magnitude z) 2.0) 0]
 ;;	 [else (loop (add1 i) (+ (* z z) c))]))))
  
+#lang scheme/base
+(require scheme/cmdline)
 
-(module mandelbrot mzscheme
+(define +limit-sqr+ 4.0)
 
-  ;; -------------------------------
+(define +iterations+ 50)
 
-  (define +limit-sqr+ 4.0)
+;; -------------------------------
 
-  (define +iterations+ 50)
-
-  ;; -------------------------------
-  
-  (define (mandelbrot iterations x y n ci)
+(define (mandelbrot iterations x y n ci)
   (let ((cr (- (/ (* 2.0 x) n) 1.5)))
     (let loop ((i 0) (zr 0.0) (zi 0.0))
       (if (> i iterations)
@@ -39,13 +34,14 @@
                 (ziq (* zi zi)))
             (cond
              ((> (+ zrq ziq) +limit-sqr+) 0)
-	       (else (loop (add1 i) (+ (- zrq ziq) cr) (+ (* 2.0 (* zr zi)) ci)))))))))
+             (else (loop (add1 i) 
+                         (+ (- zrq ziq) cr) 
+                         (+ (* 2.0 (* zr zi)) ci)))))))))
 
-  ;; -------------------------------
+;; -------------------------------
 
-  (define (main args)
-    (let ((n (string->number (vector-ref args 0)))
-	  (out (current-output-port)))
+(define (main n)
+  (let ((out (current-output-port)))
 
     (fprintf out "P4\n~a ~a\n" n n)
 
@@ -71,10 +67,13 @@
 
                 (begin
                   (when (positive? bitnum)
-		      (write-byte (arithmetic-shift byteacc (- 8 (bitwise-and n #x7))) out))
+                    (write-byte (arithmetic-shift byteacc 
+                                                  (- 8 (bitwise-and n #x7))) 
+                                out))
 
                   (loop-y (add1 y))))))))))
 
-  ;; -------------------------------
+;; -------------------------------
 
-  (main (current-command-line-arguments)))
+(command-line #:args (n)
+              (main (string->number n)))

collects/tests/mzscheme/benchmarks/shootout/nbody.ss

@@ -146,8 +146,7 @@ Correct output N = 1000 is
   
   (printf "~a~%" (real->decimal-string (energy system) 9))
 
-  (do ((i 1 (+ i 1)))
-      ((< n i))
+  (for ([i (in-range 0 n)])
     (advance system 0.01))
   
   (printf "~a~%" (real->decimal-string (energy system) 9)))

collects/tests/mzscheme/benchmarks/shootout/nsieve.ss

@@ -7,44 +7,37 @@
 ;; Written by Dima Dorfman, 2004
 ;; Converted to MzScheme by Brent Fulgham
 
-(module nsieve mzscheme
-  (require (only srfi/13 string-index string-pad))
+#lang scheme/base
+(require scheme/cmdline)
 
-  (define (nsieve m)
+(define (nsieve m)
   (let ((a (make-vector m #t)))
     (let loop ((i 2) (n 0))
       (if (< i m)
-            (begin
           (if (vector-ref a i)
               (begin
                 (let clear ((j (+ i i)))
-		      (if (< j m)
-		          (begin
+                  (when (< j m)
                     (vector-set! a j #f)
-			    (clear (+ j i)))))
+                    (clear (+ j i))))
                 (loop (+ 1 i) (+ 1 n)))
-		  (loop (+ 1 i) n)))
+              (loop (+ 1 i) n))
           n))))
 
-  (define (test n)
+(define (string-pad s len)
+  (string-append (make-string (- len (string-length s)) #\space)
+                 s))
+
+(define (test n)
   (let* ((m (* (expt 2 n) 10000))
          (count (nsieve m)))
-      (printf "Primes up to ~a ~a~%"
+    (printf "Primes up to ~a ~a\n"
             (string-pad (number->string m) 8)
             (string-pad (number->string count) 8))))
 
-  (define (main args)
-    (if (< (vector-length args) 1)
-        (begin
-          (display "An argument is required") (newline) 2)
-        (let ((n (string->number (vector-ref args 0))))
-	  (if (not n)
-	      (begin
-                (display "An integer is required") (newline) 2)
-	      (begin
-	        (if (>= n 0) (test n))
-	        (if (>= n 1) (test (- n 1)))
-	        (if (>= n 2) (test (- n 2)))
-	         0)))))
+(define (main n)
+  (when (>= n 0) (test n))
+  (when (>= n 1) (test (- n 1)))
+  (when (>= n 2) (test (- n 2))))
 
-  (main (current-command-line-arguments)))
+(command-line #:args (n) (main (string->number n)))

collects/tests/mzscheme/benchmarks/shootout/nsievebits.ss

@@ -4,11 +4,11 @@
 ;;
 ;; Adapted from CMUCL code by Dima Dorfman; bit-vector stuff by Alex Shinn;
 ;; cobbled together by felix, converted to MzScheme by Brent Fulgham
-;; Note:  Requires MzScheme 299+
 
-(module nsievebits mzscheme
+#lang scheme/base
+(require scheme/cmdline)
 
-  (define (make-bit-vector size)
+(define (make-bit-vector size)
   (let* ((len (quotient (+ size 7) 8))
          (res (make-bytes len #b11111111)))
     (let ((off (remainder size 8)))
@@ -16,14 +16,14 @@
         (bytes-set! res (- len 1) (- (arithmetic-shift 1 off) 1))))
     res))
 
-  (define (bit-vector-ref vec i)
+(define (bit-vector-ref vec i)
   (let ((byte (arithmetic-shift i -3))
         (off (bitwise-and i #x7)))
     (and (< byte (bytes-length vec))
          (not (zero? (bitwise-and (bytes-ref vec byte)
                                   (arithmetic-shift 1 off)))))))
 
-  (define (bit-vector-set! vec i x)
+(define (bit-vector-set! vec i x)
   (let ((byte (arithmetic-shift i -3))
         (off (bitwise-and i #x7)))
     (let ((val (bytes-ref vec byte))
@@ -34,33 +34,33 @@
                       (bitwise-ior val mask)
                       (bitwise-and val (bitwise-not mask)))))))
 
-  (define (nsievebits m)
+(define (nsievebits m)
   (let ((a (make-bit-vector m)))
     (define (clear i)
       (do ([j (+ i i) (+ j i)])
   	  ((>= j m))
-           (bit-vector-set! a j #f) ) )
+        (bit-vector-set! a j #f)))
     (let ([c 0])
       (do ([i 2 (add1 i)])
           ((>= i m) c)
         (when (bit-vector-ref a i)
           (clear i)
-	    (set! c (add1 c)) ) ) ) ) )
+          (set! c (add1 c)))))))
 
-  (define (string-pad s n)
-    (string-append (make-string (- n (string-length s)) #\space)
+(define (string-pad s len)
+  (string-append (make-string (- len (string-length s)) #\space)
                  s))
 
-  (define (test n)
-    (let ((m (* 10000 (arithmetic-shift 1 n))))
-      (printf "Primes up to ~a ~a~%"
+(define (test n)
+  (let* ((m (* (expt 2 n) 10000))
+         (count (nsievebits m)))
+    (printf "Primes up to ~a ~a\n"
             (string-pad (number->string m) 8)
-              (string-pad (number->string (nsievebits m)) 8))))
+            (string-pad (number->string count) 8))))
 
-  (define (main args)
-    (let ([n (string->number (vector-ref args 0))])
+(define (main n)
   (when (>= n 0) (test n))
   (when (>= n 1) (test (- n 1)))
-      (when (>= n 2) (test (- n 2)))))
+  (when (>= n 2) (test (- n 2))))
 
-  (main (current-command-line-arguments)))
+(command-line #:args (n) (main (string->number n)))

collects/tests/mzscheme/benchmarks/shootout/partialsums.ss

@@ -8,23 +8,17 @@
 ;; Contributed by Anthony Borla
 ;; ---------------------------------------------------------------------
 
-;; Note: as of version 350, this benchmark spends much of
-;;  its time GCing; it runs 1.5 times as fast in mzscheme3m.
+#lang scheme/base
+(require scheme/cmdline)
 
-(module partialsums mzscheme
-  (require (only mzlib/string real->decimal-string))
-
-  (let ((n (exact->inexact
+(let ((n (exact->inexact
           (string->number
-	     (vector-ref (current-command-line-arguments) 0))))
-	
-	(alt 1) (d2 0) (d3 0) (ds 0) (dc 0)
-	(s0 0) (s1 0) (s2 0) (s3 0) (s4 0) (s5 0) (s6 0) (s7 0) (s8 0))
+           (command-line #:args (n) n)))))
   
   (let loop ([d 0.0]
              (alt 1) (d2 0) (d3 0) (ds 0) (dc 0)
              (s0 0) (s1 0) (s2 0) (s3 0) (s4 0) (s5 0) (s6 0) (s7 0) (s8 0))
-      (if (= d n #;(+ n 1))
+    (if (= d n)
         (let ([format-result
                (lambda (str n)
                  (printf str (real->decimal-string n 9)))])
@@ -58,4 +52,4 @@
           
 	  (loop d
 		alt d2 d3 ds dc
-		s0 s1 s2 s3 s4 s5 s6 s7 s8))))))
+		s0 s1 s2 s3 s4 s5 s6 s7 s8)))))

collects/tests/mzscheme/benchmarks/shootout/pidigits.ss

@@ -31,7 +31,7 @@
                     (digit k q r s t (sub1 n) row 1))
                   (begin
                     (printf "~a" y)
-                    (digit k q r s t(sub1 n) row (add1 col)))))
+                    (digit k q r s t (sub1 n) row (add1 col)))))
             (let-values ([(q r s t) (mk q r s t k)])
               (digit (add1 k) q r s t n row col))))
       (printf "~a\t:~a\n"

collects/tests/mzscheme/benchmarks/shootout/recursive.ss

@@ -8,40 +8,39 @@
 ;; Contributed by Anthony Borla
 ;; ---------------------------------------------------------------------
 
-(module recursive mzscheme
-  (require (only mzlib/string real->decimal-string))
+#lang scheme/base
+(require scheme/cmdline)
 
-  ;; -------------------------------
+;; -------------------------------
 
-  (define (ack m n)
+(define (ack m n)
   (cond ((zero? m) (+ n 1))
         ((zero? n) (ack (- m 1) 1))
         (else (ack (- m 1) (ack m (- n 1))))))
 
-  ;; --------------
+;; --------------
 
-  (define (fib n)
+(define (fib n)
   (cond ((< n 2) 1)
         (else (+ (fib (- n 2)) (fib (- n 1))))))
 
-  (define (fibflt n)
+(define (fibflt n)
   (cond ((< n 2.0) 1.0)
         (else (+ (fibflt (- n 2.0)) (fibflt (- n 1.0))))))
 
-  ;; --------------
+;; --------------
 
-  (define (tak x y z)
+(define (tak x y z)
   (cond ((not (< y x)) z)
         (else (tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y)))))
 
-  (define (takflt x y z)
+(define (takflt x y z)
   (cond ((not (< y x)) z)
         (else (takflt (takflt (- x 1.0) y z) (takflt (- y 1.0) z x) (takflt (- z 1.0) x y)))))
 
-  ;; -------------------------------
+;; -------------------------------
 
-  (define (main args)
-    (let ((n (string->number (vector-ref args 0))))
+(define (main n)
 
   (printf "Ack(3,~A): ~A~%" n (ack 3 n))
   (printf "Fib(~a): ~a~%" 
@@ -52,8 +51,8 @@
   (printf "Tak(~A,~A,~A): ~A~%" (* n 3) (* n 2) n (tak (* n 3) (* n 2) n))
   
   (printf "Fib(3): ~A~%" (fib 3))
-      (printf "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1))))
+  (printf "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1)))
 
-  ;; -------------------------------
+;; -------------------------------
 
-  (main (current-command-line-arguments)))
+(main (command-line #:args (n) (string->number n)))

collects/tests/mzscheme/benchmarks/shootout/regexpdna.ss

@@ -10,40 +10,39 @@
 ;; Contributed by Anthony Borla
 ;; ---------------------------------------------------------------------
 
-(module regexpdna mzscheme
+#lang scheme/base
+(require scheme/port)
 
-  (require mzlib/port)
+;; -------------------------------
 
-  ;; -------------------------------
-  
-  (define VARIANTS
+(define VARIANTS
   '(#"agggtaaa|tttaccct" #"[cgt]gggtaaa|tttaccc[acg]" #"a[act]ggtaaa|tttacc[agt]t"
     #"ag[act]gtaaa|tttac[agt]ct" #"agg[act]taaa|ttta[agt]cct" #"aggg[acg]aaa|ttt[cgt]ccct"
     #"agggt[cgt]aa|tt[acg]accct" #"agggta[cgt]a|t[acg]taccct" #"agggtaa[cgt]|[acg]ttaccct"))
 
 
-  (define IUBS
+(define IUBS
   '((#"B" #"(c|g|t)") (#"D" #"(a|g|t)") (#"H" #"(a|c|t)")
     (#"K" #"(g|t)") (#"M" #"(a|c)") (#"N" #"(a|c|g|t)")
     (#"R" #"(a|g)") (#"S" #"(c|g)") (#"V" #"(a|c|g)")
     (#"W" #"(a|t)") (#"Y" #"(c|t)")))
 
-  ;; -------------------------------
+;; -------------------------------
 
-  (define (ci-byte-regexp s)
+(define (ci-byte-regexp s)
   (byte-regexp (bytes-append #"(?i:" s #")")))
 
-  ;; -------------------------------
+;; -------------------------------
 
-  (define (match-count str rx offset cnt)
+(define (match-count str rx offset cnt)
   (let ([m (regexp-match-positions rx str offset)])
     (if m
         (match-count str rx (cdar m) (add1 cnt))
         cnt)))
 
-  ;; --------------
+;; --------------
 
-  (define (replace-all rx str new)
+(define (replace-all rx str new)
   (let ([out (open-output-bytes)])
     (let loop ([pos 0])
       (let ([m (regexp-match-positions rx str pos)])
@@ -55,17 +54,17 @@
             (write-bytes str out pos))))
     (get-output-bytes out)))
 
-  ;; -------------------------------
+;; -------------------------------
 
-  (define (input->bytes)
+(define (input->bytes)
   (let ([b (open-output-bytes)])
     (copy-port (current-input-port) b)
     (get-output-bytes b)))
 
-  ;; -------------------------------
+;; -------------------------------
 
-  ;; Load sequence and record its length
-  (let* ([orig (input->bytes)]
+;; Load sequence and record its length
+(let* ([orig (input->bytes)]
        [filtered (replace-all #rx#"(>.*?\n)|\n" orig #"")])
 
   ;; Perform regexp counts
@@ -86,4 +85,4 @@
     (printf "~%~A~%~A~%~A~%" 
             (bytes-length orig)
             (bytes-length filtered)
-	      (bytes-length replaced)))))
+            (bytes-length replaced))))

collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss

@@ -27,7 +27,7 @@
 
 ;; return element i,j of infinite matrix A
 (define (A i j)
-  (/ 1.0 (+ (* (+ i j) (/ (+ i j 1) 2)) i 1)))
+  (/ 1.0 (+ (* (+ i j) (/ (+ i (+ j 1)) 2)) (+ i 1))))
 
 ;; multiply vector v by matrix A
 (define (MultiplyAv n v Av)

collects/tests/mzscheme/benchmarks/shootout/sumcol.ss

@@ -1,10 +1,5 @@
-;;; http://shootout.alioth.debian.org/
-;;;
-;;; Contributed by Eli Barzilay
+#lang scheme/base
 
-(module sumcol mzscheme
-  (let loop ([acc 0])
-    (let ([n (read)])
-      (if (eof-object? n)
-	  (printf "~a\n" acc)
-	  (loop (+ acc n))))))
+(for/fold ([acc 0])
+    ([n (in-lines)])
+  (+ acc (string->number n)))

collects/tests/mzscheme/benchmarks/shootout/thread-ring.ss

@@ -0,0 +1,23 @@
+#lang scheme/base
+(require scheme/cmdline)
+
+;; Each thread runs this loop:
+(define (run id next)
+  (let ([v (thread-receive)])
+    (cond
+     [(zero? v) ;; Done
+      (printf "~a\n" id)
+      (exit)]
+     [else ;; Keep going
+      (thread-send next (sub1 v))
+      (run id next)])))
+                       
+
+(let ([n (command-line #:args (n) (string->number n))])
+  ;; The original thread is #503. Create the rest:
+  (let ([t1 (for/fold ([next (current-thread)])
+                      ([id (in-range 502 0 -1)])
+              (thread (lambda () (run id next))))])
+    ;; Start:
+    (thread-send t1 n)
+    (run 503 t1)))