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

Ported most of the shootout benchmarks to Typed Scheme.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-06-10 16:50:43 -04:00
parent 37ae5a338b
commit 4fde1e8ccb
107 changed files with 2249 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/meta/props
View File

@ -1540,6 +1540,41 @@ path/s is either such a string or a list of them.
"collects/tests/racket/benchmarks/shootout/spellcheck.rkt" drdr:command-line (mzc *) "collects/tests/racket/benchmarks/shootout/spellcheck.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/shootout/strcat.rkt" drdr:command-line (racket "-t" * "--" "25") "collects/tests/racket/benchmarks/shootout/strcat.rkt" drdr:command-line (racket "-t" * "--" "25")
"collects/tests/racket/benchmarks/shootout/thread-ring.rkt" drdr:command-line (racket "-t" * "--" "25") "collects/tests/racket/benchmarks/shootout/thread-ring.rkt" drdr:command-line (racket "-t" * "--" "25")
"collects/tests/racket/benchmarks/shootout/typed" responsible (stamourv)
"collects/tests/racket/benchmarks/shootout/typed/ackermann.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/ary.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/chameneos.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/cheapconcurrency.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/echo.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/except.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/fannkuch.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/fasta.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/fibo.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/hash.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/hash2.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/heapsort.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/mandelbrot.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/matrix.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/moments.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/nbody.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/nestedloop.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/nsieve.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/nsievebits.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/partialsums.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/pidigits.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/pidigits1.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/random.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/recursive.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/regexpdna.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/reversecomplement.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/reversefile.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/sieve.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/spectralnorm.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/spellcheck.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/strcat.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/sumcol.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/wc.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/shootout/typed/wordfreq.rktl" drdr:command-line #f
"collects/tests/racket/binc.rktl" drdr:command-line #f "collects/tests/racket/binc.rktl" drdr:command-line #f
"collects/tests/racket/boundmap-test.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/boundmap-test.rktl" drdr:command-line (racket "-f" *)
"collects/tests/racket/cache-image-snip-test.rktl" drdr:command-line (gracket "-f" *) "collects/tests/racket/cache-image-snip-test.rktl" drdr:command-line (gracket "-f" *)

2
collects/tests/racket/benchmarks/shootout/typed/ackermann-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module ackermann-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/ackermann-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module ackermann-optimizing "wrap-typed-optimizing.ss")

12
collects/tests/racket/benchmarks/shootout/typed/ackermann.rktl Normal file
View File

@ -0,0 +1,12 @@
(require scheme/cmdline)
(: ack (Integer Integer -> Integer))
(define (ack m n)
(cond ((zero? m) (+ n 1))
((zero? n) (ack (- m 1) 1))
(else (ack (- m 1) (ack m (- n 1))))))
(command-line #:args (n)
(printf "Ack(3,~a): ~a~n"
n
(ack 3 (assert (string->number (assert n string?)) exact-integer?))))

2
collects/tests/racket/benchmarks/shootout/typed/ary-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module ary-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/ary-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module ary-optimizing "wrap-typed-optimizing.ss")

23
collects/tests/racket/benchmarks/shootout/typed/ary.rktl Normal file
View File

@ -0,0 +1,23 @@
(: main ((Vectorof String) -> Void))
(define (main args)
(let*: ((n : Exact-Positive-Integer
(if (= (vector-length args) 0)
1
(assert (string->number (vector-ref args 0)) exact-positive-integer?)))
(x : (Vectorof Integer) (make-vector n 0))
(y : (Vectorof Integer) (make-vector n 0))
(last : Natural (- n 1)))
(do ((i 0 (+ i 1)))
((= i n))
(vector-set! x i (+ i 1)))
(do ((k 0 (+ k 1)))
((= k 1000))
(do: : Void ((i : Integer last (- i 1)))
((< i 0))
(vector-set! y i (+ (vector-ref x i) (vector-ref y i)))))
(print-list (vector-ref y 0) " " (vector-ref y last))))
(: print-list (Any * -> Void))
(define (print-list . items) (for-each display items) (newline))
(main (current-command-line-arguments))

202
collects/tests/racket/benchmarks/shootout/typed/auto.rkt Executable file
View File

@ -0,0 +1,202 @@
#!/bin/sh
#|
exec racket -qu "$0" ${1+"$@"}
|#
;; Benchmark harness for the shootout benchmarks
;; Mostly taken from the common benchmark harness
(module auto scheme/base
(require (for-syntax scheme/base)
mzlib/process
"../../common/cmdline.rkt"
mzlib/list
mzlib/compile
mzlib/inflate
mzlib/date
mzlib/port
mzlib/file
dynext/file
syntax/toplevel
scheme/runtime-path)
;; Implementaton-specific control functions ------------------------------
(define (bytes->number b)
(string->number (bytes->string/latin-1 b)))
(define ((run-mk script) bm)
(when (file-exists? (symbol->string bm))
(delete-file (symbol->string bm)))
(parameterize ([current-command-line-arguments (vector (symbol->string bm))])
(namespace-require 'scheme)
(load script)))
(define (mk-racket bm)
(unless (directory-exists? "../compiled")
(make-directory "../compiled"))
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(let ([name (format "~a.rkt" bm)])
(compile-file (format "../~a" name)
(build-path "../compiled" (path-add-suffix name #".zo"))))))
(define (clean-up-zo bm)
(when (directory-exists? "../compiled")
(delete-directory/files "../compiled")))
(define (mk-typed-scheme bm)
(unless (directory-exists? "compiled")
(make-directory "compiled"))
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(let ([name (format "~a-non-optimizing.rkt" bm)])
(compile-file name
(build-path "compiled" (path-add-suffix name #".zo"))))))
(define (mk-typed-scheme-optimizing bm)
(unless (directory-exists? "compiled")
(make-directory "compiled"))
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(let ([name (format "~a-optimizing.rkt" bm)])
(compile-file name
(build-path "compiled" (path-add-suffix name #".zo"))))))
(define (clean-up-typed bm)
(when (directory-exists? "compiled")
(delete-directory/files "compiled")))
(define (extract-racket-times bm str)
(let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)])
(map bytes->number (cdr m))))
;; Table of implementatons and benchmarks ------------------------------
(define-struct impl (name setup make run extract-result clean-up skips))
(define untypeable-benchmarks
'(binarytrees
lists
regexmatch
k-nucleotide))
(define impls
(list
(make-impl 'racket
void
mk-racket
(lambda (bm)
(system (format "racket run.rkt ~a racket" bm)))
extract-racket-times
clean-up-zo
'())
(make-impl 'typed-scheme
void
mk-typed-scheme
(lambda (bm)
(system (format "racket run.rkt ~a typed-scheme" bm)))
extract-racket-times
clean-up-typed
untypeable-benchmarks)
(make-impl 'typed-scheme-optimizing
void
mk-typed-scheme-optimizing
(lambda (bm)
(system (format "racket run.rkt ~a typed-scheme-optimizing" bm)))
extract-racket-times
clean-up-typed
untypeable-benchmarks)
))
(define benchmarks
'(ackermann
ary
binarytrees
chameneos
cheapconcurrency
echo
except
fannkuch
fasta
fibo
hash
hash2
heapsort
k-nucleotide
lists
mandelbrot
matrix
moments
nbody
nestedloop
nsieve
nsievebits
partialsums
pidigits
pidigits1
random
recursive
regexmatch
regexpdna
reversecomplement
reversefile
sieve
spectralnorm
strcat
sumcol
wc
wordfreq))
(define without-input-benchmarks
'(spellcheck))
(define (run-benchmark impl bm)
(let ([i (ormap (lambda (i)
(and (eq? impl (impl-name i))
i))
impls)])
(if (memq bm (impl-skips i))
(rprintf "[~a ~a ~s #f]\n" impl bm '(#f #f #f))
(begin
((impl-setup i) bm)
(let ([start (current-inexact-milliseconds)])
((impl-make i) bm)
(let ([end (current-inexact-milliseconds)])
(let loop ([n num-iterations])
(unless (zero? n)
(let ([out (open-output-bytes)])
(unless (parameterize ([current-output-port out]
[current-error-port out])
((impl-run i) bm))
(error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm))
(rprintf "[~a ~a ~s ~a]\n"
impl
bm
((impl-extract-result i) bm (get-output-bytes out))
(inexact->exact (round (- end start)))))
(loop (sub1 n)))))
((impl-clean-up i) bm))))
(flush-output)))
;; Extract command-line arguments --------------------
(define-values (actual-benchmarks-to-run
actual-implementations-to-run
num-iterations)
(process-command-line benchmarks
'()
(map impl-name impls) '() ; no obsolete implementations here
3))
(define-runtime-path bm-directory ".")
;; Run benchmarks -------------------------------
#;(rprintf "; ~a\n" (date->string (seconds->date (current-seconds)) #t))
(parameterize ([current-directory bm-directory])
(for-each (lambda (impl)
(map (lambda (bm)
(run-benchmark impl bm))
actual-benchmarks-to-run))
actual-implementations-to-run)))

2
collects/tests/racket/benchmarks/shootout/typed/chameneos-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module chameneos-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/chameneos-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module chameneos-optimizing "wrap-typed-optimizing.ss")

108
collects/tests/racket/benchmarks/shootout/typed/chameneos.rktl Normal file
View File

@ -0,0 +1,108 @@
;;; The Great Computer Language Shootout
;;; http://shootout.alioth.debian.org/
;;;
;;; Uses Racket threads
(require racket/cmdline
racket/match)
(define-type Color (U 'red 'yellow 'blue))
(define-type MeetingChannel (Channelof (Pair (Channelof (Option (Pair Color Symbol)))
(Pair Color Symbol))))
(define-type ResultChannel (Channelof (Pair Integer Integer)))
(: change (Color Color -> Color))
(define (change c1 c2)
(case c1
[(red)
(case c2 [(blue) 'yellow] [(yellow) 'blue] [else c1])]
[(yellow)
(case c2 [(blue) 'red] [(red) 'blue] [else c1])]
[(blue)
(case c2 [(yellow) 'red] [(red) 'yellow] [else c1])]))
(let ([colors '(blue red yellow)])
(for*: ([a : Color colors][b : Color colors])
(printf "~a + ~a -> ~a\n" a b (change a b))))
(: place (MeetingChannel Integer -> Thread))
(define (place meeting-ch n)
(thread
(lambda ()
(let: loop : Void ([n : Integer n])
(if (zero? n)
;; Fade all:
(let loop ()
(let ([c (channel-get meeting-ch)])
(channel-put (car c) #f)
(loop)))
;; Let two meet:
(match-let ([(cons ch1 v1) (channel-get meeting-ch)]
[(cons ch2 v2) (channel-get meeting-ch)])
(channel-put ch1 v2)
(channel-put ch2 v1)
(loop (sub1 n))))))))
(: creature (Color MeetingChannel ResultChannel -> Thread))
(define (creature color meeting-ch result-ch)
(thread
(lambda ()
(let: ([ch : (Channelof (Option (Pair Color Symbol))) (make-channel)]
[name : Symbol (gensym)])
(let: loop : Void ([color : Color color][met : Integer 0][same : Integer 0])
(channel-put meeting-ch (cons ch (cons color name)))
(match (channel-get ch)
[(cons other-color other-name)
;; Meet:
(sleep) ; avoid imbalance from weak fairness
(loop (change color other-color)
(add1 met)
(+ same (if (eq? name other-name)
1
0)))]
[#f
;; Done:
(channel-put result-ch (cons met same))]))))))
(: spell (Integer -> Void))
(define (spell n)
(for: ([i : Char (number->string n)])
(display " ")
(display (hash-ref digits i))))
(define digits
#hash((#\0 . "zero")
(#\1 . "one")
(#\2 . "two")
(#\3 . "three")
(#\4 . "four")
(#\5 . "five")
(#\6 . "six")
(#\7 . "seven")
(#\8 . "eight")
(#\9 . "nine")))
(: go (Integer (Listof Color) -> Void))
(define (go n inits)
(let: ([result-ch : ResultChannel (make-channel)]
[meeting-ch : MeetingChannel (make-channel)])
(place meeting-ch n)
(newline)
(for ([init inits])
(printf " ~a" init)
(creature init meeting-ch result-ch))
(newline)
(let ([results (for/list: : (Listof (Pair Integer Integer))
([i : Color inits])
(channel-get result-ch))])
(for ([r results])
(display (car r))
(spell (cdr r))
(newline))
(spell (apply + (map (inst car Integer Integer) results)))
(newline))))
(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))])
(go n '(blue red yellow))
(go n '(blue red yellow red yellow blue red yellow red blue))
(newline))

2
collects/tests/racket/benchmarks/shootout/typed/cheapconcurrency-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module cheapconcurrency-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/cheapconcurrency-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module cheapconcurrency-optimizing "wrap-typed-optimizing.ss")

23
collects/tests/racket/benchmarks/shootout/typed/cheapconcurrency.rktl Normal file
View File

@ -0,0 +1,23 @@
(require scheme/cmdline)
(: generate ((Channelof Natural) Natural -> (Channelof Natural)))
(define (generate receive-ch n)
(if (zero? n)
receive-ch
(let: ([ch : (Channelof Natural) (make-channel)])
(thread (lambda ()
(let: loop : Void ()
(channel-put ch (add1 (channel-get receive-ch)))
(loop))))
(generate ch (sub1 n)))))
(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))])
(let*: ([start-ch : (Channelof Natural) (make-channel)]
[end-ch : (Channelof Natural) (generate start-ch 500)])
(let: loop : Void ([n : Integer n][total : Integer 0])
(if (zero? n)
(printf "~a\n" total)
(begin
(channel-put start-ch 0)
(loop (sub1 n)
(+ total (channel-get end-ch))))))))

2
collects/tests/racket/benchmarks/shootout/typed/echo-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module echo-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/echo-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module echo-optimizing "wrap-typed-optimizing.ss")

49
collects/tests/racket/benchmarks/shootout/typed/echo.rktl Normal file
View File

@ -0,0 +1,49 @@
(require racket/tcp)
(define PORT 8888)
(define DATA "Hello there sailor\n")
(define n 10)
(: server ( -> Void))
(define (server)
(thread client)
(let-values ([(in out) (tcp-accept (tcp-listen PORT 5 #t))]
[(buffer) (make-string (string-length DATA))])
(file-stream-buffer-mode out 'none)
(let: loop : Void ([i : (U Integer EOF) (read-string! buffer in)]
[bytes : Integer 0])
(if (not (eof-object? i))
(begin
(display buffer out)
(loop (read-string! buffer in)
(+ bytes (string-length buffer))))
(begin
(display "server processed ")
(display bytes)
(display " bytes\n"))))))
(: client ( -> (U Void 'error)))
(define (client)
(let-values ([(in out) (tcp-connect "127.0.0.1" PORT)]
[(buffer) (make-string (string-length DATA))])
(file-stream-buffer-mode out 'none)
(let: loop : (U Void 'error) ([n : Integer n])
(if (> n 0)
(begin
(display DATA out)
(let ([i (read-string! buffer in)])
(begin
(if (equal? DATA buffer)
(loop (- n 1))
'error))))
(close-output-port out)))))
(: main ((Vectorof String) -> Void))
(define (main args)
(set! n
(if (= (vector-length args) 0)
1
(assert (string->number (vector-ref args 0)) exact-positive-integer?)))
(server))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/except-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module except-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/except-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module except-optimizing "wrap-typed-optimizing.ss")

44
collects/tests/racket/benchmarks/shootout/typed/except.rktl Normal file
View File

@ -0,0 +1,44 @@
(: HI Integer)
(define HI 0)
(: LO Integer)
(define LO 0)
(define (hi-excp? x) (eq? x 'Hi_Exception))
(define (lo-excp? x) (eq? x 'Lo_Exception))
(define (true? x) (if (boolean? x) x #t))
(: some_fun (Integer -> Any))
(define (some_fun n)
(with-handlers
([true? (lambda (exn) #f)])
(hi_fun n)))
(: hi_fun (Integer -> Any))
(define (hi_fun n)
(with-handlers
([hi-excp? (lambda (exn) (set! HI (+ HI 1))) ])
(lo_fun n)))
(: lo_fun (Integer -> Any))
(define (lo_fun n)
(with-handlers
([lo-excp? (lambda (exn) (set! LO (+ LO 1))) ])
(blowup n)))
(: blowup (Integer -> Any))
(define (blowup n)
(if (= 0 (modulo n 2))
(raise 'Hi_Exception)
(raise 'Lo_Exception)))
(: main ((Vectorof String) -> Void))
(define (main args)
(let* ((n (if (= (vector-length args) 1)
(assert (string->number (vector-ref args 0)) exact-integer?)
1)))
(do ((i 0 (+ i 1)))
((= i n))
(some_fun i)))
(printf "Exceptions: HI=~a / LO=~a~n" HI LO))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/fannkuch-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module fannkuch-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/fannkuch-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module fannkuch-optimizing "wrap-typed-optimizing.ss")

69
collects/tests/racket/benchmarks/shootout/typed/fannkuch.rktl Normal file
View File

@ -0,0 +1,69 @@
;; 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 (Natural -> Natural))
(define (fannkuch n)
(let ([pi (list->vector
(for/list: : (Listof Natural) ([i : Natural (in-range n)]) i))]
[tmp (make-vector n)]
[count (make-vector n)])
(let: loop : Natural
([flips : Natural 0]
[perms : Natural 0]
[r : Natural n])
(when (< perms 30)
(for ([x (in-vector pi)])
(display (add1 x)))
(newline))
(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 (assert (sub1 (vector-ref count r)) exact-nonnegative-integer?))
(cond
[(<= (vector-ref count r) 0)
(loop2 (add1 r))]
[else (loop flips2 (add1 perms) r)]))))))))
(: count-flips ((Vectorof Natural) (Vectorof Natural) -> Natural))
(define (count-flips pi rho)
(vector-copy! rho 0 pi)
(let: loop : Natural ([i : Natural 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) Natural Natural -> Void)))
(define (vector-reverse-slice! v i j)
(let: loop : Void
([i : Natural i]
[j : Natural (assert (sub1 j) exact-nonnegative-integer?)])
(when (> j i)
(vector-swap! v i j)
(loop (assert (add1 i) exact-nonnegative-integer?)
(assert (sub1 j) exact-nonnegative-integer?)))))
(: vector-swap! (All (X) ((Vectorof X) Natural Natural -> 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?))))

2
collects/tests/racket/benchmarks/shootout/typed/fasta-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module fasta-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/fasta-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module fasta-optimizing "wrap-typed-optimizing.ss")

115
collects/tests/racket/benchmarks/shootout/typed/fasta.rktl Normal file
View File

@ -0,0 +1,115 @@
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; fasta - benchmark
;;
;; Derived from the Chicken variant, which was
;; Contributed by Anthony Borla
(require racket/cmdline)
(define-type CumulativeTable (Listof (Pair Natural Float)))
(define +alu+
(bytes-append
#"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
#"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA"
#"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT"
#"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA"
#"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG"
#"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC"
#"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"))
(define +iub+
(list
'(#\a . 0.27) '(#\c . 0.12) '(#\g . 0.12) '(#\t . 0.27) '(#\B . 0.02)
'(#\D . 0.02) '(#\H . 0.02) '(#\K . 0.02) '(#\M . 0.02) '(#\N . 0.02)
'(#\R . 0.02) '(#\S . 0.02) '(#\V . 0.02) '(#\W . 0.02) '(#\Y . 0.02)))
(define +homosapien+
(list
'(#\a . 0.3029549426680) '(#\c . 0.1979883004921)
'(#\g . 0.1975473066391) '(#\t . 0.3015094502008)))
;; -------------
(define +line-size+ 60)
;; -------------------------------
(: make-random (Integer -> (Real -> Real)))
(define (make-random seed)
(let* ((ia 3877) (ic 29573) (im 139968) (last seed))
(lambda: ((max : Real))
(set! last (modulo (+ ic (* last ia)) im))
(/ (* max last) im))))
;; -------------------------------
(: make-cumulative-table ((Listof (Pair Char Float)) -> CumulativeTable))
(define (make-cumulative-table frequency-table)
(let ([cumulative 0.0])
(for/list: : CumulativeTable
([x : (Pair Char Float) frequency-table])
(set! cumulative (+ cumulative (cdr x)))
(cons (char->integer (car x)) cumulative))))
;; -------------
(define random-next (make-random 42))
(define +segmarker+ ">")
;; -------------
(: select-random (CumulativeTable -> Natural))
(define (select-random cumulative-table)
(let ((rvalue (random-next 1.0)))
(let select-over-threshold ([table cumulative-table])
(if (<= rvalue (cdar table))
(caar table)
(select-over-threshold (cdr table))))))
;; -------------
(: repeat-fasta (String String Integer Bytes Integer -> Void))
(define (repeat-fasta id desc n_ sequence line-length)
(let ((seqlen (bytes-length sequence))
(out (current-output-port)))
(display (string-append +segmarker+ id " " desc "\n") out)
(let: loop-o : Void
((n : Integer n_) (k : Integer 0))
(unless (<= n 0)
(let ((m (min n line-length)))
(let loop-i ((i 0) (k k))
(if (>= i m)
(begin
(newline out)
(loop-o (- n line-length) k))
(let ([k (if (= k seqlen) 0 k)])
(write-byte (bytes-ref sequence k) out)
(loop-i (add1 i) (add1 k))))))))))
;; -------------
(: random-fasta (String String Integer CumulativeTable Integer -> Void))
(define (random-fasta id desc n_ cumulative-table line-length)
(let ((out (current-output-port)))
(display (string-append +segmarker+ id " " desc "\n") out)
(let: loop-o : Void ((n : Integer n_))
(unless (<= n 0)
(for ([i (in-range (min n line-length))])
(write-byte (select-random cumulative-table) out))
(newline out)
(loop-o (- n line-length))))))
;; -------------------------------
(let ((n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))))
(repeat-fasta "ONE" "Homo sapiens alu" (* n 2) +alu+ +line-size+)
(random-fasta "TWO" "IUB ambiguity codes" (* n 3)
(make-cumulative-table +iub+) +line-size+)
(random-fasta "THREE" "Homo sapiens frequency" (* n 5)
(make-cumulative-table +homosapien+) +line-size+))

2
collects/tests/racket/benchmarks/shootout/typed/fibo-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module fibo-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/fibo-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module fibo-optimizing "wrap-typed-optimizing.ss")

14
collects/tests/racket/benchmarks/shootout/typed/fibo.rktl Normal file
View File

@ -0,0 +1,14 @@
(: fib (Integer -> Integer))
(define (fib n)
(cond ((< n 2) 1)
(else (+ (fib (- n 2)) (fib (- n 1))))))
(: main ((Vectorof String) -> Void))
(define (main args)
(let ((n (if (= (vector-length args) 0)
1
(assert (string->number (vector-ref args 0)) exact-integer?))))
(display (fib n))
(newline)))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/hash-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module hash-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/hash-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module hash-optimizing "wrap-typed-optimizing.ss")

18
collects/tests/racket/benchmarks/shootout/typed/hash.rktl Normal file
View File

@ -0,0 +1,18 @@
(: main ((Vectorof String) -> Void))
(define (main argv)
(let*: ([n : Integer (assert (string->number (vector-ref argv 0)) exact-integer?)]
[hash : (HashTable String Integer) (make-hash)]
[accum : Integer 0]
[false : ( -> False) (lambda () #f)])
(let loop ([i 1])
(unless (> i n)
(hash-set! hash (number->string i 16) i)
(loop (add1 i))))
(let loop ([i n])
(unless (zero? i)
(when (hash-ref hash (number->string i) false)
(set! accum (+ accum 1)))
(loop (sub1 i))))
(printf "~s~n" accum)))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/hash2-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module hash2-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/hash2-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module hash2-optimizing "wrap-typed-optimizing.ss")

25
collects/tests/racket/benchmarks/shootout/typed/hash2.rktl Normal file
View File

@ -0,0 +1,25 @@
(: main ((Vectorof String) -> Void))
(define (main argv)
(let*: ([n : Integer (assert (string->number (vector-ref argv 0)) exact-integer?)]
[hash1 : (HashTable String Integer) (make-hash)]
[hash2 : (HashTable String Integer) (make-hash)]
[zero : ( -> 0) (lambda () 0)])
(let loop ([i 0])
(unless (= i 10000)
(hash-set! hash1 (string-append "foo_" (number->string i)) i)
(loop (add1 i))))
(let loop ([i 0])
(unless (= i n)
(hash-for-each hash1 (lambda: ((key : String) (value : Integer))
(hash-set!
hash2
key
(+ (hash-ref hash2 key zero) value))))
(loop (add1 i))))
(printf "~s ~s ~s ~s~n"
(hash-ref hash1 "foo_1")
(hash-ref hash1 "foo_9999")
(hash-ref hash2 "foo_1")
(hash-ref hash2 "foo_9999"))))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/heapsort-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module heapsort-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/heapsort-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module heapsort-optimizing "wrap-typed-optimizing.ss")

72
collects/tests/racket/benchmarks/shootout/typed/heapsort.rktl Normal file
View File

@ -0,0 +1,72 @@
;;; heapsort.scm
;; Prints 0.9990640717878372 instead of 0.9990640718 when n=1000.
;; Updated by Justin Smith
;;
;; Updated by Brent Fulgham to provide proper output formatting
(require (only-in srfi/13 string-index string-pad-right)
(only-in mzlib/string real->decimal-string))
(define IM 139968)
(define IA 3877)
(define IC 29573)
(: LAST Natural)
(define LAST 42)
(: gen_random (Float -> Float))
(define (gen_random max)
(set! LAST (modulo (+ (* LAST IA) IC) IM))
(/ (* max LAST) IM))
(: heapsort (Natural (Vectorof Float) -> (U Void True)))
(define (heapsort n ra)
(let: ((ir : Natural n)
(l : Natural (+ (quotient n 2) 1))
(i : Natural 0)
(j : Natural 0)
(rra : Float 0.0))
(let/ec: return : True
(do: : Void
((bar : True #t))
((= 1 0))
(cond ((> l 1)
(set! l (assert (- l 1) exact-nonnegative-integer?))
(set! rra (vector-ref ra l)))
(else
(set! rra (vector-ref ra ir))
(vector-set! ra ir (vector-ref ra 1))
(set! ir (assert (- ir 1) exact-nonnegative-integer?))
(cond ((<= ir 1)
(vector-set! ra 1 rra)
(return #t)))))
(set! i l)
(set! j (* l 2))
(do ((foo #t))
((> j ir))
(cond ((and (< j ir) (< (vector-ref ra j) (vector-ref ra (+ j 1))))
(set! j (+ j 1))))
(cond ((< rra (vector-ref ra j))
(vector-set! ra i (vector-ref ra j))
(set! i j)
(set! j (+ j i)))
(else
(set! j (+ ir 1)))))
(vector-set! ra i rra)))))
(: main ((Vectorof String) -> Void))
(define (main args)
(let*: ((n : Natural
(or (and (= (vector-length args) 1)
(assert (string->number (vector-ref args 0)) exact-nonnegative-integer?))
1))
(last : Natural (+ n 1))
(ary : (Vectorof Float) (make-vector last 0.0)))
(do ((i 1 (+ i 1)))
((= i last))
(vector-set! ary i (gen_random 1.0)))
(heapsort n ary)
(printf "~a~n"
(real->decimal-string (vector-ref ary n) 10))))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/mandelbrot-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module mandelbrot-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/mandelbrot-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module mandelbrot-optimizing "wrap-typed-optimizing.ss")

68
collects/tests/racket/benchmarks/shootout/typed/mandelbrot.rktl Normal file
View File

@ -0,0 +1,68 @@
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; Derived from the Chicken variant, which was
;; Contributed by Anthony Borla
(require racket/cmdline
racket/flonum)
(define +limit-sqr+ 4.0)
(define +iterations+ 50)
;; -------------------------------
(: mandelbrot (Integer Integer Integer Float -> (U 1 0)))
(define (mandelbrot x y n ci)
(let ((cr (fl- (fl/ (fl* 2.0 (->fl x)) (->fl n)) 1.5)))
(let loop ((i 0) (zr 0.0) (zi 0.0))
(if (> i +iterations+)
1
(cond
((fl> (fl+ (fl* zr zr) (fl* zi zi)) +limit-sqr+) 0)
(else (loop (+ 1 i)
(fl+ (fl- (fl* zr zr) (fl* zi zi)) cr)
(fl+ (fl* 2.0 (fl* zr zi)) ci))))))))
;; -------------------------------
(: main (Integer -> Void))
(define (main n)
(let ((out (current-output-port)))
(fprintf out "P4\n~a ~a\n" n n)
(let loop-y ((y 0))
(when (< y n)
(let ([ci (fl- (fl/ (fl* 2.0 (->fl y)) (->fl n)) 1.0)])
(let: loop-x : Void
((x : Natural 0) (bitnum : Natural 0) (byteacc : Natural 0))
(if (< x n)
(let: ([bitnum : Natural (+ 1 bitnum)]
[byteacc : Natural (+ (arithmetic-shift byteacc 1)
(mandelbrot x y n ci))])
(cond
((= bitnum 8)
(write-byte byteacc out)
(loop-x (+ 1 x) 0 0))
[else (loop-x (+ 1 x) bitnum byteacc)]))
(begin
(when (positive? bitnum)
(write-byte (arithmetic-shift byteacc
(assert (- 8 (bitwise-and n #x7)) exact-nonnegative-integer?))
out))
(loop-y (add1 y))))))))))
;; -------------------------------
(command-line #:args (n)
(main (assert (string->number (assert n string?)) exact-integer?)))

2
collects/tests/racket/benchmarks/shootout/typed/matrix-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module matrix-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/matrix-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module matrix-optimizing "wrap-typed-optimizing.ss")

92
collects/tests/racket/benchmarks/shootout/typed/matrix.rktl Normal file
View File

@ -0,0 +1,92 @@
;; Matrix.scm
(define-type Matrix (Vectorof (Vectorof Natural)))
(define size 30)
(: 1+ (Natural -> Natural))
(define (1+ x) (+ x 1))
(: mkmatrix (Natural Natural -> Matrix))
(define (mkmatrix rows cols)
(let: ((mx : Matrix (make-vector rows (ann (vector 0) (Vectorof Natural))))
(count : Natural 1))
(do: : Void
((i : Natural 0 (1+ i)))
((= i rows))
(let: ((row : (Vectorof Natural) (make-vector cols 0)))
(do: : Void
((j : Natural 0 (1+ j)))
((= j cols))
(vector-set! row j count)
(set! count (+ count 1)))
(vector-set! mx i row)))
mx))
(: num-cols (Matrix -> Natural))
(define (num-cols mx)
(let ((row (vector-ref mx 0)))
(vector-length row)))
(: num-rows (Matrix -> Natural))
(define (num-rows mx)
(vector-length mx))
(: mmult (Natural Natural Matrix Matrix -> Matrix))
(define (mmult rows cols m1 m2)
(let: ((m3 : Matrix (make-vector rows (ann (vector 0) (Vectorof Natural)))))
(do: : Void
((i : Natural 0 (1+ i)))
((= i rows))
(let: ((m1i : (Vectorof Natural) (vector-ref m1 i))
(row : (Vectorof Natural) (make-vector cols 0)))
(do: : Void
((j : Natural 0 (1+ j)))
((= j cols))
(let: ((val : Natural 0))
(do: : Void
((k : Natural 0 (1+ k)))
((= k cols))
(set! val (+ val (* (vector-ref m1i k)
(vector-ref (vector-ref m2 k) j)))))
(vector-set! row j val)))
(vector-set! m3 i row)))
m3))
(: matrix-print (Matrix -> Void))
(define (matrix-print m)
(do: : Void
((i : Natural 0 (1+ i)))
((= i (num-rows m)))
(let ((row (vector-ref m i)))
(do: : Void
((j : Natural 0 (1+ j)))
((= j (num-cols m)))
(display (vector-ref row j))
(if (< j (num-cols m))
(display " ")
#t))
(newline))))
(define (print-list . items) (for-each display items) (newline))
(: main ((Vectorof String) -> Void))
(define (main args)
(let ((n (or (and (= (vector-length args) 1)
(assert (string->number (vector-ref args 0)) exact-integer?))
1)))
(let: ((mm : Matrix (vector (vector 0)))
(m1 : Matrix (mkmatrix size size))
(m2 : Matrix (mkmatrix size size)))
(let loop ((iter n))
(cond ((> iter 0)
(set! mm (mmult size size m1 m2))
(loop (- iter 1)))))
(let ((r0 (vector-ref mm 0))
(r2 (vector-ref mm 2))
(r3 (vector-ref mm 3))
(r4 (vector-ref mm 4)))
(print-list (vector-ref r0 0) " " (vector-ref r2 3) " "
(vector-ref r3 2) " " (vector-ref r4 4))))))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/moments-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module moments-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/moments-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module moments-optimizing "wrap-typed-optimizing.ss")

72
collects/tests/racket/benchmarks/shootout/typed/moments.rktl Normal file
View File

@ -0,0 +1,72 @@
;; Moments.scm
(require (only-in mzlib/list sort)
(only-in mzlib/string real->decimal-string)
racket/flonum)
(: to-str (Number -> String))
(define (to-str n) (real->decimal-string n 6))
(let*: ((sum : Float 0.0)
(numlist : (Listof Float)
(let: loop : (Listof Float)
((line : String (read-line))
(numlist : (Listof Float) '()))
(cond ((eof-object? line) numlist)
(else
(let ((num (exact->inexact (assert (string->number line) real?))))
(set! sum (+ num sum))
(loop (read-line) (cons num numlist))))))))
(unless (null? numlist)
(let ((n (length numlist)))
(let: ((mean : Float (/ sum n))
(average_deviation : Float 0.0)
(standard_deviation : Float 0.0)
(variance : Float 0.0)
(skew : Float 0.0)
(kurtosis : Float 0.0)
(median : Float 0.0)
(deviation : Float 0.0))
(let loop ((nums numlist))
(if (not (null? nums))
(begin
(set! deviation (- (car nums) mean))
(set! average_deviation (+ average_deviation (abs deviation)))
(set! variance (+ variance (expt deviation 2)))
(set! skew (+ skew (expt deviation 3)))
(set! kurtosis (+ kurtosis (expt deviation 4)))
(loop (cdr nums)))
#t))
(set! average_deviation (/ average_deviation (exact->inexact n)))
(set! variance (/ variance (- n 1)))
(set! standard_deviation (flsqrt variance))
(cond ((> variance 0.0)
(set! skew (/ skew (* n variance standard_deviation)))
(set! kurtosis (- (/ kurtosis (* n variance variance))
3.0))))
(set! numlist ((inst sort Float Float) numlist (lambda: ((x : Float) (y : Float))
(< x y))))
(let ((mid (quotient n 2)))
(if (zero? (modulo n 2))
(set! median (/ (+ (car (list-tail numlist mid))
(car (list-tail numlist (assert (- mid 1) exact-nonnegative-integer?))))
2.0))
(set! median (car (list-tail numlist mid)))))
(set! standard_deviation (/ (round (* standard_deviation 1000000))
1000000))
(for-each display
`("n: " ,n "\n"
"median: " ,(to-str median) "\n"
"mean: " ,(to-str mean) "\n"
"average_deviation: " ,(to-str average_deviation ) "\n"
"standard_deviation: " ,(to-str standard_deviation) "\n"
"variance: " ,(to-str variance)"\n"
"skew: " ,(to-str skew) "\n"
"kurtosis: " ,(to-str kurtosis)"\n" ))))))

2
collects/tests/racket/benchmarks/shootout/typed/nbody-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module nbody-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/nbody-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module nbody-optimizing "wrap-typed-optimizing.ss")

161
collects/tests/racket/benchmarks/shootout/typed/nbody.rktl Normal file
View File

@ -0,0 +1,161 @@
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
;;
;; Imperative-style implementation based on the SBCL implementation by
;; 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 Racket
;; by Matthew Flatt and Brent Fulgham
#|
Correct output N = 1000 is
-0.169075164
-0.169087605
|#
(require racket/cmdline
racket/flonum)
;; ------------------------------
;; define planetary masses, initial positions & velocity
(define +pi+ 3.141592653589793)
(define +days-per-year+ 365.24)
(define +solar-mass+ (* 4.0 +pi+ +pi+))
(define +dt+ 0.01)
(define-struct: body ((x : Float) (y : Float) (z : Float)
(vx : Float) (vy : Float) (vz : Float)
(mass : Float))
#:mutable)
(define *sun*
(make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
(define *jupiter*
(make-body 4.84143144246472090
-1.16032004402742839
-1.03622044471123109e-1
(* 1.66007664274403694e-3 +days-per-year+)
(* 7.69901118419740425e-3 +days-per-year+)
(* -6.90460016972063023e-5 +days-per-year+)
(* 9.54791938424326609e-4 +solar-mass+)))
(define *saturn*
(make-body 8.34336671824457987
4.12479856412430479
-4.03523417114321381e-1
(* -2.76742510726862411e-3 +days-per-year+)
(* 4.99852801234917238e-3 +days-per-year+)
(* 2.30417297573763929e-5 +days-per-year+)
(* 2.85885980666130812e-4 +solar-mass+)))
(define *uranus*
(make-body 1.28943695621391310e1
-1.51111514016986312e1
-2.23307578892655734e-1
(* 2.96460137564761618e-03 +days-per-year+)
(* 2.37847173959480950e-03 +days-per-year+)
(* -2.96589568540237556e-05 +days-per-year+)
(* 4.36624404335156298e-05 +solar-mass+)))
(define *neptune*
(make-body 1.53796971148509165e+01
-2.59193146099879641e+01
1.79258772950371181e-01
(* 2.68067772490389322e-03 +days-per-year+)
(* 1.62824170038242295e-03 +days-per-year+)
(* -9.51592254519715870e-05 +days-per-year+)
(* 5.15138902046611451e-05 +solar-mass+)))
(define *system* (list *sun* *jupiter* *saturn* *uranus* *neptune*))
;; -------------------------------
(: offset-momentum ( -> Void))
(define (offset-momentum)
(let loop-i ([i *system*] [px 0.0] [py 0.0] [pz 0.0])
(if (null? i)
(begin
(set-body-vx! (car *system*) (fl/ (fl- 0.0 px) +solar-mass+))
(set-body-vy! (car *system*) (fl/ (fl- 0.0 py) +solar-mass+))
(set-body-vz! (car *system*) (fl/ (fl- 0.0 pz) +solar-mass+)))
(let ([i1 (car i)])
(loop-i (cdr i)
(fl+ px (fl* (body-vx i1) (body-mass i1)))
(fl+ py (fl* (body-vy i1) (body-mass i1)))
(fl+ pz (fl* (body-vz i1) (body-mass i1))))))))
;; -------------------------------
(: energy ( -> Float))
(define (energy)
(let loop-o ([o *system*] [e 0.0])
(if (null? o)
e
(let* ([o1 (car o)]
[e (+ e (fl* 0.5
(fl* (body-mass o1)
(fl+ (fl+ (fl* (body-vx o1) (body-vx o1))
(fl* (body-vy o1) (body-vy o1)))
(fl* (body-vz o1) (body-vz o1))))))])
(let loop-i ([i (cdr o)] [e e])
(if (null? i)
(loop-o (cdr o) e)
(let* ([i1 (car i)]
[dx (fl- (body-x o1) (body-x i1))]
[dy (fl- (body-y o1) (body-y i1))]
[dz (fl- (body-z o1) (body-z i1))]
[dist (flsqrt (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz)))]
[e (fl- e (fl/ (fl* (body-mass o1) (body-mass i1)) dist))])
(loop-i (cdr i) e))))))))
;; -------------------------------
(: advance ( -> Void))
(define (advance)
(let loop-o ([o *system*])
(when (pair? o)
(let* ([o1 (car o)]
[o1x (body-x o1)]
[o1y (body-y o1)]
[o1z (body-z o1)]
[om (body-mass o1)])
(let loop-i ([i (cdr o)]
[vx (body-vx o1)]
[vy (body-vy o1)]
[vz (body-vz o1)])
(if (pair? i)
(let* ([i1 (car i)]
[dx (fl- o1x (body-x i1))]
[dy (fl- o1y (body-y i1))]
[dz (fl- o1z (body-z i1))]
[dist2 (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz))]
[mag (fl/ +dt+ (fl* dist2 (flsqrt dist2)))]
[dxmag (fl* dx mag)]
[dymag (fl* dy mag)]
[dzmag (fl* dz mag)]
[im (body-mass i1)])
(set-body-vx! i1 (fl+ (body-vx i1) (fl* dxmag om)))
(set-body-vy! i1 (fl+ (body-vy i1) (fl* dymag om)))
(set-body-vz! i1 (fl+ (body-vz i1) (fl* dzmag om)))
(loop-i (cdr i)
(fl- vx (fl* dxmag im))
(fl- vy (fl* dymag im))
(fl- vz (fl* dzmag im))))
(begin (set-body-vx! o1 vx)
(set-body-vy! o1 vy)
(set-body-vz! o1 vz)
(set-body-x! o1 (fl+ o1x (fl* +dt+ vx)))
(set-body-y! o1 (fl+ o1y (fl* +dt+ vy)))
(set-body-z! o1 (fl+ o1z (fl* +dt+ vz)))))))
(loop-o (cdr o)))))
;; -------------------------------
(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))])
(offset-momentum)
(printf "~a\n" (real->decimal-string (energy) 9))
(for ([i (in-range n)]) (advance))
(printf "~a\n" (real->decimal-string (energy) 9)))

2
collects/tests/racket/benchmarks/shootout/typed/nestedloop-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module nestedloop-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/nestedloop-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module nestedloop-optimizing "wrap-typed-optimizing.ss")

18
collects/tests/racket/benchmarks/shootout/typed/nestedloop.rktl Normal file
View File

@ -0,0 +1,18 @@
(require mzlib/defmacro)
(define-macro (nest n expr)
(if (> n 0)
`(let loop ([i 1]) (unless (> i n)
(nest ,(- n 1) ,expr)
(loop (add1 i))))
expr))
(: main ((Vectorof String) -> Void))
(define (main argv)
(let*: ([n : Integer (assert (string->number (vector-ref argv 0)) exact-integer?)]
[x : Integer 0])
(nest 6 (set! x (+ x 1)))
(printf "~s~n" x)))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/nsieve-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module nsieve-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/nsieve-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module nsieve-optimizing "wrap-typed-optimizing.ss")

46
collects/tests/racket/benchmarks/shootout/typed/nsieve.rktl Normal file
View File

@ -0,0 +1,46 @@
;; $Id: nsieve-mzscheme.code,v 1.6 2006/06/10 23:38:29 bfulgham Exp $
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; nsieve benchmark for The Computer Language Shootout
;; Written by Dima Dorfman, 2004
;; Converted to MzScheme by Brent Fulgham
;; Converted to Typed Scheme by Vincent St-Amour
(require scheme/cmdline)
(: nsieve (Natural -> Natural))
(define (nsieve m)
(let: ((a : (Vectorof Boolean) (make-vector m #t)))
(let loop ((i 2) (n 0))
(if (< i m)
(if (vector-ref a i)
(begin
(let clear ((j (+ i i)))
(when (< j m)
(vector-set! a j #f)
(clear (+ j i))))
(loop (+ 1 i) (+ 1 n)))
(loop (+ 1 i) n))
n))))
(: string-pad (String Natural -> String))
(define (string-pad s len)
(string-append (make-string (assert (- len (string-length s)) exact-nonnegative-integer?) #\space)
s))
(: test (Natural -> Void))
(define (test n)
(let* ((m (* (expt 2 n) 10000))
(count (nsieve m)))
(printf "Primes up to ~a ~a\n"
(string-pad (number->string m) 8)
(string-pad (number->string count) 8))))
(: main (Natural -> Void))
(define (main n)
(when (>= n 0) (test n))
(when (>= n 1) (test (assert (- n 1) exact-nonnegative-integer?)))
(when (>= n 2) (test (assert (- n 2) exact-nonnegative-integer?))))
(command-line #:args (n) (main (assert (string->number (assert n string?)) exact-nonnegative-integer?)))

2
collects/tests/racket/benchmarks/shootout/typed/nsievebits-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module nsievebits-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/nsievebits-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module nsievebits-optimizing "wrap-typed-optimizing.ss")

74
collects/tests/racket/benchmarks/shootout/typed/nsievebits.rktl Normal file
View File

@ -0,0 +1,74 @@
;;; The Great Computer Language Shootout
;;; http://shootout.alioth.debian.org/
;;
;; Adapted from CMUCL code by Dima Dorfman; bit-vector stuff by Alex Shinn;
;; cobbled together by felix, converted to MzScheme by Brent Fulgham
;; converted to Typed Scheme by Vincent St-Amour
(require scheme/cmdline)
(: make-bit-vector (Natural -> Bytes))
(define (make-bit-vector size)
(let* ((len (quotient (+ size 7) 8))
(res (make-bytes len #b11111111)))
(let ((off (remainder size 8)))
(unless (zero? off)
(bytes-set! res (- len 1) (- (arithmetic-shift 1 off) 1))))
res))
(: bit-vector-ref (Bytes Natural -> Boolean))
(define (bit-vector-ref vec i)
(let ((byte (arithmetic-shift i -3))
(off (bitwise-and i #x7)))
(and (< byte (bytes-length vec))
(not (zero? (bitwise-and (bytes-ref vec byte)
(arithmetic-shift 1 off)))))))
(: bit-vector-set! (Bytes Natural Boolean -> Void))
(define (bit-vector-set! vec i x)
(let ((byte (arithmetic-shift i -3))
(off (bitwise-and i #x7)))
(let ((val (bytes-ref vec byte))
(mask (arithmetic-shift 1 off)))
(bytes-set! vec
byte
(if x
(bitwise-ior val mask)
(bitwise-and val (bitwise-not mask)))))))
(: nsievebits (Natural -> Natural))
(define (nsievebits m)
(let ((a (make-bit-vector m)))
(: clear (Natural -> Void))
(define (clear i)
(do: : Void
([j : Natural (+ i i) (+ j i)])
((>= j m))
(bit-vector-set! a j #f)))
(let: ([c : Natural 0])
(do ([i 2 (add1 i)])
((>= i m) c)
(when (bit-vector-ref a i)
(clear i)
(set! c (add1 c)))))))
(: string-pad (String Natural -> String))
(define (string-pad s len)
(string-append (make-string (assert (- len (string-length s)) exact-nonnegative-integer?) #\space)
s))
(: test (Natural -> Void))
(define (test n)
(let* ((m (* (expt 2 n) 10000))
(count (nsievebits m)))
(printf "Primes up to ~a ~a\n"
(string-pad (number->string m) 8)
(string-pad (number->string count) 8))))
(: main (Natural -> Void))
(define (main n)
(when (>= n 0) (test n))
(when (>= n 1) (test (assert (- n 1) exact-nonnegative-integer?)))
(when (>= n 2) (test (assert (- n 2) exact-nonnegative-integer?))))
(command-line #:args (n) (main (assert (string->number (assert n string?)) exact-nonnegative-integer?)))

2
collects/tests/racket/benchmarks/shootout/typed/partialsums-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module partialsums-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/partialsums-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module partialsums-optimizing "wrap-typed-optimizing.ss")

57
collects/tests/racket/benchmarks/shootout/typed/partialsums.rktl Normal file
View File

@ -0,0 +1,57 @@
;; ---------------------------------------------------------------------
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; Based on D language implementation by Dave Fladebo [imperative version]
;;
;; Derived from the Chicken variant, which was
;; Contributed by Anthony Borla
;; ---------------------------------------------------------------------
(require scheme/cmdline)
(require scheme/flonum)
(let ((n (exact->inexact (assert (string->number (command-line #:args (n) (assert n string?)))))))
(let: loop : Void
([d : Float 0.0]
(alt : Float 1.0) (d2 : Float 0.0) (d3 : Float 0.0)
(ds : Float 0.0) (dc : Float 0.0)
(s0 : Float 0.0) (s1 : Float 0.0) (s2 : Float 0.0)
(s3 : Float 0.0) (s4 : Float 0.0) (s5 : Float 0.0)
(s6 : Float 0.0) (s7 : Float 0.0) (s8 : Float 0.0))
(if (= d n)
(let ([format-result
(lambda: ((str : String) (n : Float))
(printf str (real->decimal-string n 9)))])
(format-result "~a\t(2/3)^k\n" s0)
(format-result "~a\tk^-0.5\n" s1)
(format-result "~a\t1/k(k+1)\n" s2)
(format-result "~a\tFlint Hills\n" s3)
(format-result "~a\tCookson Hills\n" s4)
(format-result "~a\tHarmonic\n" s5)
(format-result "~a\tRiemann Zeta\n" s6)
(format-result "~a\tAlternating Harmonic\n" s7)
(format-result "~a\tGregory\n" s8))
(let*: ((d : Float (+ d 1))
(d2 : Float (* d d))
(d3 : Float (* d2 d))
(ds : Float (sin d))
(dc : Float (cos d))
(s0 : Float (+ s0 (assert (expt (/ 2.0 3) (- d 1)) real?)))
(s1 : Float (+ s1 (/ 1 (flsqrt d))))
(s2 : Float (+ s2 (/ 1 (* d (+ d 1)))))
(s3 : Float (+ s3 (/ 1 (* d3 (* ds ds)))))
(s4 : Float (+ s4 (/ 1 (* d3 (* dc dc)))))
(s5 : Float (+ s5 (/ 1 d)))
(s6 : Float (+ s6 (/ 1 d2)))
(s7 : Float (+ s7 (/ alt d)))
(s8 : Float (+ s8 (/ alt (- (* 2 d) 1))))
(alt : Float (- alt)))
(loop d
alt d2 d3 ds dc
s0 s1 s2 s3 s4 s5 s6 s7 s8)))))

2
collects/tests/racket/benchmarks/shootout/typed/pidigits-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module pidigits-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/pidigits-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module pidigits-optimizing "wrap-typed-optimizing.ss")

55
collects/tests/racket/benchmarks/shootout/typed/pidigits.rktl Normal file
View File

@ -0,0 +1,55 @@
;; The Computer Language Shootout
;; http://shootout.alioth.debian.org/
;; Based on the MLton version of the benchmark
;; contributed by Scott Cruzen
(require racket/cmdline)
(: floor_ev (Integer Integer Integer Integer Integer -> Integer))
(define (floor_ev q r s t x)
(quotient (+ (* q x) r) (+ (* s x) t)))
(: comp (Integer Integer Integer Integer Integer Integer Integer Integer
-> (values Integer Integer Integer Integer)))
(define (comp q r s t q2 r2 s2 t2)
(values (+ (* q q2) (* r s2))
(+ (* q r2) (* r t2))
(+ (* s q2) (* t s2))
(+ (* s r2) (* t t2))))
(: next (Integer Integer Integer Integer -> Integer))
(define (next q r s t) (floor_ev q r s t 3))
(: safe? (Integer Integer Integer Integer Integer -> Boolean))
(define (safe? q r s t n) (= n (floor_ev q r s t 4)))
(: prod (Integer Integer Integer Integer Integer
-> (values Integer Integer Integer Integer)))
(define (prod q r s t n) (comp 10 (* -10 n) 0 1 q r s t))
(: mk (Integer Integer Integer Integer Integer
-> (values Integer Integer Integer Integer)))
(define (mk q r s t k) (comp q r s t k (* 2 (add1 (* 2 k))) 0 (add1 (* 2 k))))
(: digit (Integer Integer Integer Integer Integer Integer Integer Integer
-> Void))
(define (digit k q r s t n row col)
(if (> n 0)
(let ([y (next q r s t)])
(if (safe? q r s t y)
(let-values ([(q r s t) (prod q r s t y)])
(if (= col 10)
(let ([row (+ row 10)])
(printf "\t:~a\n~a" row y)
(digit k q r s t (sub1 n) row 1))
(begin
(printf "~a" y)
(digit k q r s t (sub1 n) row (add1 col)))))
(let-values ([(q r s t) (mk q r s t k)])
(digit (add1 k) q r s t n row col))))
(printf "~a\t:~a\n"
(make-string (assert (- 10 col) exact-nonnegative-integer?) #\space)
(+ row col))))
(: digits (Integer -> Void))
(define (digits n)
(digit 1 1 0 0 1 n 0 0))
(digits (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?)))

2
collects/tests/racket/benchmarks/shootout/typed/pidigits1-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module pidigits1-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/pidigits1-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module pidigits1-optimizing "wrap-typed-optimizing.ss")

58
collects/tests/racket/benchmarks/shootout/typed/pidigits1.rktl Normal file
View File

@ -0,0 +1,58 @@
; The Computer Language Shootout
; http://shootout.alioth.debian.org/
; Sven Hartrumpf 2005-04-12
; Implements 'Spigot' algorithm origionally due to Stanly Rabinowitz.
; This program is based on an implementation for SCM by Aubrey Jaffer and
; Jerry D. Hedden.
(: pi (Natural Natural -> Void))
(define (pi n d)
(let*: ((r : Natural (assert (inexact->exact (floor (exp (* d (log 10))))) exact-nonnegative-integer?)) ; 10^d
(p : Natural (+ (quotient n d) 1))
(m : Natural (quotient (* p d 3322) 1000))
(a : (Vectorof Natural) (make-vector (+ m 1) 2))
(out : Output-Port (current-output-port)))
(vector-set! a m 4)
(let: j-loop : Void
([b : Natural 2][digits : Natural 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 (assert (- 10 left) exact-nonnegative-integer?) #\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 (assert (- d (string-length s)) exact-nonnegative-integer?) #\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)))))))))))
(: print-digits (Output-Port String Natural Natural Natural Natural -> Natural))
(define (print-digits out s start end digits n)
(let*: ([len : Natural (assert (- end start) exact-nonnegative-integer?)]
[cnt : Natural (assert (min len (- n digits) (- 10 (modulo digits 10)) len) exact-nonnegative-integer?)])
(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))))))
(: main ((Vectorof String) -> Void))
(define (main args)
(let ((n (if (= (vector-length args) 0)
1
(assert (string->number (vector-ref args 0)) exact-nonnegative-integer?))))
(pi n 10)))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/random-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module random-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/random-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module random-optimizing "wrap-typed-optimizing.ss")

39
collects/tests/racket/benchmarks/shootout/typed/random.rktl Normal file
View File

@ -0,0 +1,39 @@
;;; http://shootout.alioth.debian.org/
;;; Random implementation, by Jens Axel Sogaard
;;;
;;; Modified for proper string output by Brent Fulgham
;;; Modified for Typed Scheme by Vincent St-Amour
(require (only-in mzlib/string real->decimal-string))
(define IM 139968)
(define IA 3877)
(define IC 29573)
(define gen_random
(let: ((LAST : Integer 42))
(lambda: ((max : Float))
(set! LAST (modulo (+ (* LAST IA) IC) IM))
(/ (* max LAST) IM))))
(: roundto (Natural Float -> String))
(define (roundto digits num)
(let*: ([e : Integer (expt 10 digits)]
[num : Integer (round (* e (inexact->exact num)))])
(format "~a.~a"
(quotient num e)
(substring (string-append (number->string (remainder num e))
(make-string digits #\0))
0 digits))))
(let ((n (assert (string->number
(vector-ref (current-command-line-arguments)
0)) exact-integer?)))
(let loop ((iter n))
(if (> iter 1)
(begin
(gen_random 100.0)
(loop (- iter 1)))
#t))
(printf "~a~%"
(real->decimal-string (gen_random 100.0) 9)))

2
collects/tests/racket/benchmarks/shootout/typed/recursive-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module recursive-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/recursive-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module recursive-optimizing "wrap-typed-optimizing.ss")

64
collects/tests/racket/benchmarks/shootout/typed/recursive.rktl Normal file
View File

@ -0,0 +1,64 @@
;; ---------------------------------------------------------------------
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; Code based on / inspired by existing, relevant Shootout submissions
;;
;; Derived from the Chicken variant, which was
;; Contributed by Anthony Borla
;; ---------------------------------------------------------------------
(require scheme/cmdline
scheme/flonum)
;; -------------------------------
(: ack (Integer Integer -> Integer))
(define (ack m n)
(cond ((zero? m) (+ n 1))
((zero? n) (ack (- m 1) 1))
(else (ack (- m 1) (ack m (- n 1))))))
;; --------------
(: fib (Integer -> Integer))
(define (fib n)
(cond ((< n 2) 1)
(else (+ (fib (- n 2)) (fib (- n 1))))))
(: fibflt (Float -> Float))
(define (fibflt n)
(cond ((fl< n 2.0) 1.0)
(else (fl+ (fibflt (fl- n 2.0)) (fibflt (fl- n 1.0))))))
;; --------------
(: tak (Integer Integer Integer -> Integer))
(define (tak x y z)
(cond ((not (< y x)) z)
(else (tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y)))))
(: takflt (Float Float Float -> Float))
(define (takflt x y z)
(cond ((not (fl< y x)) z)
(else (takflt (takflt (fl- x 1.0) y z) (takflt (fl- y 1.0) z x) (takflt (fl- z 1.0) x y)))))
;; -------------------------------
(: main (Integer -> Void))
(define (main n)
(printf "Ack(3,~A): ~A~%" n (ack 3 n))
(printf "Fib(~a): ~a~%"
(real->decimal-string (+ 27.0 n) 1)
(real->decimal-string (fibflt (+ 27.0 n)) 1))
(set! n (- n 1))
(printf "Tak(~A,~A,~A): ~A~%" (* n 3) (* n 2) n (tak (* n 3) (* n 2) n))
(printf "Fib(3): ~A~%" (fib 3))
(printf "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1)))
;; -------------------------------
(main (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?)))

2
collects/tests/racket/benchmarks/shootout/typed/regexpdna-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module regexpdna-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/regexpdna-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module regexpdna-optimizing "wrap-typed-optimizing.ss")

57
collects/tests/racket/benchmarks/shootout/typed/regexpdna.rktl Normal file
View File

@ -0,0 +1,57 @@
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;;
;; Based on a version by by Anthony Borla
(require racket/port)
;; -------------------------------
(define VARIANTS
'(#"agggtaaa|tttaccct" #"[cgt]gggtaaa|tttaccc[acg]" #"a[act]ggtaaa|tttacc[agt]t"
#"ag[act]gtaaa|tttac[agt]ct" #"agg[act]taaa|ttta[agt]cct" #"aggg[acg]aaa|ttt[cgt]ccct"
#"agggt[cgt]aa|tt[acg]accct" #"agggta[cgt]a|t[acg]taccct" #"agggtaa[cgt]|[acg]ttaccct"))
(define IUBS
'((#"B" #"(c|g|t)") (#"D" #"(a|g|t)") (#"H" #"(a|c|t)")
(#"K" #"(g|t)") (#"M" #"(a|c)") (#"N" #"(a|c|g|t)")
(#"R" #"(a|g)") (#"S" #"(c|g)") (#"V" #"(a|c|g)")
(#"W" #"(a|t)") (#"Y" #"(c|t)")))
;; -------------------------------
(: ci-byte-regexp (Bytes -> Byte-Regexp))
(define (ci-byte-regexp s)
(byte-regexp (bytes-append #"(?i:" s #")")))
;; -------------------------------
(: match-count (Bytes Byte-Regexp Natural Natural -> Natural))
(define (match-count str rx offset cnt)
(let ([m (regexp-match-positions rx str offset)])
(if m
(match-count str rx (cdr (assert (car m))) (add1 cnt))
cnt)))
;; -------------------------------
;; Load sequence and record its length
(let* ([orig (port->bytes)]
[filtered (regexp-replace* #rx#"(?:>.*?\n)|\n" orig #"")])
;; Perform regexp counts
(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
(for/fold: : Bytes
([sequence : Bytes filtered])
([IUB : (List Bytes Bytes) IUBS])
(regexp-replace* (byte-regexp (car IUB)) sequence (cadr IUB)))])
;; Print statistics
(printf "\n~a\n~a\n~a\n"
(bytes-length orig)
(bytes-length filtered)
(bytes-length replaced))))

2
collects/tests/racket/benchmarks/shootout/typed/reversecomplement-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module reversecomplement-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/reversecomplement-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module reversecomplement-optimizing "wrap-typed-optimizing.ss")

60
collects/tests/racket/benchmarks/shootout/typed/reversecomplement.rktl Normal file
View File

@ -0,0 +1,60 @@
;; The Computer Language Benchmarks Game
;; http://shootout.alioth.debian.org/
(require scheme/cmdline)
(define translation (make-vector 128))
(for: : Void
([from-to : (List Symbol Symbol)
'([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 : Symbol))
(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))))
(: output ((Listof Bytes) -> Void))
(define (output lines)
(let*: ([str : Bytes (apply bytes-append lines)]
[o : Output-Port (current-output-port)]
[len : Natural (bytes-length str)])
(for: : Void
([offset : Natural (in-range 0 len 60)])
(write-bytes str o offset (min len (+ offset 60)))
(newline o))))
(let ([in (current-input-port)])
(let: loop : Void ([accum : (Listof Bytes) null])
(let ([l (read-bytes-line in)])
(if (eof-object? l)
(output accum)
(cond
[(regexp-match? #rx#"^>" l)
(output accum)
(printf "~a\n" l)
(loop null)]
[else
(let* ([len (bytes-length l)]
[dest (make-bytes len)])
(for ([i (in-range len)])
(bytes-set! dest
(- (- len i) 1)
(vector-ref translation (bytes-ref l i))))
(loop (cons dest accum)))])))))

2
collects/tests/racket/benchmarks/shootout/typed/reversefile-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module reversefile-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/reversefile-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module reversefile-optimizing "wrap-typed-optimizing.ss")

12
collects/tests/racket/benchmarks/shootout/typed/reversefile.rktl Normal file
View File

@ -0,0 +1,12 @@
;;; -*- mode: scheme -*-
;;; $Id: reversefile-mzscheme.code,v 1.10 2006/06/21 15:05:29 bfulgham Exp $
;;; http://shootout.alioth.debian.org/
;;; Provided by Bengt Kleberg
(let ([inport (current-input-port)])
(let: rev : Void ([lines : (Listof Bytes) null])
(let ([line (read-bytes-line inport)])
(if (eof-object? line)
(for-each (lambda (l) (printf "~a\n" l))
lines)
(rev (cons line lines))))))

128
collects/tests/racket/benchmarks/shootout/typed/run.rkt Normal file
View File

@ -0,0 +1,128 @@
(module run mzscheme
(require (only scheme/runtime-path define-runtime-path)
racket/port)
(define input-map
`(
("ackermann" "11")
("ary" "9000")
("binarytrees" "16")
("chameneos" "1000000")
("cheapconcurrency" "15000")
("echo" "150000")
("except" "2500000")
("fannkuch" "10")
("fasta" "25000000")
("fibo" "32")
("hash" "100000")
("hash2" "200")
("heapsort" "100000")
("lists" "18")
("mandelbrot" "3000")
("matrix" "600")
("moments" #f ,(lambda () (mk-sumcol-input)))
("nbody" "20000000")
("nestedloop" "18")
("nsieve" "9")
("nsievebits" "11")
("partialsums" "2500000")
("pidigits" "2500")
("pidigits1" "2500")
("random" "900000")
("recursive" "11")
("regexmatch")
("regexpdna" #f ,(lambda () (mk-regexpdna-input)))
("reversecomplement" #f ,(lambda () (mk-revcomp-input)))
("k-nucleotide" #f ,(lambda () (mk-knuc-input)))
("reversefile" #f ,(lambda () (mk-sumcol-input)))
("sieve" "1200")
("spellcheck")
("spectralnorm" "5500")
("spectralnorm-unsafe" "5500")
("strcat" "40000")
("sumcol" #f ,(lambda () (mk-sumcol-input)))
("wc" #f ,(lambda () (mk-sumcol-input)))
("wordfreq" #f ,(lambda () (mk-sumcol-input)))
))
(define-runtime-path here ".")
(define (dynreq f)
(parameterize ([current-load-relative-directory here]
[current-output-port (open-output-nowhere)])
(dynamic-require f #f)))
(define (mk-fasta n suffix)
(let ([f (build-path (find-system-path 'temp-dir) (string-append "fasta-" suffix))])
(unless (file-exists? f)
(printf "Building FASTA ~a output for input: ~a\n" n f)
(with-output-to-file f
(lambda ()
(parameterize ([current-command-line-arguments (vector n)])
(dynreq "../fasta.rkt"))))) ; we can use the untyped version to generate inputs
f))
(define (mk-revcomp-input)
(mk-fasta "2500000" "2m5"))
(define (mk-knuc-input)
(mk-fasta "1000000" "1m"))
(define (mk-regexpdna-input)
(mk-fasta "5000000" "5m"))
(define (mk-sumcol-input)
(let ([f (build-path (find-system-path 'temp-dir) "sumcol-21k")])
(unless (file-exists? f)
(printf "Building sumcol 21000 input: ~a\n" f)
(let ([c (with-input-from-file (build-path (collection-path "tests")
"racket"
"benchmarks"
"shootout"
"sumcol-input.txt")
(lambda ()
(read-bytes 10000)))])
(with-output-to-file f
(lambda ()
(let loop ([n 21000])
(unless (zero? n)
(printf "~a" c)
(loop (sub1 n))))))))
f))
(define iters
(let ([len (vector-length (current-command-line-arguments))])
(unless (<= 2 len 3)
(printf "provide ~athe name of a benchmark on the command line, which version of the benchmark to run, and an optional iteration count\n"
(if (<= len 1) "" "ONLY "))
(exit))
(if (= len 3)
(string->number (vector-ref (current-command-line-arguments) 2))
1)))
(let* ([version (vector-ref (current-command-line-arguments) 1)] ; racket, typed-scheme, typed-scheme-optimizing
[bench (vector-ref (current-command-line-arguments) 0)]
[prog (cond
((string=? version "racket") (format "../~a.rkt" bench))
((string=? version "typed-scheme") (format "~a-non-optimizing.rkt" bench))
((string=? version "typed-scheme-optimizing") (format "~a-optimizing.rkt" bench))
(else (error 'run "unknown version ~a" version)))])
(let ([m (assoc bench input-map)])
(unless m
(error 'run "cannot find input for ~a" bench))
(when (null? (cdr m))
(error 'run "don't know input for ~a" bench))
(let loop ([n iters])
(parameterize ([current-command-line-arguments
(if (cadr m)
(vector (cadr m))
(vector))]
[current-input-port
(if (null? (cddr m))
(current-input-port)
(open-input-file ((caddr m))))])
(parameterize ([current-namespace (make-namespace)])
(collect-garbage)
(collect-garbage)
(time (dynreq prog))))
(unless (= n 1)
(loop (sub1 n)))))))

2
collects/tests/racket/benchmarks/shootout/typed/sieve-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module sieve-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/sieve-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module sieve-optimizing "wrap-typed-optimizing.ss")

27
collects/tests/racket/benchmarks/shootout/typed/sieve.rktl Normal file
View File

@ -0,0 +1,27 @@
(: main ((Vectorof String) -> Void))
(define (main args)
(let: ((n : Integer
(if (= (vector-length args) 0)
1
(assert (string->number (vector-ref args 0)) exact-integer?)))
(count : Integer 0)
(flags : (Vectorof Boolean) (make-vector 8192 #t)))
(let loop ((iter n))
(if (> iter 0)
(begin
(do ((i 0 (+ i 1))) ((>= i 8192)) (vector-set! flags i #t))
(set! count 0)
(do ((i 2 (+ 1 i)))
((>= i 8192))
(if (vector-ref flags i)
(begin
(do ((k (+ i i) (+ k i)))
((>= k 8192))
(vector-set! flags k #f))
(set! count (+ 1 count)))
#t))
(loop (- iter 1)))
#t))
(display "Count: ") (display count) (newline)))
(main (current-command-line-arguments))

2
collects/tests/racket/benchmarks/shootout/typed/spectralnorm-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module spectralnorm-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/spectralnorm-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module spectralnorm-optimizing "wrap-typed-optimizing.ss")

65
collects/tests/racket/benchmarks/shootout/typed/spectralnorm.rktl Normal file
View File

@ -0,0 +1,65 @@
;; The Great Computer Language Shootout
;; http://shootout.alioth.debian.org/
;; Translated directly from the C# version, which was:
;; contributed by Isaac Gouy
(require racket/cmdline
racket/flonum)
(: Approximate (Natural -> Float))
(define (Approximate n)
(let ([u (make-flvector n 1.0)]
[v (make-flvector n 0.0)])
;; 20 steps of the power method
(for: : Void ([i : Integer (in-range 10)])
(MultiplyAtAv n u v)
(MultiplyAtAv n v u))
;; B=AtA A multiplied by A transposed
;; v.Bv /(v.v) eigenvalue of v
(let loop ([i 0][vBv 0.0][vv 0.0])
(if (= i n)
(flsqrt (fl/ vBv vv))
(let ([vi (flvector-ref v i)])
(loop (add1 i)
(fl+ vBv (fl* (flvector-ref u i) vi))
(fl+ vv (fl* vi vi))))))))
;; return element i,j of infinite matrix A
(: A (Integer Integer -> Float))
(define (A i j)
(fl/ 1.0 (fl+ (fl* (->fl (+ i j))
(fl/ (->fl (+ i (+ j 1))) 2.0))
(->fl (+ i 1)))))
;; multiply vector v by matrix A
(: MultiplyAv (Natural FlVector FlVector -> Void))
(define (MultiplyAv n v Av)
(for: : Void ([i : Natural (in-range n)])
(flvector-set! Av i
(for/fold ([r 0.0])
([j (in-range n)])
(fl+ r (fl* (A i j) (flvector-ref v j)))))))
;; multiply vector v by matrix A transposed
(: MultiplyAtv (Natural FlVector FlVector -> Void))
(define (MultiplyAtv n v Atv)
(for: : Void ([i : Natural (in-range n)])
(flvector-set! Atv i
(for/fold ([r 0.0])
([j (in-range n)])
(fl+ r (fl* (A j i) (flvector-ref v j)))))))
;; multiply vector v by matrix A and then by matrix A transposed
(: MultiplyAtAv (Natural FlVector FlVector -> Void))
(define (MultiplyAtAv n v AtAv)
(let ([u (make-flvector n 0.0)])
(MultiplyAv n v u)
(MultiplyAtv n u AtAv)))
(printf "~a\n"
(real->decimal-string
(Approximate (command-line #:args (n) (assert (string->number (assert n string?)) exact-positive-integer?)))
9))

2
collects/tests/racket/benchmarks/shootout/typed/spellcheck-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module spellcheck-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/spellcheck-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module spellcheck-optimizing "wrap-typed-optimizing.ss")

23
collects/tests/racket/benchmarks/shootout/typed/spellcheck.rktl Normal file
View File

@ -0,0 +1,23 @@
;;; The Great Computer Language Shootout
;;; http://shootout.alioth.debian.org/
;;;
;;; spellcheck benchmark
(: dict (HashTable Bytes Boolean))
(define dict (make-hash))
(with-input-from-file "Usr.Dict.Words"
(lambda ()
(let: loop : Void ()
(let ([r (read-bytes-line)])
(unless (eof-object? r)
(hash-set! dict r #t)
(loop))))))
(let ([in (current-input-port)])
(let: loop : Void ()
(let ([w (read-bytes-line in)])
(unless (eof-object? w)
(unless (hash-ref dict w (lambda () #f))
(printf "~a\n" w))
(loop)))))

2
collects/tests/racket/benchmarks/shootout/typed/strcat-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module strcat-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/strcat-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module strcat-optimizing "wrap-typed-optimizing.ss")

37
collects/tests/racket/benchmarks/shootout/typed/strcat.rktl Normal file
View File

@ -0,0 +1,37 @@
; strcat.scm
;;; SPECIFICATION
;For this test, each program should be implemented in the same way,
;according to the following specification.
;
; pseudocode for strcat test
;
; s is initialized to the null string
; repeat N times:
; append "hello\n" to s
; count the number of individual characters in s
; print the count
; There should be N distinct string append statements done in a loop.
; After each append the resultant string should be 6 characters
; longer (the length of "hello\n").
; s should be a string, string buffer, or character array.
; The program should not construct a list of strings and join it.
(define p (open-output-bytes))
(define hello #"hello\n")
(let: loop : Void
([n : Integer
(assert (string->number
(vector-ref (current-command-line-arguments) 0))
exact-integer?)])
(unless (zero? n)
(display hello p)
;; At this point, (get-output-bytes p) would
;; return the byte string accumulated so far.
(loop (sub1 n))))
(printf "~a\n" (file-position p))

2
collects/tests/racket/benchmarks/shootout/typed/sumcol-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module sumcol-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/sumcol-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module sumcol-optimizing "wrap-typed-optimizing.ss")

4
collects/tests/racket/benchmarks/shootout/typed/sumcol.rktl Normal file
View File

@ -0,0 +1,4 @@
(for/fold: : Number
([acc : Number 0])
([n : String (in-lines)])
(+ acc (assert (string->number n))))

2
collects/tests/racket/benchmarks/shootout/typed/wc-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module wc-non-optimizing "wrap-typed-non-optimizing.ss")

Some files were not shown because too many files have changed in this diff Show More