suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

rackety shootout benchmarks

Browse Source
This commit is contained in:
Matthew Flatt 2010-05-19 14:09:45 -06:00
parent e9ac3651a4
commit 993d80eb2a
23 changed files with 185 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/tests/racket/benchmarks/shootout/binarytrees.rkt
View File

@ -1,22 +1,26 @@
#lang racket/base
;;; The Great Computer Language Shootout
;;; http://shootout.alioth.debian.org/
;;; Derived from the Chicken variant by Sven Hartrumpf
#lang scheme/base
(require scheme/cmdline)
(define-struct node (left val right))
(require racket/cmdline)
(struct node (left val right))
;; Instead of (define-struct leaf (val)):
(define (make-leaf val) (make-node #f val #f))
(define (leaf val) (node #f val #f))
(define (leaf? l) (not (node-left l)))
(define (leaf-val l) (node-val l))
(define (make item d)
(if (= d 0)
(make-leaf item)
(leaf item)
(let ((item2 (* item 2))
(d2 (- d 1)))
(make-node (make (- item2 1) d2) item (make item2 d2)))))
(node (make (- item2 1) d2)
item
(make item2 d2)))))
(define (check t)
(if (leaf? t)

11
collects/tests/racket/benchmarks/shootout/chameneos.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base
;;; The Great Computer Language Shootout
;;; http://shootout.alioth.debian.org/
;;;
;;; Uses PLT Scheme threads
;;; Uses Racket threads
#lang scheme/base
(require scheme/cmdline
scheme/match)
(require racket/cmdline
racket/match)
(define (change c1 c2)
(case c1
@ -96,5 +97,3 @@
(go n '(blue red yellow))
(go n '(blue red yellow red yellow blue red yellow red blue))
(newline))

5
collects/tests/racket/benchmarks/shootout/fannkuch.rkt
View File

@ -1,11 +1,12 @@
#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
#lang scheme/base
(require scheme/cmdline)
(require racket/cmdline)
(define (fannkuch n)
(let ([pi (list->vector

7
collects/tests/racket/benchmarks/shootout/fasta.rkt
View File

@ -1,3 +1,5 @@
#lang racket/base
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
@ -6,8 +8,7 @@
;; Derived from the Chicken variant, which was
;; Contributed by Anthony Borla
#lang scheme/base
(require scheme/cmdline)
(require racket/cmdline)
(define +alu+
(bytes-append
@ -40,7 +41,7 @@
(let* ((ia 3877) (ic 29573) (im 139968) (last seed))
(lambda (max)
(set! last (modulo (+ ic (* last ia)) im))
(/ (* max last) im) )))
(/ (* max last) im))))
;; -------------------------------

27
collects/tests/racket/benchmarks/shootout/k-nucleotide.rkt
View File

@ -1,8 +1,8 @@
#lang racket/base
;; The Computer Language Shootout
;; http://shootout.alioth.debian.org/
#lang scheme/base
(define (all-counts len dna)
(let ([table (make-hasheq)]
[seq (make-string len)])
@ -16,12 +16,10 @@
(define (write-freqs table)
(let* ([content (hash-map table cons)]
[total (exact->inexact (apply + (map cdr content)))])
(for-each
(lambda (a)
(printf "~a ~a\n"
(car a)
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))
(sort content (lambda (a b) (> (cdr a) (cdr b)))))))
(for ([a (sort content > #:key cdr)])
(printf "~a ~a\n"
(car a)
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))))
(define (write-one-freq table key)
(let ([cnt (hash-ref table key 0)])
@ -33,9 +31,8 @@
(regexp-match #rx#"(?m:^>THREE.*$)" in)
(let ([s (open-output-string)])
;; Copy everything but newlines to s:
(let loop ()
(when (regexp-match #rx#"\n" in 0 #f s)
(loop)))
(for ([l (in-bytes-lines in)])
(write-bytes l s))
;; Extract the string from s:
(string-upcase (get-output-string s)))))
@ -48,8 +45,6 @@
(newline)
;; Specific sequences:
(for-each (lambda (seq)
(write-one-freq (all-counts (string-length seq) dna)
(string->symbol seq)))
'("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))
(for ([seq '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT")])
(write-one-freq (all-counts (string-length seq) dna)
(string->symbol seq)))

6
collects/tests/racket/benchmarks/shootout/mandelbrot-generic.rkt
View File

@ -1,4 +1,5 @@
;; ---------------------------------------------------------------------
#lang racket/base
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
@ -16,8 +17,7 @@
;; [(> (magnitude z) 2.0) 0]
;; [else (loop (add1 i) (+ (* z z) c))]))))
#lang scheme/base
(require scheme/cmdline)
(require racket/cmdline)
(define +limit-sqr+ 4.0)

10
collects/tests/racket/benchmarks/shootout/mandelbrot-unsafe.rkt
View File

@ -1,4 +1,5 @@
;; ---------------------------------------------------------------------
#lang racket/base
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
@ -7,12 +8,11 @@
;;
;; This version uses unsafe operations
#lang scheme/base
(require scheme/cmdline
scheme/require (for-syntax scheme/base)
(require racket/cmdline
racket/require (for-syntax racket/base)
(filtered-in
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
scheme/unsafe/ops))
racket/unsafe/ops))
(define +limit-sqr+ 4.0)

8
collects/tests/racket/benchmarks/shootout/mandelbrot.rkt
View File

@ -1,13 +1,13 @@
;; ---------------------------------------------------------------------
#lang racket/base
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; Derived from the Chicken variant, which was
;; Contributed by Anthony Borla
#lang scheme/base
(require scheme/cmdline
scheme/flonum)
(require racket/cmdline
racket/flonum)
(define +limit-sqr+ 4.0)

5
collects/tests/racket/benchmarks/shootout/meteor.rkt
View File

@ -1,3 +1,5 @@
#lang racket/base
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
;;
@ -7,8 +9,7 @@
;; contributed by Matthew Flatt
;; optimized by Eli Barzilay
#lang scheme/base
(require scheme/cmdline scheme/list)
(require racket/cmdline)
(define width 5)
(define height 10)

8
collects/tests/racket/benchmarks/shootout/nbody-generic.rkt
View File

@ -1,4 +1,5 @@
#!/usr/bin/mzscheme -qu
#lang racket/base
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
;;
@ -6,7 +7,7 @@
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
;; idioms like 'named let' and 'do' special form.
;;
;; Contributed by Anthony Borla, then converted for mzscheme
;; Contributed by Anthony Borla, then converted for Racket
;; by Matthew Flatt and Brent Fulgham
#|
@ -16,8 +17,7 @@ Correct output N = 1000 is
-0.169087605
|#
#lang scheme/base
(require scheme/cmdline)
(require racket/cmdline)
;; ------------------------------
;; define planetary masses, initial positions & velocity

8
collects/tests/racket/benchmarks/shootout/nbody-vec-generic.rkt
View File

@ -1,4 +1,5 @@
#!/usr/bin/mzscheme -qu
#lang racket/base
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
;;
@ -6,7 +7,7 @@
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
;; idioms like 'named let' and 'do' special form.
;;
;; Contributed by Anthony Borla, then converted for mzscheme
;; Contributed by Anthony Borla, then converted for Racket
;; by Matthew Flatt and Brent Fulgham
#|
@ -16,8 +17,7 @@ Correct output N = 1000 is
-0.169087605
|#
#lang scheme/base
(require scheme/cmdline)
(require racket/cmdline)
;; ------------------------------
;; define planetary masses, initial positions & velocity

14
collects/tests/racket/benchmarks/shootout/nbody-vec-unsafe.rkt
View File

@ -1,4 +1,5 @@
#!/usr/bin/mzscheme -qu
#lang racket/base
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
;;
@ -6,7 +7,7 @@
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
;; idioms like 'named let' and 'do' special form.
;;
;; Contributed by Anthony Borla, then converted for mzscheme
;; Contributed by Anthony Borla, then converted for Racket
;; by Matthew Flatt and Brent Fulgham
;; Made unsafe and optimized by Sam TH
#|
@ -16,15 +17,14 @@ Correct output N = 1000 is
-0.169087605
|#
#lang scheme/base
(require scheme/cmdline scheme/require
(only-in scheme/flonum flvector)
(for-syntax scheme/base)
(require racket/cmdline racket/require
(only-in racket/flonum flvector)
(for-syntax racket/base)
(filtered-in
(lambda (name)
(regexp-replace
#rx"unsafe-fl" name "fl"))
scheme/unsafe/ops))
racket/unsafe/ops))
;; ------------------------------
;; define planetary masses, initial positions & velocity

10
collects/tests/racket/benchmarks/shootout/nbody-vec.rkt
View File

@ -1,4 +1,5 @@
#!/usr/bin/mzscheme -qu
#lang racket/base
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
;;
@ -6,7 +7,7 @@
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
;; idioms like 'named let' and 'do' special form.
;;
;; Contributed by Anthony Borla, then converted for mzscheme
;; Contributed by Anthony Borla, then converted for Racket
;; by Matthew Flatt and Brent Fulgham
#|
@ -16,9 +17,8 @@ Correct output N = 1000 is
-0.169087605
|#
#lang scheme/base
(require scheme/cmdline
scheme/flonum)
(require racket/cmdline
racket/flonum)
;; ------------------------------
;; define planetary masses, initial positions & velocity

10
collects/tests/racket/benchmarks/shootout/nbody.rkt
View File

@ -1,4 +1,5 @@
#!/usr/bin/mzscheme -qu
#lang racket/base
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
;;
@ -6,7 +7,7 @@
;; Patrick Frankenberger and Juho Snellman, but using only native Scheme
;; idioms like 'named let' and 'do' special form.
;;
;; Contributed by Anthony Borla, then converted for mzscheme
;; Contributed by Anthony Borla, then converted for Racket
;; by Matthew Flatt and Brent Fulgham
#|
@ -16,9 +17,8 @@ Correct output N = 1000 is
-0.169087605
|#
#lang scheme/base
(require scheme/cmdline
scheme/flonum)
(require racket/cmdline
racket/flonum)
;; ------------------------------
;; define planetary masses, initial positions & velocity

9
collects/tests/racket/benchmarks/shootout/pidigits-gmp.rkt
View File

@ -1,12 +1,13 @@
#lang racket/base
;; The Computer Language Shootout
;; http://shootout.alioth.debian.org/
;; Based on the Perl version of the benchmark
;; adapted with a GMP interface by Eli Barzilay
#lang scheme/base
(require scheme/cmdline)
(require (for-syntax scheme/base))
(require scheme/foreign) (unsafe!)
(require racket/cmdline
(for-syntax racket/base)
ffi/unsafe)
;; quick libgmp interface, limited to what we need below
(define libgmp (ffi-lib "libgmp"))

5
collects/tests/racket/benchmarks/shootout/pidigits.rkt
View File

@ -1,10 +1,11 @@
#lang racket/base
;; The Computer Language Shootout
;; http://shootout.alioth.debian.org/
;; Based on the MLton version of the benchmark
;; contributed by Scott Cruzen
#lang scheme/base
(require scheme/cmdline)
(require racket/cmdline)
(define (floor_ev q r s t x)
(quotient (+ (* q x) r) (+ (* s x) t)))

93
collects/tests/racket/benchmarks/shootout/pidigits1.rkt
View File

@ -1,4 +1,5 @@
#!/usr/bin/mzscheme -r
#lang racket/base
; The Computer Language Shootout
; http://shootout.alioth.debian.org/
; Sven Hartrumpf 2005-04-12
@ -6,52 +7,50 @@
; This program is based on an implementation for SCM by Aubrey Jaffer and
; Jerry D. Hedden.
(module pidigits1 mzscheme
(define (pi n d)
(let* ((r (inexact->exact (floor (exp (* d (log 10)))))) ; 10^d
(p (+ (quotient n d) 1))
(m (quotient (* p d 3322) 1000))
(a (make-vector (+ m 1) 2))
(out (current-output-port)))
(vector-set! a m 4)
(let j-loop ([b 2][digits 0])
(if (= digits n)
;; Add whitespace for ungenerated digits
(let ([left (modulo digits 10)])
(unless (zero? left)
(fprintf out "~a\t:~a\n" (make-string (- 10 left) #\space) n)))
;; Compute more digits
(let loop ([k m][q 0])
(if (zero? k)
(let* ((s (let ([s (number->string (+ b (quotient q r)))])
(if (zero? digits)
s
(string-append (make-string (- d (string-length s)) #\0) s)))))
(j-loop (remainder q r)
(print-digits out s 0 (string-length s) digits n)))
(let ([q (+ q (* (vector-ref a k) r))])
(let ((t (+ (* k 2) 1)))
(let-values ([(qt rr) (quotient/remainder q t)])
(vector-set! a k rr)
(loop (sub1 k) (* k qt)))))))))))
(define (pi n d)
(let* ((r (inexact->exact (floor (exp (* d (log 10)))))) ; 10^d
(p (+ (quotient n d) 1))
(m (quotient (* p d 3322) 1000))
(a (make-vector (+ m 1) 2))
(out (current-output-port)))
(vector-set! a m 4)
(let j-loop ([b 2][digits 0])
(if (= digits n)
;; Add whitespace for ungenerated digits
(let ([left (modulo digits 10)])
(unless (zero? left)
(fprintf out "~a\t:~a\n" (make-string (- 10 left) #\space) n)))
;; Compute more digits
(let loop ([k m][q 0])
(if (zero? k)
(let* ((s (let ([s (number->string (+ b (quotient q r)))])
(if (zero? digits)
s
(string-append (make-string (- d (string-length s)) #\0) s)))))
(j-loop (remainder q r)
(print-digits out s 0 (string-length s) digits n)))
(let ([q (+ q (* (vector-ref a k) r))])
(let ((t (+ (* k 2) 1)))
(let-values ([(qt rr) (quotient/remainder q t)])
(vector-set! a k rr)
(loop (sub1 k) (* k qt)))))))))))
(define (print-digits out s start end digits n)
(let* ([len (- end start)]
[cnt (min len (- n digits) (- 10 (modulo digits 10)) len)])
(if (zero? cnt)
digits
(begin
(write-string s out start (+ start cnt))
(let ([digits (+ digits cnt)])
(when (zero? (modulo digits 10))
(fprintf out "\t:~a\n" digits))
(print-digits out s (+ start cnt) end digits n))))))
(define (print-digits out s start end digits n)
(let* ([len (- end start)]
[cnt (min len (- n digits) (- 10 (modulo digits 10)) len)])
(if (zero? cnt)
digits
(begin
(write-string s out start (+ start cnt))
(let ([digits (+ digits cnt)])
(when (zero? (modulo digits 10))
(fprintf out "\t:~a\n" digits))
(print-digits out s (+ start cnt) end digits n))))))
(define (main args)
(let ((n (if (= (vector-length args) 0)
1
(string->number (vector-ref args 0)))))
(pi n 10)))
(define (main args)
(let ((n (if (= (vector-length args) 0)
1
(string->number (vector-ref args 0)))))
(pi n 10)))
(main (current-command-line-arguments)))
(main (current-command-line-arguments))

55
collects/tests/racket/benchmarks/shootout/regexpdna.rkt
View File

@ -1,17 +1,11 @@
;; ---------------------------------------------------------------------
#lang racket/base
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; Tested with PCRE [compiler must be built with PCRE already installed
;; else other regex routines (with different behaviours) will be used].
;; Regex performance appears reasonable, but file loading [of 'large'
;; files] performance requires tweaking to effect a significant improvement.
;;
;; Contributed by Anthony Borla
;; ---------------------------------------------------------------------
;; Based on a version by by Anthony Borla
#lang scheme/base
(require scheme/port)
(require racket/port)
;; -------------------------------
@ -40,49 +34,22 @@
(match-count str rx (cdar m) (add1 cnt))
cnt)))
;; --------------
(define (replace-all rx str new)
(let ([out (open-output-bytes)])
(let loop ([pos 0])
(let ([m (regexp-match-positions rx str pos)])
(if m
(begin
(write-bytes str out pos (caar m))
(write-bytes new out)
(loop (cdar m)))
(write-bytes str out pos))))
(get-output-bytes out)))
;; -------------------------------
(define (input->bytes)
(let ([b (open-output-bytes)])
(copy-port (current-input-port) b)
(get-output-bytes b)))
;; -------------------------------
;; Load sequence and record its length
(let* ([orig (input->bytes)]
[filtered (replace-all #rx#"(>.*?\n)|\n" orig #"")])
(let* ([orig (port->bytes)]
[filtered (regexp-replace* #rx#"(?:>.*?\n)|\n" orig #"")])
;; Perform regexp counts
(for-each
(lambda (i)
(printf "~a ~a\n" i (match-count filtered (ci-byte-regexp i) 0 0)))
VARIANTS)
(for ([i (in-list VARIANTS)])
(printf "~a ~a\n" i (match-count filtered (ci-byte-regexp i) 0 0)))
;; Perform regexp replacements, and record sequence length
(let ([replaced
(let loop ([sequence filtered]
[IUBS IUBS])
(if (null? IUBS)
sequence
(loop (replace-all (byte-regexp (caar IUBS)) sequence (cadar IUBS))
(cdr IUBS))))])
(for/fold ([sequence filtered]) ([IUB IUBS])
(regexp-replace* (byte-regexp (car IUB)) sequence (cadr IUB)))])
;; Print statistics
(printf "~%~A~%~A~%~A~%"
(printf "\n~a\n~a\n~a\n"
(bytes-length orig)
(bytes-length filtered)
(bytes-length replaced))))

50
collects/tests/racket/benchmarks/shootout/reversecomplement.rkt
View File

@ -1,32 +1,34 @@
#lang racket/base
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
#lang scheme/base
(require scheme/cmdline)
(define translation (make-vector 128))
(for-each (lambda (from-to)
(let ([char (lambda (sym)
(string-ref (symbol->string sym) 0))])
(let ([from (char (car from-to))]
[to (char->integer (char-upcase (char (cadr from-to))))])
(vector-set! translation (char->integer from) to)
(vector-set! translation (char->integer (char-upcase from)) to))))
'([a t]
[c g]
[g c]
[t a]
[u a]
[m k]
[r y]
[w w]
[s s]
[y R]
[k M]
[v b]
[h d]
[d h]
[b v]
[n n]))
(for ([from-to '([a t]
[c g]
[g c]
[t a]
[u a]
[m k]
[r y]
[w w]
[s s]
[y R]
[k M]
[v b]
[h d]
[d h]
[b v]
[n n])])
(let ([char (lambda (sym)
(string-ref (symbol->string sym) 0))])
(let ([from (char (car from-to))]
[to (char->integer (char-upcase (char (cadr from-to))))])
(vector-set! translation (char->integer from) to)
(vector-set! translation (char->integer (char-upcase from)) to))))
(define (output lines)
(let* ([str (apply bytes-append lines)]

5
collects/tests/racket/benchmarks/shootout/spectralnorm-generic.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;; Translated directly from the C# version, which was:
;; contributed by Isaac Gouy
#lang scheme/base
(require scheme/cmdline)
(require racket/cmdline)
(define (Approximate n)
(let ([u (make-vector n 1.0)]

11
collects/tests/racket/benchmarks/shootout/spectralnorm-unsafe.rkt
View File

@ -1,18 +1,19 @@
#lang racket/base
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;; Translated directly from the C# version, which was:
;; contributed by Isaac Gouy
#lang scheme/base
(require scheme/cmdline
scheme/require (for-syntax scheme/base)
(require racket/cmdline
racket/require (for-syntax racket/base)
(rename-in
(filtered-in
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
scheme/unsafe/ops)
racket/unsafe/ops)
[fx->fl ->fl])
(only-in scheme/flonum make-flvector))
(only-in racket/flonum make-flvector))
(define (Approximate n)

7
collects/tests/racket/benchmarks/shootout/spectralnorm.rkt
View File

@ -1,12 +1,13 @@
#lang racket/base
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;; Translated directly from the C# version, which was:
;; contributed by Isaac Gouy
#lang scheme/base
(require scheme/cmdline
scheme/flonum)
(require racket/cmdline
racket/flonum)
(define (Approximate n)
(let ([u (make-flvector n 1.0)]

10
collects/tests/racket/benchmarks/shootout/thread-ring.rkt
View File

@ -1,7 +1,11 @@
;; Uses PLT Scheme threads
#lang racket/base
#lang scheme/base
(require scheme/cmdline)
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; Uses Racket threads
(require racket/cmdline)
;; Each thread runs this loop:
(define (run id next)