<div>Wow!  I'm both impressed and sad.  Impressed at the speed-up.  Sad that something as simple as read-char can be so slow.  And I don't find the fixed-up code nearly as ugly as the C code in libcsv.</div>
<div> </div>
<div>Phil<br><br> </div>
<div><span class="gmail_quote">On 2/10/07, <b class="gmail_sendername">Bradley Lucier</b> <<a href="mailto:lucier@math.purdue.edu">lucier@math.purdue.edu</a>> wrote:</span>
<blockquote class="gmail_quote" style="PADDING-LEFT: 1ex; MARGIN: 0px 0px 0px 0.8ex; BORDER-LEFT: #ccc 1px solid">OK, I've done a few experiments.  I've added<br><br>(declare (standard-bindings)(extended-bindings)(block)(fixnum)(not
<br>safe))<br><br>to all files.<br><br>Here's the original code on my machine, an Opteron running in 64-bit<br>mode, while giving it a 100 MB heap:<br><br>> (load "bewig")<br>"/export/users/lucier/lang/scheme/csv/bewig.o7"
<br>> (time (begin (read-all (open-input-file "data.csv") read-csv-<br>record) #t))<br>(time (begin (read-all (open-input-file "data.csv") read-csv-record)<br>#t))<br>    591 ms real time<br>    580 ms cpu time (497 user, 83 system)
<br>    2 collections accounting for 29 ms real time (25 user, 4 system)<br>    264023440 bytes allocated<br>    25865 minor faults<br>    no major faults<br>#t<br><br>Next we buffer the collection of characters into a field, (re-)using
<br>an extensible string (really ugly code at bottom):<br><br>> (load "bewig2")<br>"/export/users/lucier/lang/scheme/csv/bewig2.o17"<br>> (time (begin (read-all (open-input-file "data.csv") read-csv-
<br>record) #t))<br>(time (begin (read-all (open-input-file "data.csv") read-csv-record)<br>#t))<br>    436 ms real time<br>    435 ms cpu time (420 user, 15 system)<br>    1 collection accounting for 13 ms real time (13 user, 0 system)
<br>    45290944 bytes allocated<br>    3067 minor faults<br>    no major faults<br>#t<br><br>Next we "simply" use macro-read-char from _io.scm instead of read-<br>char in the original code:<br><br>> (load "bewig+macro-read-char")
<br>"/export/users/lucier/lang/scheme/csv/bewig+macro-read-char.o2"<br>> (time (begin (read-all (open-input-file "data.csv") read-csv-<br>record) #t))<br>(time (begin (read-all (open-input-file "
data.csv") read-csv-record)<br>#t))<br>    175 ms real time<br>    175 ms cpu time (171 user, 4 system)<br>    3 collections accounting for 29 ms real time (29 user, 1 system)<br>    264030352 bytes allocated<br>    376 minor faults
<br>    no major faults<br>#t<br><br>Finally we use macro-read-char in the ugly, buffered-output code:<br><br>> (load "bewig2+macro-read-char")<br>"/export/users/lucier/lang/scheme/csv/bewig2+macro-read-char.o2
"<br>> (time (begin (read-all (open-input-file "data.csv") read-csv-<br>record) #t))<br>(time (begin (read-all (open-input-file "data.csv") read-csv-record)<br>#t))<br>    105 ms real time<br>    105 ms cpu time (98 user, 7 system)
<br>    no collections<br>    45270736 bytes allocated<br>    3106 minor faults<br>    no major faults<br>#t<br><br>So this is over five times as fast as the original code on this test<br>file.<br><br>We gain a factor of about three just by inlining the fast path of
<br>read-char.<br><br>Marc, if you don't want Gambit to suck on simple IO processing like<br>this, you should use the macro-read-char expansion for read-char in<br>the compiler.<br><br>Brad<br><br>(define (read-csv-record . args)
<br><br>  (define (read-csv sep port)<br><br>    (define (add-char-to-field c field)<br>      (let ((length  (field-length field))<br>           (buffer  (field-buffer field)))<br>       (if (< length (string-length buffer))
<br>           (begin<br>             (string-set! buffer length c)<br>             (field-length-set! field (+ length 1))<br>             field)<br>           (let ((new-buffer (string-append buffer (make-string length))))
<br>             (string-set! new-buffer length c)<br>             (field-length-set! field (+ length 1))<br>             (field-buffer-set! field new-buffer)<br>             field))))<br><br>    (define (extract-string-from-field! field)
<br>      (let ((result (substring (field-buffer field) 0 (field-length<br>field))))<br>       (reset-field! field)<br>       result))<br><br>    (define (new-field)<br>      (cons (make-string 800)<br>           0))<br><br>
    (define (field-buffer field)<br>      (car field))<br><br>    (define (field-buffer-set! field value)<br>      (set-car! field value))<br><br>    (define (field-length field)<br>      (cdr field))<br><br>    (define (field-length-set! field value)
<br>      (set-cdr! field value))<br><br>    (define (reset-field! field)<br>      (field-length-set! field 0)<br>      field)<br><br>    (define (add-field! field fields)<br>      (cons (extract-string-from-field! field) fields))
<br><br><br>    (define (start field fields)<br>      (let ((c (read-char port)))<br>        (cond ((eof-object? c)<br>              (reverse fields))<br>              ((char=? #\return c)<br>              (carriage-return field fields))
<br>              ((char=? #\newline c)<br>              (line-feed field fields))<br>              ((char=? #\" c)<br>              (quoted-field field fields))<br>              ((char=? sep c)<br>              (let ((fields (add-field! field fields)))
<br>                (not-field field fields)))<br>              (else<br>              (unquoted-field (add-char-to-field c field) fields)))))<br><br>    (define (not-field field fields)<br>      (let ((c (read-char port)))
<br>        (cond ((eof-object? c)<br>              (cons "" fields))<br>              ((char=? #\return c)<br>              (carriage-return '() (add-field! field fields)))<br>              ((char=? #\newline c)
<br>              (line-feed '() (add-field! field fields)))<br>              ((char=? #\" c)<br>              (quoted-field field fields))<br>              ((char=? sep c)<br>              (let ((fields (add-field! field fields)))
<br>                (not-field field fields)))<br>             (else<br>              (unquoted-field (add-char-to-field c field) fields)))))<br><br>    (define (quoted-field field fields)<br>      (let ((c (read-char port)))
<br>        (cond ((eof-object? c)<br>              (add-field! field fields))<br>              ((char=? #\" c)<br>              (may-be-doubled-quotes field fields))<br>              (else<br>              (quoted-field (add-char-to-field c field) fields)))))
<br><br>    (define (may-be-doubled-quotes field fields)<br>      (let ((c (read-char port)))<br>        (cond ((eof-object? c)<br>              (add-field! field fields))<br>              ((char=? #\return c)<br>              (carriage-return '() (add-field! field fields)))
<br>              ((char=? #\newline c)<br>              (line-feed '() (add-field! field fields)))<br>              ((char=? #\" c)<br>              (quoted-field (add-char-to-field #\" field) fields))<br>              ((char=? sep c)
<br>              (let ((fields (add-field! field fields)))<br>                (not-field field fields)))<br>              (else<br>              (unquoted-field (add-char-to-field c field) fields)))))<br><br>    (define (unquoted-field field fields)
<br>      (let ((c (read-char port)))<br>        (cond ((eof-object? c)<br>              (add-field! field fields))<br>              ((char=? #\return c)<br>              (carriage-return '() (add-field! field fields)))
<br>              ((char=? #\newline c)<br>              (line-feed '() (add-field! field fields)))<br>              ((char=? sep c)<br>              (let ((fields (add-field! field fields)))<br>                (not-field field fields)) )
<br>              (else<br>              (unquoted-field (add-char-to-field c field) fields)))))<br><br>    (define (carriage-return field fields)<br>      (if (char=? #\newline (peek-char port))<br>         (read-char port))
<br>      fields)<br><br>    (define (line-feed field fields)<br>      (if (char=? #\return (peek-char port))<br>         (read-char port))<br>      fields)<br><br>    (if (eof-object? (peek-char port))<br>       (peek-char port)
<br>       (reverse (start (new-field) '()))))<br><br>  (cond ((null? args)<br>        (read-csv #\, (current-input-port)))<br>        ((and (null? (cdr args))<br>             (char? (car args)))<br>        (read-csv (car args) (current-input-port)))
<br>        ((and (null? (cdr args))<br>             (port? (car args)))<br>        (read-csv #\, (car args)))<br>        ((and (pair? (cdr args)) (null? (cddr args))<br>              (char? (car args)) (port? (cadr args)))
<br>        (read-csv (car args) (cadr args)))<br>        (else<br>        (car '()))))<br></blockquote></div><br>