Some improved shootout benchmarks.

* An improved version of the `fasta' benchmark: ~2.5 times faster, and
  if an inlined `unsafe-fl->fx' is added it is probably going to be
  about ~3.5 times faster.

* `reversecomplement' -- revised code that is ~2.5 times faster, further
  tweaks and unsafe ops gets it to ~4.5 times.

* Doing the structs differently in `binarytrees' and a few minor tweaks
  get it to be ~1.5 times faster.  This is probably because a leaf has
  now only one field.

* `mandelbrot' improved a little (~1.2x), but the code is pretty much a
  rewrite.  (Given some more flonum inlining it can probably do much
  better.)

* Added a comment to `pidigits-gmp' saying that it was used without
  attribution.

These versions use unsafe operations, but I'm not putting them in
separate files since it's easy to turn them off.  I've also removed
"mandelbrot-unsafe.rkt", since it was identical to the safe version.

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

@@ -4,51 +4,54 @@
 ;;; http://shootout.alioth.debian.org/
 ;;; Derived from the Chicken variant by Sven Hartrumpf
 
-(require racket/cmdline)
+(require racket/cmdline racket/require (for-syntax racket/base)
+         (filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
+                      racket/unsafe/ops))
 
-(struct node (left val right))
+(struct *leaf (val))
+(struct *node *leaf (left right))
 
-;; Instead of (define-struct leaf (val)):
+(define-syntax leaf  (make-rename-transformer #'*leaf))
-(define (leaf val) (node #f val #f))
+(define-syntax leaf? (make-rename-transformer #'*leaf?))
-(define (leaf? l) (not (node-left l)))
+(define-syntax node  (make-rename-transformer #'*node))
-(define (leaf-val l) (node-val l))
+(define-syntax node? (make-rename-transformer #'*node?))
+(define-syntax-rule (leaf-val l)   (struct-ref l 0))
+(define-syntax-rule (node-left n)  (struct-ref n 1))
+(define-syntax-rule (node-right n) (struct-ref n 2))
 
 (define (make item d)
-  (if (= d 0)
+  (if (fx= d 0)
-      (leaf item)
+    (leaf item)
-      (let ((item2 (* item 2))
+    (let ([item2 (fx* item 2)] [d2 (fx- d 1)])
-            (d2 (- d 1)))
+      (node item (make (fx- item2 1) d2) (make item2 d2)))))
-        (node (make (- item2 1) d2) 
-              item 
-              (make item2 d2)))))
 
 (define (check t)
-  (if (leaf? t)
+  (let loop ([t t] [acc 0])
-      (leaf-val t)
+    (let ([acc (fx+ (leaf-val t) acc)])
-      (+ (node-val t) (- (check (node-left t)) 
+      (if (leaf? t)
-                         (check (node-right t))))))
+        acc
+        (loop (node-right t)
+              (fx+ acc (loop (node-left t) 0)))))))
+
+(define min-depth 4)
 
 (define (main n)
-  (let* ((min-depth 4)
+  (let ([max-depth (max (+ min-depth 2) n)])
-         (max-depth (max (+ min-depth 2) n)))
+    (let ([stretch-depth (+ max-depth 1)])
-    (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)))
+    (let ([long-lived-tree (make 0 max-depth)])
-      (for ((d (in-range 4 (add1 max-depth) 2)))
+      (for ([d (in-range 4 (+ max-depth 1) 2)])
-        (let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth))))
+        (let ([iterations (expt 2 (+ (- max-depth d) min-depth))])
           (printf "~a\t trees of depth ~a\t check: ~a\n"
                   (* 2 iterations)
                   d
-                  (for/fold ([c 0])
+                  (for/fold ([c 0]) ([i (in-range iterations)])
-                            ([i (in-range iterations)])
+                    (fx+ c (fx+ (check (make i d))
-                    (+ c 
+                                (check (make (fx- 0 i) d))))))))
-                       (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) 
+(command-line #:args (n) (time (main (string->number n))))
-              (main (string->number n)))

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

@@ -5,104 +5,113 @@
 ;;
 ;; fasta - benchmark
 ;;
-;; Derived from the Chicken variant, which was
+;; Very loosely based on the Chicken variant by Anthony Borla,
-;; Contributed by Anthony Borla
+;; some optimizations taken from the GCC version by Petr Prokhorenkov.
-
-(require racket/cmdline)
 
 (define +alu+
-  (bytes-append
+  (bytes-append #"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
-   #"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG"
+                #"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA"
-   #"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA"
+                #"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT"
-   #"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT"
+                #"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA"
-   #"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA"
+                #"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG"
-   #"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG"
+                #"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC"
-   #"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC"
+                #"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"))
-   #"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"))
 
-(define +iub+
+(define IUB
-  (list
+  '([#\a 0.27] [#\c 0.12] [#\g 0.12] [#\t 0.27] [#\B 0.02]
-   '(#\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]
-   '(#\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]))
-   '(#\R . 0.02) '(#\S . 0.02) '(#\V . 0.02) '(#\W . 0.02) '(#\Y . 0.02)))
 
-(define +homosapien+
+(define HOMOSAPIEN
-  (list
+  '([#\a 0.3029549426680] [#\c 0.1979883004921]
-   '(#\a . 0.3029549426680) '(#\c . 0.1979883004921)
+    [#\g 0.1975473066391] [#\t 0.3015094502008]))
-   '(#\g . 0.1975473066391) '(#\t . 0.3015094502008)))
 
-;; -------------
+(define line-length 60)
 
-(define +line-size+ 60)
+;; ----------------------------------------
 
-;; -------------------------------
+(require racket/require racket/require-syntax (for-syntax racket/base))
+(define-require-syntax overriding-in
+  (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)
 
-(define (make-random seed)
+;; ----------------------------------------
-  (let* ((ia 3877) (ic 29573) (im 139968) (last seed))
-    (lambda (max)
-      (set! last (modulo (+ ic (* last ia)) im))
-      (/ (* max last) im))))
 
-;; -------------------------------
+(define (repeat-fasta header N sequence)
+  (define out (current-output-port))
+  (define len (bytes-length sequence))
+  (define buf (make-bytes (+ len line-length)))
+  (bytes-copy! buf 0 sequence)
+  (bytes-copy! buf len sequence 0 line-length)
+  (display header out)
+  (let loop ([n N] [start 0])
+    (when (fx> n 0)
+      (let ([end (fx+ start (fxmin n line-length))])
+        (write-bytes buf out start end)
+        (newline)
+        (loop (fx- n line-length) (if (fx> end len) (fx- end len) end))))))
 
-(define (make-cumulative-table frequency-table)
+;; ----------------------------------------
-  (let ([cumulative 0.0])
-    (for/list ([x frequency-table])
-      (set! cumulative (+ cumulative (cdr x))) 
-      (cons (char->integer (car x)) cumulative))))
 
-;; -------------
+(define lookup-size 4096)
 
-(define random-next (make-random 42))
+(define lookup-size.0 (fx->fl lookup-size))
-(define +segmarker+ ">")
 
-;; -------------
+(define (fl->fx f) (inexact->exact (flfloor f)))
 
-(define (select-random cumulative-table)
+(define IA 3877)
-  (let ((rvalue (random-next 1.0)))
+(define IC 29573)
-    (let select-over-threshold ([table cumulative-table])
+(define IM 139968)
-      (if (<= rvalue (cdar table))
+(define IM.0 (fx->fl IM))
-          (caar table)
+(define random-state 42)
-          (select-over-threshold (cdr table))))))
 
-;; -------------
+(define (random-next)
+  (set! random-state (fxmodulo (fx+ IC (fx* random-state IA)) IM))
+  (fl/ (fl* lookup-size.0 (fx->fl random-state)) IM.0))
 
-(define (repeat-fasta id desc n_ sequence line-length)
+(define (make-lookup-vectors frequency-table)
-  (let ((seqlen (bytes-length sequence))
+  (define byte-vec (make-bytes lookup-size))
-        (out (current-output-port)))
+  (define cumu-vec (make-flvector lookup-size))
-    (display (string-append +segmarker+ id " " desc "\n") out)
+  (define (set-range from to b)
-    (let loop-o ((n n_) (k 0))
+    (for ([i (in-range (fl->fx from) (fl->fx (flround to)))])
-      (unless (<= n 0) 
+      (bytes-set! byte-vec i b)
-        (let ((m (min n line-length)))
+      (flvector-set! cumu-vec i from)))
-          (let loop-i ((i 0) (k k))
+  (let loop ([t frequency-table] [c 0.0])
-            (if (>= i m) 
+    (unless (null? t)
-                (begin
+      (let ([c1 (fl+ c (fl* lookup-size.0 (cadar t)))])
-                  (newline out)
+        (set-range c c1 (char->integer (caar t)))
-                  (loop-o (- n line-length) k))
+        (loop (cdr t) c1))))
-                (let ([k (if (= k seqlen) 0 k)])
+  (values byte-vec cumu-vec))
-                  (write-byte (bytes-ref sequence k) out)
-                  (loop-i (add1 i) (add1 k))))))))))
 
-;; -------------
+(define (random-fasta header N table)
+  (define out (current-output-port))
+  (define-values (lookup-byte lookup-cumu) (make-lookup-vectors table))
+  (define (n-randoms to)
+    (let loop ([n 0])
+      (when (fx< n to)
+        (let* ([rnd (random-next)]
+               [i (fl->fx rnd)]
+               [i (if (fl< rnd (flvector-ref lookup-cumu i)) (fx- i 1) i)]
+               [b (bytes-ref lookup-byte i)])
+          (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 ([n (remainder N line-length)])
+    (unless (zero? n) (bytes-set! buf n LF) (n-randoms n)))
+  (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 ((n 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) (string->number n))])
-  
+  (repeat-fasta ">ONE Homo sapiens alu\n" (* n 2) +alu+)
-(let ((n (command-line #:args (n) (string->number n))))
+  (random-fasta ">TWO IUB ambiguity codes\n" (* n 3) IUB)
-    
+  (random-fasta ">THREE Homo sapiens frequency\n" (* n 5) HOMOSAPIEN))
-  (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+))

collects/tests/racket/benchmarks/shootout/mandelbrot-unsafe.rkt

@@ -1,72 +0,0 @@
-#lang racket/base
-
-;; 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)
-
-;; -------------------------------
-
-(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))))))))
-
-;; -------------------------------
-
-(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 ((x 0) (bitnum 0) (byteacc 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 (string->number n)))

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

@@ -2,66 +2,55 @@
 
 ;; The Great Computer Language Shootout
 ;; http://shootout.alioth.debian.org/
-;;
-;; Derived from the Chicken variant, which was
-;; Contributed by Anthony Borla
 
-(require racket/cmdline
+(require racket/require racket/require-syntax (for-syntax racket/base))
-         racket/flonum)
+(define-require-syntax overriding-in
+  (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)
 
-(define +limit-sqr+ 4.0)
+(define O (current-output-port))
 
-(define +iterations+ 50)
+(define LIMIT-SQR 4.0)
+(define ITERATIONS 50)
+(define N (command-line #:args (n) (string->number n)))
+(define N.0 (fx->fl N))
+(define 2/N (fl/ 2.0 N.0))
+(define Crs
+  (let ([v (make-flvector N)])
+    (for ([x (in-range N)])
+      (flvector-set! v x (fl- (fl/ (fx->fl (fx* 2 x)) N.0) 1.5)))
+    v))
 
-;; -------------------------------
+(define-syntax (let-n stx)
+  (syntax-case stx ()
+    [(_ N bindings E)
+     (let loop ([N (syntax-e #'N)] [E #'E])
+       (if (zero? N) E (loop (sub1 N) #`(let bindings #,E))))]))
 
-(define (mandelbrot x y n ci)
+(define-syntax-rule (mandelbrot Cr Ci)
-  (let ((cr (fl- (fl/ (fl* 2.0 (->fl x)) (->fl n)) 1.5)))
+  (let loop ([i 0] [Zr 0.0] [Zi 0.0])
-    (let loop ((i 0) (zr 0.0) (zi 0.0))
+    (cond [(fl> (fl+ (fl* Zr Zr) (fl* Zi Zi)) LIMIT-SQR) 0]
-      (if (> i +iterations+)
+          [(fx= i ITERATIONS) 1]
-          1
+          [else (let-n 5 ([Zr (fl+ (fl- (fl* Zr Zr) (fl* Zi Zi)) Cr)]
-          (cond
+                          [Zi (fl+ (fl* 2.0 (fl* Zr Zi)) Ci)])
-           ((fl> (fl+ (fl* zr zr) (fl* zi zi)) +limit-sqr+) 0)
+                  (loop (fx+ i 5) Zr Zi))])))
-           (else (loop (+ 1 i) 
-                       (fl+ (fl- (fl* zr zr) (fl* zi zi)) cr) 
-                       (fl+ (fl* 2.0 (fl* zr zi)) ci))))))))
 
-;; -------------------------------
+(fprintf O "P4\n~a ~a\n" N N)
-
+(let loop-y ([y N])
-(define (main n)
+  (let ([Ci (fl- (fl* 2/N (fx->fl y)) 1.0)])
-  (let ((out (current-output-port)))
+    (let loop-x ([x 0] [bitnum 0] [byteacc 0])
-
+      (if (fx< x N)
-    (fprintf out "P4\n~a ~a\n" n n)
+        (let* ([Cr (flvector-ref Crs x)]
-
+               [bitnum (fx+ bitnum 1)]
-    (let loop-y ((y 0))
+               [byteacc (fx+ (fxlshift byteacc 1) (mandelbrot Cr Ci))])
-
+          (cond [(fx= bitnum 8)
-      (when (< y n)
+                 (write-byte byteacc O)
-        
+                 (loop-x (fx+ x 1) 0 0)]
-        (let ([ci (fl- (fl/ (fl* 2.0 (->fl y)) (->fl n)) 1.0)])
+                [else (loop-x (fx+ x 1) bitnum byteacc)]))
-          
+        (begin (when (fx> bitnum 0)
-          (let loop-x ((x 0) (bitnum 0) (byteacc 0))
+                 (write-byte (fxlshift byteacc (fx- 8 (fxand N #x7))) O))
-
+               (when (fx> y 1) (loop-y (fx- y 1))))))))
-            (if (< x n)
-                (let ([bitnum (+ 1 bitnum)]
-                      [byteacc (+ (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 
-                                                  (- 8 (bitwise-and n #x7))) 
-                                out))
-
-                  (loop-y (add1 y))))))))))
-
-;; -------------------------------
-
-(command-line #:args (n)
-              (main (string->number n)))

collects/tests/racket/benchmarks/shootout/pidigits-gmp.rkt

@@ -4,6 +4,9 @@
 ;; http://shootout.alioth.debian.org/
 ;; Based on the Perl version of the benchmark
 ;; adapted with a GMP interface by Eli Barzilay
+;;
+;; Note that this was later used by several other shootout submissions
+;; without attribution.
 
 (require racket/cmdline
          (for-syntax racket/base)

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

@@ -3,56 +3,80 @@
 ;; The Computer Language Benchmarks Game
 ;; http://shootout.alioth.debian.org/
 
-(require racket/cmdline)
-
 (define translation (make-vector 128))
 
-(for ([from-to '([a t]
+(for ([from (in-string "ACGTUMRWSYKVHDBN")]
-                 [c g]
+      [to   (in-string "TGCAAKYWSRMBDHVN")])
-                 [g c]
+  (let ([to (char->integer to)])
-                 [t a]
+    (vector-set! translation (char->integer from) to)
-                 [u a]
+    (vector-set! translation (char->integer (char-downcase from)) to)))
-                 [m k]
-                 [r y]
-                 [w w]
-                 [s s]
-                 [y R]
-                 [k M]
-                 [v b]
-                 [h d]
-                 [d h]
-                 [b v]
-                 [n n])])
-  (let ([char (lambda (sym)
-                (string-ref (symbol->string sym) 0))])
-    (let ([from (char (car from-to))]
-          [to (char->integer (char-upcase (char (cadr from-to))))])
-      (vector-set! translation (char->integer from) to)
-      (vector-set! translation (char->integer (char-upcase from)) to))))
 
-(define (output lines)
+(define I (current-input-port))
-  (let* ([str (apply bytes-append lines)]
+(define O (current-output-port))
-         [o (current-output-port)]
-         [len (bytes-length str)])
-    (for ([offset (in-range 0 len 60)])
-      (write-bytes str o offset (min len (+ offset 60)))
-      (newline o))))
 
-(let ([in (current-input-port)])
+(define marker (char->integer #\>))
-  (let loop ([accum null])
+
-    (let ([l (read-bytes-line in)])
+(require racket/require (for-syntax racket/base)
-      (if (eof-object? l)
+         (filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name ""))
-          (output accum)
+                      racket/unsafe/ops))
-          (cond
+
-           [(regexp-match? #rx#"^>" l)
+(define line-length 60)
-            (output accum)
+(define buf-size (* 64 1024))
-            (printf "~a\n" l)
+(define out-buf ; so there's always enough room for newlines
-            (loop null)]
+  (make-bytes (+ buf-size 1 (quotient buf-size line-length))))
-           [else
+(define LF (char->integer #\newline))
-            (let* ([len (bytes-length l)]
+
-                   [dest (make-bytes len)])
+#|
-              (for ([i (in-range len)])
+The basic idea is to read the input in chunks, and keep pointers to
-                (bytes-set! dest
+them, then on output process each chunk to translate and reverse it
-                            (- (- len i) 1)
+before dumping it out.
-                            (vector-ref translation (bytes-ref l i))))
+|#
-              (loop (cons dest accum)))])))))
+
+(define (output chunks)
+  (let loop ([chunks chunks] [col line-length])
+    (when (pair? chunks)
+      (let ([chunk (car chunks)])
+        (let ([start  (vector-ref chunk 0)]
+              [end    (vector-ref chunk 1)]
+              [in-buf (vector-ref chunk 2)])
+          (let chunk-loop ([i end] [j 0] [col col])
+            (if (fx> i start)
+              (let* ([i (fx- i 1)] [b (bytes-ref in-buf i)])
+                (if (fx= b LF)
+                  (chunk-loop i j col)
+                  (let ([b (vector-ref translation b)])
+                    (if (fx= 0 col)
+                      (begin (bytes-set! out-buf j LF)
+                             (bytes-set! out-buf (fx+ j 1) b)
+                             (chunk-loop i (fx+ j 2) (fx- line-length 1)))
+                      (begin (bytes-set! out-buf j b)
+                             (chunk-loop i (fx+ j 1) (fx- col 1)))))))
+              (begin (write-bytes out-buf O 0 j)
+                     (loop (cdr chunks) col))))))))
+  (newline O))
+
+(define-syntax case-regexp-posns
+  (syntax-rules (=> else)
+    [(_ rx buf start [id B1 ...] [else B2 ...])
+     (let ([m (regexp-match-positions rx buf start)])
+       (if m (let ([id (car m)]) B1 ...) (begin B2 ...)))]))
+
+(let ([m (regexp-match #rx"^([^\n]+)\n" I)]) (display (car m)))
+
+(let loop ([buf (read-bytes buf-size I)] [start 0] [chunks '()])
+  (if (eof-object? buf)
+    (begin (output chunks) (void))
+    (case-regexp-posns #rx">" buf start
+      [p1 (output (cons (vector start (car p1) buf) chunks))
+          (case-regexp-posns #rx"\n" buf (cdr p1)
+            [p2 (write-bytes buf O (car p1) (cdr p2))
+                (loop buf (cdr p2) '())]
+            [else (write-bytes buf O (car p1))
+                  (let header-loop ()
+                    (let ([buf (read-bytes buf-size I)])
+                      (case-regexp-posns #rx"\n" buf 0
+                        [p2 (write-bytes buf O 0 (cdr p2))
+                            (loop buf (cdr p2) '())]
+                        [else (write-bytes buf O) (header-loop)])))])]
+      [else (loop (read-bytes buf-size I) 0
+                  (cons (vector start (bytes-length buf) buf) chunks))])))