Permalink
Browse files

Initial parallel versions of Shootout benchmarks.

  • Loading branch information...
1 parent b1a360b commit a55e86d93bf76a5f8f402839f5e1e69dabd16829 @samth samth committed Sep 22, 2011
View
@@ -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")
@@ -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)
@@ -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))

0 comments on commit a55e86d

Please sign in to comment.