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)]
+  (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)]
+  (let* ([content (hash-map table cons)]
          [total (exact->inexact (apply + (map cdr content)))])
     (for-each
      (lambda (a)
@@ -29,17 +24,17 @@
      (sort content (lambda (a b) (> (cdr a) (cdr b)))))))
 
 (define (write-one-freq table key)
-    (let ([cnt (hash-table-get table key 0)])
+  (let ([cnt (hash-ref table key 0)])
     (printf "~a\t~a\n" cnt key)))
 
 (define dna
-    (begin
+  (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)))))
@@ -58,4 +53,3 @@
                             (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,10 +16,8 @@
 ;;	 [(> (magnitude z) 2.0) 0]
 ;;	 [else (loop (add1 i) (+ (* z z) c))]))))
  
-
-(module mandelbrot mzscheme
-
-  ;; -------------------------------
+#lang scheme/base
+(require scheme/cmdline)
 
 (define +limit-sqr+ 4.0)
 
@@ -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)
   (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 (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,9 +4,9 @@
 ;;
 ;; 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)
   (let* ((len (quotient (+ size 7) 8))
@@ -47,20 +47,20 @@
           (clear i)
           (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~%"
+  (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.
-
-(module partialsums mzscheme
-  (require (only mzlib/string real->decimal-string))
+#lang scheme/base
+(require scheme/cmdline)
 
 (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/recursive.ss

@@ -8,8 +8,8 @@
 ;; Contributed by Anthony Borla
 ;; ---------------------------------------------------------------------
 
-(module recursive mzscheme
-  (require (only mzlib/string real->decimal-string))
+#lang scheme/base
+(require scheme/cmdline)
 
 ;; -------------------------------
 
@@ -40,8 +40,7 @@
 
 ;; -------------------------------
 
-  (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,9 +10,8 @@
 ;; Contributed by Anthony Borla
 ;; ---------------------------------------------------------------------
 
-(module regexpdna mzscheme
-
-  (require mzlib/port)
+#lang scheme/base
+(require scheme/port)
 
 ;; -------------------------------
 
@@ -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)))