And one more optimization gets this to a total of 6x improvement.

collects/tests/racket/benchmarks/shootout/fasta.rkt

@@ -5,9 +5,10 @@
 ;;
 ;; fasta - benchmark
 ;;
-;; Very loosely based on the Chicken variant by Anthony Borla,
+;; Very loosely based on the Chicken variant by Anthony Borla, some
-;; some optimizations taken from the GCC version by Petr Prokhorenkov,
+;; optimizations taken from the GCC version by Petr Prokhorenkov, and
-;; and some more optimizations added by Eli Barzilay.
+;; additional optimizations by Eli Barzilay (not really related to the
+;; above two now).
 
 (define +alu+
   (bytes-append #"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
@@ -31,14 +32,9 @@
 
 ;; ----------------------------------------
 
-(require racket/require racket/require-syntax (for-syntax racket/base))
+(require racket/cmdline racket/require (for-syntax racket/base)
-(define-require-syntax overriding-in
+         (filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
-  (syntax-rules () [(_ R1 R2) (combine-in R2 (subtract-in R1 R2))]))
-(require (overriding-in
-          racket/flonum
-          (filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
                        racket/unsafe/ops))
-         racket/cmdline)
 
 ;; ----------------------------------------
 
@@ -58,57 +54,48 @@
 
 ;; ----------------------------------------
 
-(define (fl->fx f) (inexact->exact (flfloor f)))
-
 (define IA 3877)
 (define IC 29573)
 (define IM 139968)
 (define IM.0 (fx->fl IM))
-(define random-state 42)
 
-(define (random-next)
+(define (random-next cur) (fxmodulo (fx+ IC (fx* cur IA)) IM))
-  (set! random-state (fxmodulo (fx+ IC (fx* random-state IA)) IM))
-  random-state)
 
-(define (make-lookup-vectors frequency-table)
+(define (make-lookup-table frequency-table)
-  (define byte-vec (make-bytes IM))
+  (define v (make-bytes IM))
-  (define cumu-vec (make-flvector IM))
+  (let loop ([t frequency-table] [c 0] [c. 0.0])
-  (define (set-range from to b)
-    (for ([i (in-range (fl->fx from) (fl->fx (flround to)))])
-      (bytes-set! byte-vec i b)
-      (flvector-set! cumu-vec i from)))
-  (let loop ([t frequency-table] [c 0.0])
     (unless (null? t)
-      (let ([c1 (fl+ c (fl* IM.0 (cadar t)))])
+      (let* ([c1. (fl+ c. (fl* IM.0 (cadar t)))]
-        (set-range c c1 (char->integer (caar t)))
+             [c1 (inexact->exact (flceiling c1.))]
-        (loop (cdr t) c1))))
+             [b (char->integer (caar t))])
-  (values byte-vec cumu-vec))
+        (for ([i (in-range c c1)]) (bytes-set! v i b))
+        (loop (cdr t) c1 c1.))))
+  v)
 
-(define (random-fasta header N table)
+(define (random-fasta header N table R)
   (define out (current-output-port))
-  (define-values (lookup-byte lookup-cumu) (make-lookup-vectors table))
+  (define lookup-byte (make-lookup-table table))
-  (define (n-randoms to)
+  (define (n-randoms to R)
-    (let loop ([n 0])
+    (let loop ([n 0] [R R])
-      (when (fx< n to)
+      (if (fx< n to)
-        (let* ([i (random-next)]
+        (let ([R (random-next R)])
-               [i (if (fl< (fx->fl i) (flvector-ref lookup-cumu i))
+          (bytes-set! buf n (bytes-ref lookup-byte R))
-                    (fx- i 1) i)]
+          (loop (fx+ n 1) R))
-               [b (bytes-ref lookup-byte i)])
+        (begin (write-bytes buf out 0 (fx+ to 1)) R))))
-          (bytes-set! buf n b)
-          (loop (fx+ n 1)))))
-    (write-bytes buf out 0 (fx+ to 1)))
   (define buf (make-bytes (add1 line-length)))
   (define LF (char->integer #\newline))
   (bytes-set! buf line-length LF)
   (display header out)
-  (for ([n (in-range (quotient N line-length))]) (n-randoms line-length))
+  (let-values ([(full-lines last) (quotient/remainder N line-length)])
-  (let ([n (remainder N line-length)])
+    (let loop ([i full-lines] [R R])
-    (unless (zero? n) (bytes-set! buf n LF) (n-randoms n)))
+      (cond [(fx> i 0) (loop (fx- i 1) (n-randoms line-length R))]
-  (void))
+            [(fx> last 0) (bytes-set! buf last LF) (n-randoms last R)]
+            [else R]))))
 
 ;; ----------------------------------------
 
 (let ([n (command-line #:args (n) (string->number n))])
   (repeat-fasta ">ONE Homo sapiens alu\n" (* n 2) +alu+)
-  (random-fasta ">TWO IUB ambiguity codes\n" (* n 3) IUB)
+  (random-fasta ">THREE Homo sapiens frequency\n" (* n 5) HOMOSAPIEN
-  (random-fasta ">THREE Homo sapiens frequency\n" (* n 5) HOMOSAPIEN))
+                (random-fasta ">TWO IUB ambiguity codes\n" (* n 3) IUB 42))
+  (void))