From ffad1edd7af5f1ccbabda1a438bae179feb44ce6 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 17 Jun 2010 14:48:15 -0400 Subject: [PATCH] Added the fannkuch-redux benchmark, which replaced fannkuch on the shootout roster. --- .../tests/racket/benchmarks/shootout/auto.rkt | 1 + .../benchmarks/shootout/fannkuch-redux.rkt | 59 +++++++++++++++++ .../tests/racket/benchmarks/shootout/run.rkt | 1 + .../typed/fannkuch-redux-non-optimizing.rkt | 2 + .../typed/fannkuch-redux-optimizing.rkt | 2 + .../shootout/typed/fannkuch-redux.rktl | 64 +++++++++++++++++++ 6 files changed, 129 insertions(+) create mode 100644 collects/tests/racket/benchmarks/shootout/fannkuch-redux.rkt create mode 100644 collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-non-optimizing.rkt create mode 100644 collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-optimizing.rkt create mode 100644 collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux.rktl diff --git a/collects/tests/racket/benchmarks/shootout/auto.rkt b/collects/tests/racket/benchmarks/shootout/auto.rkt index 3466ba0749..724d13d7f2 100755 --- a/collects/tests/racket/benchmarks/shootout/auto.rkt +++ b/collects/tests/racket/benchmarks/shootout/auto.rkt @@ -117,6 +117,7 @@ exec racket -qu "$0" ${1+"$@"} echo except fannkuch + fannkuch-redux fasta fibo hash diff --git a/collects/tests/racket/benchmarks/shootout/fannkuch-redux.rkt b/collects/tests/racket/benchmarks/shootout/fannkuch-redux.rkt new file mode 100644 index 0000000000..eaad42c288 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/fannkuch-redux.rkt @@ -0,0 +1,59 @@ +#lang racket/base + +;; fannkuch benchmark for The Computer Language Shootout +;; Written by Dima Dorfman, 2004 +;; Slightly improved by Sven Hartrumpf, 2005-2006 +;; Ever-so-slightly tweaked for MzScheme by Brent Fulgham +;; PLT-ized for v4.0 by Matthew + +(require racket/cmdline) + +(define (fannkuch n) + (let ([pi (list->vector + (for/list ([i (in-range n)]) i))] + [tmp (make-vector n)] + [count (make-vector n)]) + (let loop ([flips 0] + [perms 0] + [r n]) + (for ([i (in-range r)]) + (vector-set! count i (add1 i))) + (let ((flips2 (max (count-flips pi tmp) flips))) + (let loop2 ([r 1]) + (if (= r n) + flips2 + (let ((perm0 (vector-ref pi 0))) + (for ([i (in-range r)]) + (vector-set! pi i (vector-ref pi (add1 i)))) + (vector-set! pi r perm0) + (vector-set! count r (sub1 (vector-ref count r))) + (cond + [(<= (vector-ref count r) 0) + (loop2 (add1 r))] + [else (loop flips2 (add1 perms) r)])))))))) + +(define (count-flips pi rho) + (vector-copy! rho 0 pi) + (let loop ([i 0]) + (if (= (vector-ref rho 0) 0) + i + (begin + (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0))) + (loop (add1 i)))))) + +(define (vector-reverse-slice! v i j) + (let loop ([i i] + [j (sub1 j)]) + (when (> j i) + (vector-swap! v i j) + (loop (add1 i) (sub1 j))))) + +(define (vector-swap! v i j) + (let ((t (vector-ref v i))) + (vector-set! v i (vector-ref v j)) + (vector-set! v j t))) + +(command-line #:args (n) + (printf "Pfannkuchen(~a) = ~a\n" + n + (fannkuch (string->number n)))) diff --git a/collects/tests/racket/benchmarks/shootout/run.rkt b/collects/tests/racket/benchmarks/shootout/run.rkt index 5582bcd755..de2faf8454 100644 --- a/collects/tests/racket/benchmarks/shootout/run.rkt +++ b/collects/tests/racket/benchmarks/shootout/run.rkt @@ -11,6 +11,7 @@ ("echo" "200000") ("except" "2000000") ("fannkuch" "10") + ("fannkuch-redux" "10") ("fasta" "1000000") ("fibo" "40") ("hash" "2000000") diff --git a/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-non-optimizing.rkt new file mode 100644 index 0000000000..5add27e11b --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module fannkuch-redux-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-optimizing.rkt new file mode 100644 index 0000000000..588d98f203 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-optimizing.rkt @@ -0,0 +1,2 @@ + +(module fannkuch-redux-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux.rktl b/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux.rktl new file mode 100644 index 0000000000..fb201f1111 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux.rktl @@ -0,0 +1,64 @@ +;; fannkuch benchmark for The Computer Language Shootout +;; Written by Dima Dorfman, 2004 +;; Slightly improved by Sven Hartrumpf, 2005-2006 +;; Ever-so-slightly tweaked for MzScheme by Brent Fulgham +;; PLT-ized for v4.0 by Matthew +;; Ported to Typed Scheme by Vincent + +(require racket/cmdline) + +(: fannkuch (Integer -> Integer)) +(define (fannkuch n) + (let ([pi (list->vector + (for/list: : (Listof Integer) ([i : Integer (in-range n)]) i))] + [tmp (make-vector n)] + [count (make-vector n)]) + (let: loop : Integer + ([flips : Integer 0] + [perms : Integer 0] + [r : Integer n]) + (for ([i (in-range r)]) + (vector-set! count i (add1 i))) + (let ((flips2 (max (count-flips pi tmp) flips))) + (let loop2 ([r 1]) + (if (= r n) + flips2 + (let ((perm0 (vector-ref pi 0))) + (for ([i (in-range r)]) + (vector-set! pi i (vector-ref pi (add1 i)))) + (vector-set! pi r perm0) + (vector-set! count r (sub1 (vector-ref count r))) + (cond + [(<= (vector-ref count r) 0) + (loop2 (add1 r))] + [else (loop flips2 (add1 perms) r)])))))))) + +(: count-flips ((Vectorof Integer) (Vectorof Integer) -> Integer)) +(define (count-flips pi rho) + (vector-copy! rho 0 pi) + (let: loop : Integer ([i : Integer 0]) + (if (= (vector-ref rho 0) 0) + i + (begin + (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0))) + (loop (add1 i)))))) + +(: vector-reverse-slice! (All (X) ((Vectorof X) Integer Integer -> Void))) +(define (vector-reverse-slice! v i j) + (let: loop : Void + ([i : Integer i] + [j : Integer (sub1 j)]) + (when (> j i) + (vector-swap! v i j) + (loop (add1 i) (sub1 j))))) + +(: vector-swap! (All (X) ((Vectorof X) Integer Integer -> Void))) +(define (vector-swap! v i j) + (let ((t (vector-ref v i))) + (vector-set! v i (vector-ref v j)) + (vector-set! v j t))) + +(command-line #:args (n) + (printf "Pfannkuchen(~a) = ~a\n" + n + (fannkuch (assert (string->number (assert n string?)) exact-nonnegative-integer?))))