diff --git a/collects/meta/props b/collects/meta/props index 3f942dc167..6bd4b0e9f6 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1543,19 +1543,31 @@ path/s is either such a string or a list of them. "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/binarytrees.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-redux.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/hello.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/k-nucleotide.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/lists.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe.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/meteor.rktl" drdr:command-line #f "collects/tests/racket/benchmarks/shootout/typed/moments.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/nbody-generic.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/nbody-vec.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 @@ -1565,14 +1577,18 @@ path/s is either such a string or a list of them. "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/regexmatch.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-generic.rktl" drdr:command-line #f +"collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe.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/thread-ring.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 diff --git a/collects/tests/racket/benchmarks/shootout/auto.rkt b/collects/tests/racket/benchmarks/shootout/auto.rkt index 724d13d7f2..eb55cd8b71 100755 --- a/collects/tests/racket/benchmarks/shootout/auto.rkt +++ b/collects/tests/racket/benchmarks/shootout/auto.rkt @@ -74,12 +74,6 @@ exec racket -qu "$0" ${1+"$@"} (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 @@ -97,7 +91,7 @@ exec racket -qu "$0" ${1+"$@"} (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 @@ -105,7 +99,7 @@ exec racket -qu "$0" ${1+"$@"} (system (format "racket run.rkt ~a typed-scheme-optimizing" bm))) extract-racket-times clean-up-typed - untypeable-benchmarks) + '()) )) (define benchmarks @@ -123,12 +117,20 @@ exec racket -qu "$0" ${1+"$@"} hash hash2 heapsort + hello k-nucleotide lists mandelbrot + mandelbrot-generic + mandelbrot-unsafe matrix + meteor moments nbody + nbody-generic + nbody-vec + nbody-vec-generic + nbody-vec-unsafe nestedloop nothing nsieve @@ -143,8 +145,11 @@ exec racket -qu "$0" ${1+"$@"} reversefile sieve spectralnorm + spectralnorm-generic + spectralnorm-unsafe strcat sumcol + thread-ring wc wordfreq)) diff --git a/collects/tests/racket/benchmarks/shootout/meteor.rkt b/collects/tests/racket/benchmarks/shootout/meteor.rkt index a8f3e93091..23add4ea35 100644 --- a/collects/tests/racket/benchmarks/shootout/meteor.rkt +++ b/collects/tests/racket/benchmarks/shootout/meteor.rkt @@ -176,13 +176,14 @@ (define (add-solutions!) (define (add! solution) - (cond [(not (mcar solutions)) - (set-mcar! solutions solution) - (set-mcdr! solutions solution)] - [(bytes? solution (mcdr solutions)) - (set-mcdr! solutions solution)])) + (let ((head (mcar solutions))) + (cond [(not head) + (set-mcar! solutions solution) + (set-mcdr! solutions solution)] + [(bytes? solution (mcdr solutions)) + (set-mcdr! solutions solution)]))) (let* ([s (list->bytes (for/list ([pos (in-range size)]) (for/or ([color (in-range 10)]) diff --git a/collects/tests/racket/benchmarks/shootout/nbody-vec-generic.rkt b/collects/tests/racket/benchmarks/shootout/nbody-vec-generic.rkt index b76945a309..a40a754804 100644 --- a/collects/tests/racket/benchmarks/shootout/nbody-vec-generic.rkt +++ b/collects/tests/racket/benchmarks/shootout/nbody-vec-generic.rkt @@ -25,7 +25,7 @@ Correct output N = 1000 is (define +pi+ 3.141592653589793) (define +days-per-year+ 365.24) -(define +solar-mass+ (* 4 +pi+ +pi+)) +(define +solar-mass+ (* 4.0 +pi+ +pi+)) (define +dt+ 0.01) diff --git a/collects/tests/racket/benchmarks/shootout/nbody-vec.rkt b/collects/tests/racket/benchmarks/shootout/nbody-vec.rkt index a246054dd3..c87ae94c1a 100644 --- a/collects/tests/racket/benchmarks/shootout/nbody-vec.rkt +++ b/collects/tests/racket/benchmarks/shootout/nbody-vec.rkt @@ -26,7 +26,7 @@ Correct output N = 1000 is (define +pi+ 3.141592653589793) (define +days-per-year+ 365.24) -(define +solar-mass+ (* 4 +pi+ +pi+)) +(define +solar-mass+ (* 4.0 +pi+ +pi+)) (define +dt+ 0.01) diff --git a/collects/tests/racket/benchmarks/shootout/run.rkt b/collects/tests/racket/benchmarks/shootout/run.rkt index de2faf8454..9d02cae6d8 100644 --- a/collects/tests/racket/benchmarks/shootout/run.rkt +++ b/collects/tests/racket/benchmarks/shootout/run.rkt @@ -17,11 +17,19 @@ ("hash" "2000000") ("hash2" "750") ("heapsort" "1500000") + ("hello" "") ("lists" "18") ("mandelbrot" "3000") + ("mandelbrot-generic" "3000") + ("mandelbrot-unsafe" "3000") ("matrix" "10000") + ("meteor" "10000") ("moments" #f ,(lambda () (mk-moments-input))) ("nbody" "2000000") + ("nbody-generic" "2000000") + ("nbody-vec" "2000000") + ("nbody-vec-generic" "2000000") + ("nbody-vec-unsafe" "2000000") ("nestedloop" "30") ("nothing" "") ("nsieve" "12") @@ -39,8 +47,11 @@ ("sieve" "25000") ("spellcheck") ("spectralnorm" "5500") + ("spectralnorm-generic" "5500") + ("spectralnorm-unsafe" "5500") ("strcat" "50000000") ("sumcol" #f ,(lambda () (mk-sumcol-input))) + ("thread-ring" "1000000") ("wc" #f ,(lambda () (mk-wc-input))) ("wordfreq" #f ,(lambda () (mk-wordfreq-input))) )) diff --git a/collects/tests/racket/benchmarks/shootout/typed/binarytrees-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/binarytrees-non-optimizing.rkt new file mode 100644 index 0000000000..6443037142 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/binarytrees-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module binarytrees-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/binarytrees-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/binarytrees-optimizing.rkt new file mode 100644 index 0000000000..424fd9ded3 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/binarytrees-optimizing.rkt @@ -0,0 +1,2 @@ + +(module binarytrees-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/binarytrees.rktl b/collects/tests/racket/benchmarks/shootout/typed/binarytrees.rktl new file mode 100644 index 0000000000..6022011131 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/binarytrees.rktl @@ -0,0 +1,58 @@ +;;; The Great Computer Language Shootout +;;; http://shootout.alioth.debian.org/ +;;; Derived from the Chicken variant by Sven Hartrumpf + +(require racket/cmdline) + +(define-struct: node ((left : (Option node)) (val : Integer) (right : (Option node)))) + +;; Instead of (define-struct leaf (val)): +(: leaf (Integer -> node)) +(define (leaf val) (node #f val #f)) +(: leaf? (node -> Boolean)) +(define (leaf? l) (not (node-left l))) +(: leaf-val (node -> Integer)) +(define (leaf-val l) (node-val l)) + +(: make (Integer Integer -> node)) +(define (make item d) + (if (= d 0) + (leaf item) + (let ((item2 (* item 2)) + (d2 (- d 1))) + (node (make (- item2 1) d2) + item + (make item2 d2))))) + +(: check (node -> Integer)) +(define (check t) + (if (leaf? t) + (leaf-val t) + (+ (node-val t) (- (check (assert (node-left t))) + (check (assert (node-right t))))))) + +(: main (Integer -> Void)) +(define (main n) + (let* ((min-depth 4) + (max-depth (max (+ min-depth 2) n))) + (let ((stretch-depth (+ max-depth 1))) + (printf "stretch tree of depth ~a\t check: ~a\n" + stretch-depth + (check (make 0 stretch-depth)))) + (let ((long-lived-tree (make 0 max-depth))) + (for ((d (in-range 4 (add1 max-depth) 2))) + (let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth)))) + (printf "~a\t trees of depth ~a\t check: ~a\n" + (* 2 iterations) + d + (for/fold: : Integer ([c : Integer 0]) + ([i : Integer (in-range iterations)]) + (+ c + (check (make i d)) + (check (make (- i) d))))))) + (printf "long lived tree of depth ~a\t check: ~a\n" + max-depth + (check long-lived-tree))))) + +(command-line #:args (n) + (main (assert (string->number (assert n string?)) exact-integer?))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/hello-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/hello-non-optimizing.rkt new file mode 100644 index 0000000000..83b89cf540 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/hello-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module hello-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/hello-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/hello-optimizing.rkt new file mode 100644 index 0000000000..3fbe95ad07 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/hello-optimizing.rkt @@ -0,0 +1,2 @@ + +(module hello-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/hello.rktl b/collects/tests/racket/benchmarks/shootout/typed/hello.rktl new file mode 100644 index 0000000000..39c7f79299 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/hello.rktl @@ -0,0 +1 @@ +(display "hello world\n") diff --git a/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide-non-optimizing.rkt new file mode 100644 index 0000000000..24bbfff35d --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module k-nucleotide-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide-optimizing.rkt new file mode 100644 index 0000000000..561da15792 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide-optimizing.rkt @@ -0,0 +1,2 @@ + +(module k-nucleotide-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide.rktl b/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide.rktl new file mode 100644 index 0000000000..152cede4d7 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/k-nucleotide.rktl @@ -0,0 +1,52 @@ +;; The Computer Language Shootout +;; http://shootout.alioth.debian.org/ + +(: all-counts (Integer String -> (HashTable Symbol Integer))) +(define (all-counts len dna) + (let: ([table : (HashTable Symbol Integer) (make-hasheq)] + [seq : String (make-string len)]) + (for: ([s : Integer (in-range (- (string-length dna) len) -1 -1)]) + (string-copy! seq 0 dna s (+ s len)) + (let ([key (string->symbol seq)]) + (let ([cnt (hash-ref table key (lambda () 0))]) + (hash-set! table key (add1 cnt))))) + table)) + +(: write-freqs ((HashTable Symbol Integer) -> Void)) +(define (write-freqs table) + (let*: ([content : (Listof (Pair Symbol Integer)) (hash-map table (inst cons Symbol Integer))] + [total : Float (exact->inexact (apply + (map (inst cdr Symbol Integer) content)))]) + (for: ([a : (Pair Symbol Integer) ((inst sort (Pair Symbol Integer) Integer) content > #:key cdr)]) + (printf "~a ~a\n" + (car a) + (real->decimal-string (* 100 (/ (cdr a) total)) 3))))) + +(: write-one-freq ((HashTable Symbol Integer) Symbol -> Void)) +(define (write-one-freq table key) + (let ([cnt (hash-ref table key (lambda () 0))]) + (printf "~a\t~a\n" cnt key))) + +(define dna + (let ([in (current-input-port)]) + ;; Skip to ">THREE ..." + (regexp-match #rx#"(?m:^>THREE.*$)" in) + (let ([s (open-output-string)]) + ;; Copy everything but newlines to s: + (for ([l (in-bytes-lines in)]) + (write-bytes l s)) + ;; Extract the string from s: + (string-upcase (get-output-string s))))) + +;; 1-nucleotide counts: +(write-freqs (all-counts 1 dna)) +(newline) + +;; 2-nucleotide counts: +(write-freqs (all-counts 2 dna)) +(newline) + +;; Specific sequences: +(for: : Void + ([seq : String '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT")]) + (write-one-freq (all-counts (string-length seq) dna) + (string->symbol seq))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/lists-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/lists-non-optimizing.rkt new file mode 100644 index 0000000000..43f187b0c6 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/lists-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module lists-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/lists-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/lists-optimizing.rkt new file mode 100644 index 0000000000..1e2f321259 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/lists-optimizing.rkt @@ -0,0 +1,2 @@ + +(module lists-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/lists.rktl b/collects/tests/racket/benchmarks/shootout/typed/lists.rktl new file mode 100644 index 0000000000..b9e31d13b9 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/lists.rktl @@ -0,0 +1,49 @@ +(require racket/mpair) +(define SIZE 10000) + +(: sequence (Integer Integer -> (MListof Integer))) +(define (sequence start stop) + (if (> start stop) + '() + (mcons start (sequence (+ start 1) stop)))) + +(: head-to-tail! ((MListof Integer) (MListof Integer) + -> (values (MListof Integer) (MListof Integer)))) +(define (head-to-tail! headlist taillist) + (when (null? taillist) (begin + (set! taillist (ann (mlist (mcar headlist)) (MListof Integer))) + (set! headlist (mcdr headlist)))) + (letrec: ((htt-helper : ((MListof Integer) -> Void) + (lambda (dest) + (when (not (null? headlist)) + (let ((headlink headlist)) + (set-mcdr! dest headlink) + (set! headlist (mcdr headlist)) + (htt-helper headlink)))))) + (htt-helper taillist) + (values headlist taillist))) + +(: test-lists ( -> Integer)) +(define (test-lists) + (let*: ([L1 : (MListof Integer) (sequence 1 SIZE)] + [L2 : (MListof Integer) (mappend L1 '())] + [L3 : (MListof Integer) '()]) + (set!-values (L2 L3) (head-to-tail! L2 L3)) + (set!-values (L3 L2) (head-to-tail! (mreverse! L3) L2)) + (set! L1 (mreverse! L1)) + (cond ((not (= SIZE (mcar L1))) 0) + ((not (equal? L1 L2)) 0) + (else (mlength L1))))) + +(: main ((Vectorof String) -> Void)) +(define (main args) + (let: ((result : Integer 0)) + (let loop ((counter (if (= (vector-length args) 0) + 1 + (assert (string->number (vector-ref args 0)) exact-integer?)))) + (when (> counter 0) + (set! result (test-lists)) + (loop (- counter 1)))) + (printf "~s~n" result))) + +(main (current-command-line-arguments)) diff --git a/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic-non-optimizing.rkt new file mode 100644 index 0000000000..84544c1606 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module mandelbrot-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic-optimizing.rkt new file mode 100644 index 0000000000..df60cdda7b --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic-optimizing.rkt @@ -0,0 +1,2 @@ + +(module mandelbrot-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic.rktl b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic.rktl new file mode 100644 index 0000000000..e7c95dc32c --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-generic.rktl @@ -0,0 +1,80 @@ +;; The Great Computer Language Shootout +;; http://shootout.alioth.debian.org/ +;; +;; Derived from the Chicken variant, which was +;; Contributed by Anthony Borla + +;; The version that uses complex number is a little +;; more elegant, but much slower: +;; (define (mandelbrot iterations x y n ci) +;; (let ((c (+ (- (/ (* 2.0 x) n) 1.5) +;; (* ci 0.0+1.0i)))) +;; (let loop ((i 0) (z 0.0+0.0i)) +;; (cond +;; [(> i iterations) 1] +;; [(> (magnitude z) 2.0) 0] +;; [else (loop (add1 i) (+ (* z z) c))])))) + +(require racket/cmdline) + +(define +limit-sqr+ 4.0) + +(define +iterations+ 50) + +;; ------------------------------- + +(: mandelbrot (Integer Integer Integer Integer Float -> (U 0 1))) +(define (mandelbrot iterations x y n ci) + (let ((cr (- (/ (* 2.0 x) n) 1.5))) + (let loop ((i 0) (zr 0.0) (zi 0.0)) + (if (> i iterations) + 1 + (let ((zrq (* zr zr)) + (ziq (* zi zi))) + (cond + ((> (+ zrq ziq) +limit-sqr+) 0) + (else (loop (add1 i) + (+ (- zrq ziq) cr) + (+ (* 2.0 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 (- (/ (* 2.0 y) n) 1.0)]) + + (let: loop-x : Void + ((x : Integer 0) (bitnum : Integer 0) (byteacc : Integer 0)) + + (if (< x n) + (let ([bitnum (add1 bitnum)] + [byteacc (+ (arithmetic-shift byteacc 1) + (mandelbrot +iterations+ x y n ci))]) + + (cond + ((= bitnum 8) + (write-byte byteacc out) + (loop-x (add1 x) 0 0)) + + [else (loop-x (add1 x) bitnum byteacc)])) + + (begin + (when (positive? bitnum) + (write-byte (arithmetic-shift byteacc + (- 8 (bitwise-and n #x7))) + out)) + + (loop-y (add1 y)))))))))) + +;; ------------------------------- + +(command-line #:args (n) + (main (assert (string->number (assert n string?)) exact-integer?))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe-non-optimizing.rkt new file mode 100644 index 0000000000..753a6944af --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module mandelbrot-unsafe-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe-optimizing.rkt new file mode 100644 index 0000000000..49f0457852 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe-optimizing.rkt @@ -0,0 +1,2 @@ + +(module mandelbrot-unsafe-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe.rktl b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe.rktl new file mode 100644 index 0000000000..6f6ccb1d33 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/mandelbrot-unsafe.rktl @@ -0,0 +1,72 @@ +;; The Great Computer Language Shootout +;; http://shootout.alioth.debian.org/ +;; +;; Derived from the Chicken variant, which was +;; Contributed by Anthony Borla +;; +;; This version uses unsafe operations + +(require racket/cmdline + racket/require (for-syntax racket/base) + (filtered-in + (lambda (name) (regexp-replace #rx"unsafe-" name "")) + racket/unsafe/ops)) + +(define +limit-sqr+ 4.0) + +(define +iterations+ 50) + +;; ------------------------------- + +(: mandelbrot (Integer Integer Integer Float -> (U 0 1))) +(define (mandelbrot x y n ci) + (let ((cr (fl- (fl/ (fl* 2.0 (fx->fl x)) (fx->fl n)) 1.5))) + (let loop ((i 0) (zr 0.0) (zi 0.0)) + (if (fx> i +iterations+) + 1 + (cond + ((fl> (fl+ (fl* zr zr) (fl* zi zi)) +limit-sqr+) 0) + (else (loop (fx+ 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 (fx< y n) + + (let ([ci (fl- (fl/ (fl* 2.0 (fx->fl y)) (fx->fl n)) 1.0)]) + + (let: loop-x : Void ((x : Integer 0) (bitnum : Integer 0) (byteacc : Integer 0)) + + (if (fx< x n) + (let ([bitnum (fx+ 1 bitnum)] + [byteacc (fx+ (fxlshift byteacc 1) + (mandelbrot x y n ci))]) + + (cond + ((fx= bitnum 8) + (write-byte byteacc out) + (loop-x (fx+ 1 x) 0 0)) + + [else (loop-x (fx+ 1 x) bitnum byteacc)])) + + (begin + (when (positive? bitnum) + (write-byte (arithmetic-shift byteacc + (- 8 (bitwise-and n #x7))) + out)) + + (loop-y (add1 y)))))))))) + +;; ------------------------------- + +(command-line #:args (n) + (main (assert (string->number (assert n string?)) exact-integer?))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/meteor-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/meteor-non-optimizing.rkt new file mode 100644 index 0000000000..318144332d --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/meteor-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module meteor-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/meteor-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/meteor-optimizing.rkt new file mode 100644 index 0000000000..55178b9c29 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/meteor-optimizing.rkt @@ -0,0 +1,2 @@ + +(module meteor-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/meteor.rktl b/collects/tests/racket/benchmarks/shootout/typed/meteor.rktl new file mode 100644 index 0000000000..f6e11b9245 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/meteor.rktl @@ -0,0 +1,256 @@ +;; The Computer Language Benchmarks Game +;; http://shootout.alioth.debian.org/ +;; +;; Based on a Python version: +;; contributed by Olof Kraigher +;; modified by Tupteq +;; contributed by Matthew Flatt +;; optimized by Eli Barzilay + +(require racket/cmdline) + +(define-type Board Integer) +(define-type Piece (Listof (Vectorof Integer))) + +(define width 5) +(define height 10) +(define size (* width height)) + +(: valid-xy? (Integer Integer -> Boolean)) +(define (valid-xy? x y) + (and (0 . <= . x) + (x . < . width) + (0 . <= . y) + (y . < . height))) + +(: mover ((Integer Integer -> (values Integer Integer)) -> (Vectorof Integer))) +(define (mover fun) + (let ([t (make-vector size)]) + (for ([p (in-range size)]) + (vector-set! t p (let*-values ([(y x) (quotient/remainder p width)] + [(x y) (fun x y)]) + (if (valid-xy? x y) (+ x (* y width)) -1)))) + t)) + +(define E + (mover (lambda: ((x : Integer) (y : Integer)) (values (add1 x) y)))) +(define W + (mover (lambda: ((x : Integer) (y : Integer)) (values (sub1 x) y)))) +(define NE + (mover (lambda: ((x : Integer) (y : Integer)) (values (+ x (bitwise-and y 1)) (sub1 y))))) +(define NW + (mover (lambda: ((x : Integer) (y : Integer)) (values (sub1 (+ x (bitwise-and y 1))) (sub1 y))))) +(define SE + (mover (lambda: ((x : Integer) (y : Integer)) (values (+ x (bitwise-and y 1)) (add1 y))))) +(define SW + (mover (lambda: ((x : Integer) (y : Integer)) (values (sub1 (+ x (bitwise-and y 1))) (add1 y))))) + +(define-type Direction (Vectorof Integer)) +(define rotate-list (list E NE NW W SW SE E)) +(: rotate (Direction -> Direction)) +(define (rotate dir) + (cadr (assert (memq dir rotate-list)))) + +(define flip-alist (list (cons E W) (cons NE NW) (cons NW NE) + (cons W E) (cons SW SE) (cons SE SW))) +(: flip (Direction -> Direction)) +(define (flip dir) (cdr (assert (assq dir flip-alist)))) + +(define movers (list E W NE NW SE SW)) + +(: valid? (Integer -> Boolean)) +(define (valid? p) + (p . >= . 0)) + +(: clear? (Board Integer -> Boolean)) +(define (clear? board pos) + (not (bitwise-bit-set? board pos))) +(: set (Board Integer -> Integer)) +(define (set board pos) + (bitwise-ior board (arithmetic-shift 1 pos))) + +(: zero-count (Board -> Integer)) +(define (zero-count board) + (for/fold ([count 0]) ([i (in-range size)]) + (if (clear? board i) (add1 count) count))) + +(: find-free-cell (Board -> (Option Integer))) +(define (find-free-cell board) + (for/or ([p (in-range 0 size)]) + (and (clear? board p) p))) + +(: flood-fill (Board Integer -> Board)) +(define (flood-fill board p) + (for/fold ([board (set board p)]) ([mover (in-list movers)]) + (let ([p (vector-ref mover p)]) + (if (and (valid? p) (clear? board p)) + (flood-fill board p) + board)))) + +(: no-islands? (Board -> Boolean)) +(define (no-islands? mask) + (let ([zeros (zero-count mask)]) + (and (zeros . >= . 5) + (let loop ([mask mask] [zeros zeros]) + (if (= mask #x3FFFFFFFFFFFF) + #t + (let* ([p (assert (find-free-cell mask))] + [mask (flood-fill mask p)] + [new-zeros (zero-count mask)]) + (and ((- zeros new-zeros) . >= . 5) + (loop mask new-zeros)))))))) + +(: get-bitmask (Integer Piece -> (Option Integer))) +(define (get-bitmask p piece) + (let ([mask (arithmetic-shift 1 p)]) + (let loop ([p p] [cells piece] [mask mask]) + (if (null? cells) + mask + (let ([p (vector-ref (car cells) p)]) + (and (valid? p) (loop p (cdr cells) (set mask p)))))))) + +(: all-bitmasks (Piece Integer -> (Listof Integer))) +(define (all-bitmasks piece color) + (let: ([pieces : (Listof Piece) + (let-values ([(accum piece) + (for/fold: : (values (Listof Piece) Piece) + ([accum : (Listof Piece) null] + [piece : Piece piece]) + ([orientations : Integer (in-range 2)]) + (let-values ([(accum piece) + (for/fold: : (values (Listof Piece) Piece) + ([accum : (Listof Piece) accum] + [piece : Piece piece]) + ([orientations : Integer (in-range (- 6 (* 3 (if (= color 4) 1 0))))]) + (values (cons piece accum) + (map rotate piece)))]) + (values accum (map flip piece))))]) + accum)]) + (reverse + (for*/fold: : (Listof Integer) + ([accum : (Listof Integer) null]) + ([piece : Piece (in-list pieces)] + [p : Integer (in-range 0 size)]) + (let ([mask (get-bitmask p piece)]) + (if (and mask (no-islands? mask)) (cons mask accum) accum)))))) + +(: generate-bitmasks-pieces (Listof (Listof Direction))) +(define generate-bitmasks-pieces + (list (list E E E SE) + (list SE SW W SW) + (list W W SW SE) + (list E E SW SE) + (list NW W NW SE SW) + (list E E NE W) + (list NW NE NE W) + (list NE SE E NE) + (list SE SE E SE) + (list E NW NW NW))) +(: generate-bitmasks ( -> (Vectorof (Vectorof (Listof Board))))) +(define (generate-bitmasks) + (let ([masks-at-cell + (list->vector + (for/list: : (Listof (Vectorof (Listof Board))) + ([i : Integer (in-range size)]) + (list->vector (for/list: : (Listof (Listof Board)) + ([j : Integer (in-range 10)]) null))))]) + (for ([piece (in-list generate-bitmasks-pieces)] + [color (in-naturals)]) + (let: loop : (Vectorof (Vectorof (Listof Board))) + ([masks : (Listof Integer) ((inst sort Integer Integer) (all-bitmasks piece color) >)] + [cell-bit : Integer (sub1 size)] + [cell-counter : Integer (sub1 size)]) + (if (null? masks) + masks-at-cell + (if (bitwise-bit-set? (car masks) cell-bit) + (let ([vec (vector-ref masks-at-cell cell-counter)]) + (vector-set! vec color (cons (car masks) (vector-ref vec color))) + (loop (cdr masks) cell-bit cell-counter)) + (loop masks (sub1 cell-bit) (sub1 cell-counter)))))) + (for ([v (in-vector masks-at-cell)]) + (for ([j (in-naturals)] + [val (in-vector v)]) + (vector-set! v j (reverse val)))) + masks-at-cell)) + +(define masks-at-cell (generate-bitmasks)) + +(: masks (Vectorof Integer)) +(define masks (make-vector 10 0)) +(: to-go Integer) +(define to-go 0) +(define-type Solution Bytes) +(: solutions (MPairof (Option Solution) (Option Solution))) +(define solutions (mcons #f #f)) ; keeps (min max) solutions + +(: solve-cell! (Integer Board -> Void)) +(define (solve-cell! cell board) + (when (and (positive? to-go) (not (negative? cell))) + ;; Need solutions and not off board + (cond [(= board #x3FFFFFFFFFFFF) + ;; Solved + (add-solutions!)] + [(not (clear? board cell)) + ;; Cell full, so try next + (solve-cell! (sub1 cell) board)] + [else + ;; Recur + (for*: ([color : Integer (in-range 10)] + #:when (zero? (vector-ref masks color)) + [mask : Integer (in-list (vector-ref (vector-ref masks-at-cell cell) + color))] + #:when (zero? (bitwise-and mask board))) + (vector-set! masks color mask) + (solve-cell! (sub1 cell) (bitwise-ior board mask)) + (vector-set! masks color 0))]))) + +(: add-solutions! ( -> Void)) +(define (add-solutions!) + (: add! (Solution -> Void)) + (define (add! solution) + (let ((head (mcar solutions))) + (cond [(not head) + (set-mcar! solutions solution) + (set-mcdr! solutions solution)] + [(bytes? solution (assert (mcdr solutions))) + (set-mcdr! solutions solution)]))) + (let* ([s (list->bytes + (for/list: : (Listof Integer) ([pos : Integer (in-range size)]) + (assert (for/or: : (Option Integer) ([color : Integer (in-range 10)]) + (and (not (clear? (vector-ref masks color) pos)) + (+ color (char->integer #\0)))))))] + [ns (make-bytes size)]) + ;; Inverse + (for*: ([y : Integer (in-range height)] + [x : Integer (in-range width)]) + (bytes-set! ns (+ x (* y width)) + (bytes-ref s (+ (- width (+ x 1)) + (* width (- height (+ y 1))))))) + ;; Keep first and last only + (add! s) + (add! ns) + (set! to-go (- to-go 2)))) + +(: print-solution (Solution -> Void)) +(define (print-solution solution) + (let ([solution (bytes->string/utf-8 solution)]) + (for ([y (in-range height)]) + (when (odd? y) (display " ")) + (for ([x (in-range width)]) + (printf "~a " (string-ref solution (+ x (* y width))))) + (printf "\n")) + (newline))) + +(: solve! (Integer -> Void)) +(define (solve! n) + (set! to-go n) + (solve-cell! (sub1 size) 0)) + +(command-line #:args (n) + (let ([n (assert (string->number (assert n string?)) exact-integer?)]) + (solve! n) + (printf "~a solutions found\n\n" (- n to-go)) + (print-solution (assert (mcar solutions))) + (print-solution (assert (mcdr solutions))))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-generic-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/nbody-generic-non-optimizing.rkt new file mode 100644 index 0000000000..a90cb2759e --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-generic-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module nbody-generic-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-generic-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/nbody-generic-optimizing.rkt new file mode 100644 index 0000000000..28424f85c3 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-generic-optimizing.rkt @@ -0,0 +1,2 @@ + +(module nbody-generic-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-generic.rktl b/collects/tests/racket/benchmarks/shootout/typed/nbody-generic.rktl new file mode 100644 index 0000000000..f00fd9504a --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-generic.rktl @@ -0,0 +1,160 @@ +;; 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) + +;; ------------------------------ +;; 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*) (/ (- px) +solar-mass+)) + (set-body-vy! (car *system*) (/ (- py) +solar-mass+)) + (set-body-vz! (car *system*) (/ (- pz) +solar-mass+))) + (let ([i1 (car i)]) + (loop-i (cdr i) + (+ px (* (body-vx i1) (body-mass i1))) + (+ py (* (body-vy i1) (body-mass i1))) + (+ pz (* (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 (* 0.5 + (body-mass o1) + (+ (* (body-vx o1) (body-vx o1)) + (* (body-vy o1) (body-vy o1)) + (* (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 (- (body-x o1) (body-x i1))] + [dy (- (body-y o1) (body-y i1))] + [dz (- (body-z o1) (body-z i1))] + [dist (assert (sqrt (+ (* dx dx) (* dy dy) (* dz dz))) inexact-real?)] + [e (- e (/ (* (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 (- o1x (body-x i1))] + [dy (- o1y (body-y i1))] + [dz (- o1z (body-z i1))] + [dist2 (+ (* dx dx) (* dy dy) (* dz dz))] + [mag (assert (/ +dt+ (* dist2 (sqrt dist2))) inexact-real?)] + [dxmag (* dx mag)] + [dymag (* dy mag)] + [dzmag (* dz mag)] + [im (body-mass i1)]) + (set-body-vx! i1 (+ (body-vx i1) (* dxmag om))) + (set-body-vy! i1 (+ (body-vy i1) (* dymag om))) + (set-body-vz! i1 (+ (body-vz i1) (* dzmag om))) + (loop-i (cdr i) + (- vx (* dxmag im)) + (- vy (* dymag im)) + (- vz (* dzmag im)))) + (begin (set-body-vx! o1 vx) + (set-body-vy! o1 vy) + (set-body-vz! o1 vz) + (set-body-x! o1 (+ o1x (* +dt+ vx))) + (set-body-y! o1 (+ o1y (* +dt+ vy))) + (set-body-z! o1 (+ o1z (* +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))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic-non-optimizing.rkt new file mode 100644 index 0000000000..df4d728560 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module nbody-vec-generic-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic-optimizing.rkt new file mode 100644 index 0000000000..92e308adc7 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic-optimizing.rkt @@ -0,0 +1,2 @@ + +(module nbody-vec-generic-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic.rktl b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic.rktl new file mode 100644 index 0000000000..06f4547d90 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-generic.rktl @@ -0,0 +1,167 @@ +;; 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) + +;; ------------------------------ +;; 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 make-body vector) +(define-syntax-rule (deffield n getter setter) + (begin (define: (getter (b : (Vectorof Float))) : Float (vector-ref b n)) + (define: (setter (b : (Vectorof Float)) (x : Float)) : Void (vector-set! b n x)))) +(deffield 0 body-x set-body-x!) +(deffield 1 body-y set-body-y!) +(deffield 2 body-z set-body-z!) +(deffield 3 body-vx set-body-vx!) +(deffield 4 body-vy set-body-vy!) +(deffield 5 body-vz set-body-vz!) +(deffield 6 body-mass set-body-mass!) + +(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*) (/ (- px) +solar-mass+)) + (set-body-vy! (car *system*) (/ (- py) +solar-mass+)) + (set-body-vz! (car *system*) (/ (- pz) +solar-mass+))) + (let ([i1 (car i)]) + (loop-i (cdr i) + (+ px (* (body-vx i1) (body-mass i1))) + (+ py (* (body-vy i1) (body-mass i1))) + (+ pz (* (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 (* 0.5 + (body-mass o1) + (+ (* (body-vx o1) (body-vx o1)) + (* (body-vy o1) (body-vy o1)) + (* (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 (- (body-x o1) (body-x i1))] + [dy (- (body-y o1) (body-y i1))] + [dz (- (body-z o1) (body-z i1))] + [dist (assert (sqrt (+ (* dx dx) (* dy dy) (* dz dz))) inexact-real?)] + [e (- e (/ (* (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 (- o1x (body-x i1))] + [dy (- o1y (body-y i1))] + [dz (- o1z (body-z i1))] + [dist2 (+ (* dx dx) (* dy dy) (* dz dz))] + [mag (assert (/ +dt+ (* dist2 (sqrt dist2))) inexact-real?)] + [dxmag (* dx mag)] + [dymag (* dy mag)] + [dzmag (* dz mag)] + [im (body-mass i1)]) + (set-body-vx! i1 (+ (body-vx i1) (* dxmag om))) + (set-body-vy! i1 (+ (body-vy i1) (* dymag om))) + (set-body-vz! i1 (+ (body-vz i1) (* dzmag om))) + (loop-i (cdr i) + (- vx (* dxmag im)) + (- vy (* dymag im)) + (- vz (* dzmag im)))) + (begin (set-body-vx! o1 vx) + (set-body-vy! o1 vy) + (set-body-vz! o1 vz) + (set-body-x! o1 (+ o1x (* +dt+ vx))) + (set-body-y! o1 (+ o1y (* +dt+ vy))) + (set-body-z! o1 (+ o1z (* +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))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-non-optimizing.rkt new file mode 100644 index 0000000000..42d74c7c25 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module nbody-vec-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-optimizing.rkt new file mode 100644 index 0000000000..71c76f46af --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-optimizing.rkt @@ -0,0 +1,2 @@ + +(module nbody-vec-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe-non-optimizing.rkt new file mode 100644 index 0000000000..444e466e17 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module nbody-vec-unsafe-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe-optimizing.rkt new file mode 100644 index 0000000000..0a1ff75c1e --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe-optimizing.rkt @@ -0,0 +1,2 @@ + +(module nbody-vec-unsafe-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe.rktl b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe.rktl new file mode 100644 index 0000000000..a57e1ff568 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec-unsafe.rktl @@ -0,0 +1,170 @@ +;; 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 +;; Made unsafe and optimized by Sam TH +#| +Correct output N = 1000 is + +-0.169075164 +-0.169087605 +|# + +(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")) + racket/unsafe/ops)) + +;; ------------------------------ +;; define planetary masses, initial positions & velocity + +(define +pi+ 3.141592653589793) ;; define locally to enable inlining +(define +days-per-year+ 365.24) + +(define +solar-mass+ (* 4.0 +pi+ +pi+)) + +(define +dt+ 0.01) + +(define make-body flvector) +(define-syntax-rule (deffield n getter setter) + (begin (define-syntax-rule (getter b) (flvector-ref b n)) + (define-syntax-rule (setter b x) (flvector-set! b n x)))) +(deffield 0 body-x set-body-x!) +(deffield 1 body-y set-body-y!) +(deffield 2 body-z set-body-z!) +(deffield 3 body-vx set-body-vx!) +(deffield 4 body-vy set-body-vy!) +(deffield 5 body-vz set-body-vz!) +(deffield 6 body-mass set-body-mass!) + +(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 + (fl* 1.66007664274403694e-3 +days-per-year+) + (fl* 7.69901118419740425e-3 +days-per-year+) + (fl* -6.90460016972063023e-5 +days-per-year+) + (fl* 9.54791938424326609e-4 +solar-mass+))) + +(define *saturn* + (make-body 8.34336671824457987 + 4.12479856412430479 + -4.03523417114321381e-1 + (fl* -2.76742510726862411e-3 +days-per-year+) + (fl* 4.99852801234917238e-3 +days-per-year+) + (fl* 2.30417297573763929e-5 +days-per-year+) + (fl* 2.85885980666130812e-4 +solar-mass+))) + +(define *uranus* + (make-body 1.28943695621391310e1 + -1.51111514016986312e1 + -2.23307578892655734e-1 + (fl* 2.96460137564761618e-03 +days-per-year+) + (fl* 2.37847173959480950e-03 +days-per-year+) + (fl* -2.96589568540237556e-05 +days-per-year+) + (fl* 4.36624404335156298e-05 +solar-mass+))) + +(define *neptune* + (make-body 1.53796971148509165e+01 + -2.59193146099879641e+01 + 1.79258772950371181e-01 + (fl* 2.68067772490389322e-03 +days-per-year+) + (fl* 1.62824170038242295e-03 +days-per-year+) + (fl* -9.51592254519715870e-05 +days-per-year+) + (fl* 5.15138902046611451e-05 +solar-mass+))) + +(define *system* (vector *sun* *jupiter* *saturn* *uranus* *neptune*)) +(define *system-size* 5) +;; ------------------------------- +(: offset-momentum ( -> Void)) +(define (offset-momentum) + (let loop-i ([i 0] [px 0.0] [py 0.0] [pz 0.0]) + (if (unsafe-fx= i *system-size*) + (begin + (set-body-vx! (unsafe-vector-ref *system* 0) (fl/ (fl- 0.0 px) +solar-mass+)) + (set-body-vy! (unsafe-vector-ref *system* 0) (fl/ (fl- 0.0 py) +solar-mass+)) + (set-body-vz! (unsafe-vector-ref *system* 0) (fl/ (fl- 0.0 pz) +solar-mass+))) + (let ([i1 (unsafe-vector-ref *system* i)]) + (loop-i (unsafe-fx+ i 1) + (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 0] [e 0.0]) + (if (unsafe-fx= o *system-size*) + e + (let* ([o1 (unsafe-vector-ref *system* o)] + [e (fl+ e (fl* (fl* 0.5 (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 (unsafe-fx+ o 1)] [e e]) + (if (unsafe-fx= i *system-size*) + (loop-o (unsafe-fx+ o 1) e) + (let* ([i1 (unsafe-vector-ref *system* 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 (unsafe-fx+ i 1) e)))))))) + +;; ------------------------------- +(: advance ( -> Void)) +(define (advance) + (let loop-o ([o 0]) + (unless (unsafe-fx= o *system-size*) + (let* ([o1 (unsafe-vector-ref *system* o)]) + (let loop-i ([i (unsafe-fx+ o 1)] + [vx (body-vx o1)] + [vy (body-vy o1)] + [vz (body-vz o1)]) + (if (unsafe-fx< i *system-size*) + (let* ([i1 (unsafe-vector-ref *system* 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))] + [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)] + [om (body-mass o1)] + [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 (unsafe-fx+ i 1) + (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+ (body-x o1) (fl* +dt+ vx))) + (set-body-y! o1 (fl+ (body-y o1) (fl* +dt+ vy))) + (set-body-z! o1 (fl+ (body-z o1) (fl* +dt+ vz))))))) + (loop-o (unsafe-fx+ o 1))))) + +;; ------------------------------- + +(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))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/nbody-vec.rktl b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec.rktl new file mode 100644 index 0000000000..07de77204e --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/nbody-vec.rktl @@ -0,0 +1,168 @@ +;; 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 make-body flvector) +(define-syntax-rule (deffield n getter setter) + (begin (define: (getter (b : FlVector)) : Float (flvector-ref b n)) + (define: (setter (b : FlVector) (x : Float)) : Void (flvector-set! b n x)))) +(deffield 0 body-x set-body-x!) +(deffield 1 body-y set-body-y!) +(deffield 2 body-z set-body-z!) +(deffield 3 body-vx set-body-vx!) +(deffield 4 body-vy set-body-vy!) +(deffield 5 body-vz set-body-vz!) +(deffield 6 body-mass set-body-mass!) + +(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))) diff --git a/collects/tests/racket/benchmarks/shootout/typed/regexmatch-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/regexmatch-non-optimizing.rkt new file mode 100644 index 0000000000..a2e264e81e --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/regexmatch-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module regexmatch-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/regexmatch-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/regexmatch-optimizing.rkt new file mode 100644 index 0000000000..aa4bcac3a5 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/regexmatch-optimizing.rkt @@ -0,0 +1,2 @@ + +(module regexmatch-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/regexmatch.rktl b/collects/tests/racket/benchmarks/shootout/typed/regexmatch.rktl new file mode 100644 index 0000000000..a7da1211c3 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/regexmatch.rktl @@ -0,0 +1,67 @@ +;; $Id: regexmatch-mzscheme.code,v 1.9 2006/06/21 15:05:29 bfulgham Exp $ +;;; http://shootout.alioth.debian.org/ +;;; +;;; Based on the Chicken implementation +;;; Contributed by Brent Fulgham + +;; Uses byte regexps instead of string regexps for a fairer comparison + +;; NOTE: the running time of this benchmark is dominated by +;; construction of the `num' string. + +(require racket/match) + +(define rx + (string-append + "(?:^|[^0-9\\(])" ; (1) preceding non-digit or bol + "(" ; (2) area code + "\\(([0-9][0-9][0-9])\\)" ; (3) is either 3 digits in parens + "|" ; or + "([0-9][0-9][0-9])" ; (4) just 3 digits + ")" ; end of area code + " " ; area code is followed by one space + "([0-9][0-9][0-9])" ; (5) exchange is 3 digits + "[ -]" ; separator is either space or dash + "([0-9][0-9][0-9][0-9])" ; (6) last 4 digits + "(?:[^0-9]|$)" ; must be followed by a non-digit + )) + + +(: main ((Vectorof String) -> Void)) +(define (main args) + (let: ((n : String + (if (= (vector-length args) 0) + "1" + (vector-ref args 0))) + (phonelines : (Listof Bytes) '()) + (rx : Byte-Regexp (byte-regexp (string->bytes/utf-8 rx))) + (count : Integer 0)) + (let: loop : False + ((line : (U Bytes EOF) (read-bytes-line))) + (cond ((eof-object? line) #f) + (else + (set! phonelines (cons line phonelines)) + (loop (read-bytes-line))))) + (set! phonelines (reverse phonelines)) + (do ([n (assert (string->number n) exact-integer?) + (sub1 n)]) + ((negative? n)) + (let loop ((phones phonelines) + (count 0)) + (if (null? phones) + count + (let: ([m : (Option (Listof (Option Bytes))) + (regexp-match rx (car phones))]) + (if m + (match-let ([(list a1 a2 a3 exch numb) (cdr m)]) + (let* ([area (and a1 (or a2 a3))] + [num (bytes-append #"(" (assert area) #") " + (assert exch) #"-" + (assert numb))] + [count (add1 count)]) + (when (zero? n) + (printf "~a: ~a~n" count num)) + (loop (cdr phones) count))) + (loop (cdr phones) count)))))))) + +(main (current-command-line-arguments)) diff --git a/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic-non-optimizing.rkt new file mode 100644 index 0000000000..0ab82d6c51 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module spectralnorm-generic-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic-optimizing.rkt new file mode 100644 index 0000000000..c484df66b8 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic-optimizing.rkt @@ -0,0 +1,2 @@ + +(module spectralnorm-generic-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic.rktl b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic.rktl new file mode 100644 index 0000000000..a857f966d8 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-generic.rktl @@ -0,0 +1,62 @@ +;; 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) + +(: Approximate (Natural -> Float)) +(define (Approximate n) + (let ([u (make-vector n 1.0)] + [v (make-vector n 0.0)]) + ;; 20 steps of the power method + (for: : Void ([i : Natural (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 : Float ([i : Natural 0][vBv : Float 0.0][vv : Float 0.0]) + (if (= i n) + (assert (sqrt (/ vBv vv)) inexact-real?) + (let ([vi (vector-ref v i)]) + (loop (add1 i) + (+ vBv (* (vector-ref u i) vi)) + (+ vv (* vi vi)))))))) + +;; return element i,j of infinite matrix A +(: A (Natural Natural -> Float)) +(define (A i j) + (exact->inexact (/ 1.0 (+ (* (+ i j) (/ (+ i (+ j 1)) 2.0)) (+ i 1))))) + +;; multiply vector v by matrix A +(: MultiplyAv (Natural (Vectorof Float) (Vectorof Float) -> Void)) +(define (MultiplyAv n v Av) + (for: : Void ([i : Natural (in-range n)]) + (vector-set! Av i + (for/fold: : Float ([r : Float 0.0]) + ([j : Natural (in-range n)]) + (+ r (* (A i j) (vector-ref v j))))))) + +;; multiply vector v by matrix A transposed +(: MultiplyAtv (Natural (Vectorof Float) (Vectorof Float) -> Void)) +(define (MultiplyAtv n v Atv) + (for: : Void ([i : Natural (in-range n)]) + (vector-set! Atv i + (for/fold: : Float ([r : Float 0.0]) + ([j : Natural (in-range n)]) + (+ r (* (A j i) (vector-ref v j))))))) + +;; multiply vector v by matrix A and then by matrix A transposed +(: MultiplyAtAv (Natural (Vectorof Float) (Vectorof Float) -> Void)) +(define (MultiplyAtAv n v AtAv) + (let ([u (make-vector 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-nonnegative-integer?))) + 9)) + diff --git a/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe-non-optimizing.rkt new file mode 100644 index 0000000000..fb5f1f3b9d --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module spectralnorm-unsafe-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe-optimizing.rkt new file mode 100644 index 0000000000..a8f0aea973 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe-optimizing.rkt @@ -0,0 +1,2 @@ + +(module spectralnorm-unsafe-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe.rktl b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe.rktl new file mode 100644 index 0000000000..5eaa2a959b --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm-unsafe.rktl @@ -0,0 +1,71 @@ +;; 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/require (for-syntax racket/base) + (rename-in + (filtered-in + (lambda (name) (regexp-replace #rx"unsafe-" name "")) + racket/unsafe/ops) + [fx->fl ->fl]) + (only-in racket/flonum make-flvector)) + + +(: 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 ([i (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 : Float ([i : Natural 0][vBv : Float 0.0][vv : Float 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 (Natural Natural -> 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 ([i (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 ([i (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-nonnegative-integer?))) + 9)) diff --git a/collects/tests/racket/benchmarks/shootout/typed/spectralnorm.rktl b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm.rktl index b0b8c65153..4371c6577c 100644 --- a/collects/tests/racket/benchmarks/shootout/typed/spectralnorm.rktl +++ b/collects/tests/racket/benchmarks/shootout/typed/spectralnorm.rktl @@ -12,7 +12,7 @@ (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)]) + (for: : Void ([i : Natural (in-range 10)]) (MultiplyAtAv n u v) (MultiplyAtAv n v u)) @@ -27,7 +27,7 @@ (fl+ vv (fl* vi vi)))))))) ;; return element i,j of infinite matrix A -(: A (Integer Integer -> Float)) +(: A (Natural Natural -> Float)) (define (A i j) (fl/ 1.0 (fl+ (fl* (->fl (+ i j)) (fl/ (->fl (+ i (+ j 1))) 2.0)) @@ -60,6 +60,6 @@ (printf "~a\n" (real->decimal-string - (Approximate (command-line #:args (n) (assert (string->number (assert n string?)) exact-positive-integer?))) + (Approximate (command-line #:args (n) (assert (string->number (assert n string?)) exact-nonnegative-integer?))) 9)) diff --git a/collects/tests/racket/benchmarks/shootout/typed/thread-ring-non-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/thread-ring-non-optimizing.rkt new file mode 100644 index 0000000000..c44d06514b --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/thread-ring-non-optimizing.rkt @@ -0,0 +1,2 @@ + +(module thread-ring-non-optimizing "wrap-typed-non-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/thread-ring-optimizing.rkt b/collects/tests/racket/benchmarks/shootout/typed/thread-ring-optimizing.rkt new file mode 100644 index 0000000000..27992c15ee --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/thread-ring-optimizing.rkt @@ -0,0 +1,2 @@ + +(module thread-ring-optimizing "wrap-typed-optimizing.ss") diff --git a/collects/tests/racket/benchmarks/shootout/typed/thread-ring.rktl b/collects/tests/racket/benchmarks/shootout/typed/thread-ring.rktl new file mode 100644 index 0000000000..62e7a3c7be --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/typed/thread-ring.rktl @@ -0,0 +1,29 @@ +;; The Great Computer Language Shootout +;; http://shootout.alioth.debian.org/ +;; +;; Uses Racket threads + +(require racket/cmdline) + +;; Each thread runs this loop: +(: run (Integer Thread -> Void)) +(define (run id next) + (let ([v (assert (thread-receive) exact-integer?)]) + (cond + [(zero? v) ;; Done + (printf "~a\n" id) + (exit)] + [else ;; Keep going + (thread-send next (sub1 v)) + (run id next)]))) + + +(let ([n (command-line #:args (n) (assert (string->number (assert n string?)) exact-integer?))]) + ;; The original thread is #503. Create the rest: + (let ([t1 (for/fold: : Thread + ([next : Thread (current-thread)]) + ([id : Integer (in-range 502 0 -1)]) + (thread (lambda () (run id next))))]) + ;; Start: + (thread-send t1 n) + (run 503 t1)))