Initial parallel versions of Shootout benchmarks.

collects/meta/props

@@ -1616,6 +1616,7 @@ path/s is either such a string or a list of them.
 "collects/tests/racket/benchmarks/shootout/ackermann.rkt" drdr:command-line (racket "-t" * "--" "10")
 "collects/tests/racket/benchmarks/shootout/auto.rkt" drdr:command-line (racket "-qt" * "--" "hello")
 "collects/tests/racket/benchmarks/shootout/binarytrees.rkt" drdr:command-line (racket "-t" * "--" "10")
+"collects/tests/racket/benchmarks/shootout/binarytrees-places.rkt" drdr:command-line (racket "-tm" * "--" "10")
 "collects/tests/racket/benchmarks/shootout/chameneos.rkt" drdr:command-line (racket "-t" * "--" "10")
 "collects/tests/racket/benchmarks/shootout/cheapconcurrency.rkt" drdr:command-line (racket "-t" * "--" "10")
 "collects/tests/racket/benchmarks/shootout/fannkuch-redux.rkt" drdr:command-line (racket "-t" * "--" "4")
@@ -1625,6 +1626,7 @@ path/s is either such a string or a list of them.
 "collects/tests/racket/benchmarks/shootout/hash2.rkt" drdr:command-line (racket "-t" * "--" "10")
 "collects/tests/racket/benchmarks/shootout/mandelbrot-generic.rkt" drdr:command-line (racket "-t" * "--" "15")
 "collects/tests/racket/benchmarks/shootout/mandelbrot.rkt" drdr:command-line (racket "-t" * "--" "15")
+"collects/tests/racket/benchmarks/shootout/mandelbrot-futures.rkt" drdr:command-line (racket "-t" * "--" "15")
 "collects/tests/racket/benchmarks/shootout/meteor.rkt" drdr:command-line (racket "-t" * "--" "10")
 "collects/tests/racket/benchmarks/shootout/nbody-generic.rkt" drdr:command-line (racket "-t" * "--" "10")
 "collects/tests/racket/benchmarks/shootout/nbody-vec-generic.rkt" drdr:command-line (racket "-t" * "--" "10")

collects/tests/racket/benchmarks/shootout/binarytrees-places.rkt

@@ -0,0 +1,70 @@
+#lang racket/base
+
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+;;; Derived from the Chicken variant by Sven Hartrumpf
+
+(require racket/cmdline racket/require (for-syntax racket/base) racket/place (only-in racket/fixnum make-shared-fxvector)
+         (filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
+                      racket/unsafe/ops))
+
+(define-syntax-rule (**leaf? v) (fx= 1 (vector-length v)))
+(define-syntax-rule (**node? v) (fx= 3 (vector-length v)))
+
+(define-syntax leaf  (make-rename-transformer #'vector))
+(define-syntax leaf? (make-rename-transformer #'**leaf?))
+(define-syntax node  (make-rename-transformer #'vector))
+(define-syntax node? (make-rename-transformer #'**node?))
+(define-syntax-rule (leaf-val l)   (vector-ref l 0))
+(define-syntax-rule (node-left n)  (vector-ref n 1))
+(define-syntax-rule (node-right n) (vector-ref n 2))
+
+(define (make item d)
+  (if (fx= d 0)
+    (leaf item)
+    (let ([item2 (fx* item 2)] [d2 (fx- d 1)])
+      (node item (make (fx- item2 1) d2) (make item2 d2)))))
+
+(define-syntax-rule (check s)
+  (let loop ([t s] [acc 0])
+    (let ([acc (fx+ (leaf-val t) acc)])
+      (if (node? t)
+        (loop (node-left t)
+              (fx- acc (loop (node-right t) 0)))
+        acc))))
+
+(require racket/match)
+(define (work c)
+  (define args (place-channel-get c))
+  (match-define (vector max-depth min-depth d) args)
+  (define iterations (fxlshift 1 (fx+ (fx- max-depth d) min-depth)))
+  (place-channel-put 
+   c (vector (fx* 2 iterations) d
+             (for/fold ([c 0]) ([i (in-range iterations)])
+               (fx+ c (fx+ (check (make i d))
+                           (check (make (fx- 0 i) d))))))))
+
+(define min-depth 4)
+(define (main* n)  
+  (define max-depth (max (+ min-depth 2) n))
+  (define stretch-depth (+ max-depth 1))
+  (printf "stretch tree of depth ~a\t check: ~a\n"
+          stretch-depth
+          (check (make 0 stretch-depth)))
+  (define len (fx+ max-depth 1))
+  (define output (make-vector len #f))
+  (define long-lived-tree (make 0 max-depth))
+  (define thds
+    (for/list ([d (in-range 4 len 2)])
+      (thread (λ ()
+                (define c (place ch (work ch)))
+                (place-channel-put c (vector max-depth min-depth d))
+                (vector-set! output d (place-channel-get c))))))
+  (map sync thds)
+  (for ([e (in-vector output)] #:when e)
+    (printf "~a\t trees of depth ~a\t check: ~a\n"
+            (vector-ref e 0) (vector-ref e 1) (vector-ref e 2)))
+  (printf "long lived tree of depth ~a\t check: ~a\n"
+          max-depth
+          (check long-lived-tree)))
+(define (main a) (main* (string->number a))) (provide main)

collects/tests/racket/benchmarks/shootout/mandelbrot-futures.rkt

@@ -0,0 +1,60 @@
+#lang racket/base
+
+;; The Computer Language Benchmarks Game
+;; http://shootout.alioth.debian.org/
+;; contributed by Eli Barzilay
+;; parallelized by Sam Tobin-Hochstadt
+
+(require racket/require (for-syntax racket/base) racket/future
+         (filtered-in (lambda (n) (regexp-replace #rx"unsafe-" n ""))
+                       racket/unsafe/ops)
+         (only-in racket/flonum make-flvector)
+         racket/cmdline)
+
+(define LIMIT-SQR 4.0)
+(define ITERATIONS 50)
+(define N (command-line #:args (n) (string->number n)))
+(define N.0 (fx->fl N))
+(define 2/N (fl/ 2.0 N.0))
+(define Crs
+  (let ([v (make-flvector N)])
+    (for ([x (in-range N)])
+      (flvector-set! v x (fl- (fl/ (fx->fl (fx* 2 x)) N.0) 1.5)))
+    v))
+
+(define bpr (ceiling (/ N 8)))
+(define bitmap (make-bytes (* N bpr)))
+
+(define-syntax (let-n s)
+  (syntax-case s ()
+    [(_ N bs E)
+     (for/fold ([E #'E]) ([_ (syntax-e #'N)]) #`(let bs #,E))]))
+
+(define-syntax-rule (M Cr Ci)
+  (let loop ([i 0] [Zr 0.0] [Zi 0.0])
+    (cond [(fl> (fl+ (fl* Zr Zr) (fl* Zi Zi)) LIMIT-SQR) 0]
+          [(fx= i ITERATIONS) 1]
+          [else (let-n 5 ([Zr (fl+ (fl- (fl* Zr Zr) (fl* Zi Zi)) Cr)]
+                          [Zi (fl+ (fl* 2.0 (fl* Zr Zi)) Ci)])
+                  (loop (fx+ i 5) Zr Zi))])))
+
+(printf "P4\n~a ~a\n" N N)
+(for-each
+ touch
+ (for/list ([y (in-range N 0 -1)])
+   (future
+    (λ ()
+      (define Ci (fl- (fl* 2/N (fx->fl y)) 1.0))
+      (let loop-x ([x 0] [bitnum 0] [byteacc 0] [aindex (fx* bpr (fx- N y))])
+        (cond [(fx< x N)
+               (define Cr (flvector-ref Crs x))
+               (define byteacc* (fx+ (fxlshift byteacc 1) (M Cr Ci)))
+               (cond [(fx= bitnum 7)
+                      (bytes-set! bitmap aindex byteacc*)
+                      (loop-x (fx+ x 1) 0 0 (fx+ aindex 1))]
+                     [else (loop-x (fx+ x 1) (fx+ bitnum 1) byteacc* aindex)])]
+              [else
+               (when (fx> bitnum 0)
+                 (bytes-set! bitmap aindex
+                             (fxlshift byteacc (fx- 8 (fxand N #x7)))))]))))))
+(void (write-bytes bitmap))