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.
 
Phil

 
On 2/10/07, Bradley Lucier <lucier@math.purdue.edu> wrote:
OK, I've done a few experiments.  I've added

(declare (standard-bindings)(extended-bindings)(block)(fixnum)(not
safe))

to all files.

Here's the original code on my machine, an Opteron running in 64-bit
mode, while giving it a 100 MB heap:

> (load "bewig")
"/export/users/lucier/lang/scheme/csv/bewig.o7"
> (time (begin (read-all (open-input-file "data.csv") read-csv-
record) #t))
(time (begin (read-all (open-input-file "data.csv") read-csv-record)
#t))
    591 ms real time
    580 ms cpu time (497 user, 83 system)
    2 collections accounting for 29 ms real time (25 user, 4 system)
    264023440 bytes allocated
    25865 minor faults
    no major faults
#t

Next we buffer the collection of characters into a field, (re-)using
an extensible string (really ugly code at bottom):

> (load "bewig2")
"/export/users/lucier/lang/scheme/csv/bewig2.o17"
> (time (begin (read-all (open-input-file "data.csv") read-csv-
record) #t))
(time (begin (read-all (open-input-file "data.csv") read-csv-record)
#t))
    436 ms real time
    435 ms cpu time (420 user, 15 system)
    1 collection accounting for 13 ms real time (13 user, 0 system)
    45290944 bytes allocated
    3067 minor faults
    no major faults
#t

Next we "simply" use macro-read-char from _io.scm instead of read-
char in the original code:

> (load "bewig+macro-read-char")
"/export/users/lucier/lang/scheme/csv/bewig+macro-read-char.o2"
> (time (begin (read-all (open-input-file "data.csv") read-csv-
record) #t))
(time (begin (read-all (open-input-file " data.csv") read-csv-record)
#t))
    175 ms real time
    175 ms cpu time (171 user, 4 system)
    3 collections accounting for 29 ms real time (29 user, 1 system)
    264030352 bytes allocated
    376 minor faults
    no major faults
#t

Finally we use macro-read-char in the ugly, buffered-output code:

> (load "bewig2+macro-read-char")
"/export/users/lucier/lang/scheme/csv/bewig2+macro-read-char.o2 "
> (time (begin (read-all (open-input-file "data.csv") read-csv-
record) #t))
(time (begin (read-all (open-input-file "data.csv") read-csv-record)
#t))
    105 ms real time
    105 ms cpu time (98 user, 7 system)
    no collections
    45270736 bytes allocated
    3106 minor faults
    no major faults
#t

So this is over five times as fast as the original code on this test
file.

We gain a factor of about three just by inlining the fast path of
read-char.

Marc, if you don't want Gambit to suck on simple IO processing like
this, you should use the macro-read-char expansion for read-char in
the compiler.

Brad

(define (read-csv-record . args)

  (define (read-csv sep port)

    (define (add-char-to-field c field)
      (let ((length  (field-length field))
           (buffer  (field-buffer field)))
       (if (< length (string-length buffer))
           (begin
             (string-set! buffer length c)
             (field-length-set! field (+ length 1))
             field)
           (let ((new-buffer (string-append buffer (make-string length))))
             (string-set! new-buffer length c)
             (field-length-set! field (+ length 1))
             (field-buffer-set! field new-buffer)
             field))))

    (define (extract-string-from-field! field)
      (let ((result (substring (field-buffer field) 0 (field-length
field))))
       (reset-field! field)
       result))

    (define (new-field)
      (cons (make-string 800)
           0))

    (define (field-buffer field)
      (car field))

    (define (field-buffer-set! field value)
      (set-car! field value))

    (define (field-length field)
      (cdr field))

    (define (field-length-set! field value)
      (set-cdr! field value))

    (define (reset-field! field)
      (field-length-set! field 0)
      field)

    (define (add-field! field fields)
      (cons (extract-string-from-field! field) fields))


    (define (start field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c)
              (reverse fields))
              ((char=? #\return c)
              (carriage-return field fields))
              ((char=? #\newline c)
              (line-feed field fields))
              ((char=? #\" c)
              (quoted-field field fields))
              ((char=? sep c)
              (let ((fields (add-field! field fields)))
                (not-field field fields)))
              (else
              (unquoted-field (add-char-to-field c field) fields)))))

    (define (not-field field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c)
              (cons "" fields))
              ((char=? #\return c)
              (carriage-return '() (add-field! field fields)))
              ((char=? #\newline c)
              (line-feed '() (add-field! field fields)))
              ((char=? #\" c)
              (quoted-field field fields))
              ((char=? sep c)
              (let ((fields (add-field! field fields)))
                (not-field field fields)))
             (else
              (unquoted-field (add-char-to-field c field) fields)))))

    (define (quoted-field field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c)
              (add-field! field fields))
              ((char=? #\" c)
              (may-be-doubled-quotes field fields))
              (else
              (quoted-field (add-char-to-field c field) fields)))))

    (define (may-be-doubled-quotes field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c)
              (add-field! field fields))
              ((char=? #\return c)
              (carriage-return '() (add-field! field fields)))
              ((char=? #\newline c)
              (line-feed '() (add-field! field fields)))
              ((char=? #\" c)
              (quoted-field (add-char-to-field #\" field) fields))
              ((char=? sep c)
              (let ((fields (add-field! field fields)))
                (not-field field fields)))
              (else
              (unquoted-field (add-char-to-field c field) fields)))))

    (define (unquoted-field field fields)
      (let ((c (read-char port)))
        (cond ((eof-object? c)
              (add-field! field fields))
              ((char=? #\return c)
              (carriage-return '() (add-field! field fields)))
              ((char=? #\newline c)
              (line-feed '() (add-field! field fields)))
              ((char=? sep c)
              (let ((fields (add-field! field fields)))
                (not-field field fields)) )
              (else
              (unquoted-field (add-char-to-field c field) fields)))))

    (define (carriage-return field fields)
      (if (char=? #\newline (peek-char port))
         (read-char port))
      fields)

    (define (line-feed field fields)
      (if (char=? #\return (peek-char port))
         (read-char port))
      fields)

    (if (eof-object? (peek-char port))
       (peek-char port)
       (reverse (start (new-field) '()))))

  (cond ((null? args)
        (read-csv #\, (current-input-port)))
        ((and (null? (cdr args))
             (char? (car args)))
        (read-csv (car args) (current-input-port)))
        ((and (null? (cdr args))
             (port? (car args)))
        (read-csv #\, (car args)))
        ((and (pair? (cdr args)) (null? (cddr args))
              (char? (car args)) (port? (cadr args)))
        (read-csv (car args) (cadr args)))
        (else
        (car '()))))