diff --git a/collects/meta/props b/collects/meta/props index 98f4e1d6ec..76eac0d17c 100755 --- a/collects/meta/props +++ b/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") diff --git a/collects/tests/racket/benchmarks/shootout/binarytrees-places.rkt b/collects/tests/racket/benchmarks/shootout/binarytrees-places.rkt new file mode 100644 index 0000000000..d4a1d57627 --- /dev/null +++ b/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) diff --git a/collects/tests/racket/benchmarks/shootout/mandelbrot-futures.rkt b/collects/tests/racket/benchmarks/shootout/mandelbrot-futures.rkt new file mode 100644 index 0000000000..aa78ba74de --- /dev/null +++ b/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))