A simple program to measure list accumulation performance

accum.ss

(import :std/srfi/1
        :std/misc/list
        :gerbil/gambit/os)
(export main)

(def (accum1 lst)
  (let lp ((rest lst) (r []))
    (match rest
      ([e . rest]
       (lp rest (cons e r)))
      (else
       (reverse! r)))))

(def (accum2 lst)
  (let (root [#f])
    (let lp ((rest lst) (tl root))
      (match rest
        ([e . rest]
         (let (tl* [e])
           (set! (cdr tl) tl*)
           (lp rest tl*)))
        (else
         (cdr root))))))

(def (accum3 lst)
  (with-list-builder (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))

(def (main n)
  (let* ((N (string->number n))
         (lst (iota N)))
    (##gc)
    (time (accum1 lst))
    (##gc)
    (time (accum2 lst))
    (##gc)
    (time (accum3 lst))))

Here is my version, including three implementations of with-list-builder, where the #1 is what is in Gerbil 0.16, #2 is what I originally proposed to inline it, and #3 is what I got after merging #2 and accum2. Interestingly, versions #1, #2 and #3 defined in the same file are over 2x faster than accum2, but whichever ends up in misc/list.ss is about 2x slower... even though the code generated by gxc -s for accum3 and accum6 is identical (after alpha-conversion, when the winner, #3 is used in misc/list).

;;#!/usr/bin/env gxi
;;; https://gitter.im/gerbil-scheme/community?at=5eda5ea7225dc25f54ca68d4
;;; https://gist.github.com/vyzo/3db10df3a1fd886bbda5d57369455ff6

;;; gxc -O -exe -o accum accum.ss | ./accum 100000000

(import :std/srfi/1
        :std/misc/list
        :gerbil/gambit/os)
(export main)

(def (call-with-list-builder1 fun)
  (let* ((head (cons #f '())) ;; use a traditional implementation of queue as cons of tail and head
         (poke (lambda (val)
                 (let ((old-tail (car head))
                       (new-tail (cons val '())))
                   (set-cdr! old-tail new-tail)
                   (set-car! head new-tail))))
         (peek (lambda () (cdr head))))
    (set-car! head head)
    (fun poke peek)
    (peek)))

(defrules with-list-builder1 ()
  ((_ (c r) body1 body+ ...) (call-with-list-builder1 (lambda (c r) body1 body+ ...)))
  ((_ (c) body1 body+ ...) (with-list-builder1 (c _) body1 body+ ...)))

(defrules with-list-builder2 ()
  ((_ (c) body1 body+ ...) (with-list-builder2 (c _) body1 body+ ...))
  ((_ (poke peek) body1 body+ ...)
   (let* ((head (cons #f '()))) ;; use a traditional implementation of queue as cons of tail and head
     (set-car! head head)
     (defrules poke ()
       ((_ val) (let ((new-tail (cons val '()))
                      (old-tail (car head)))
                  (set-cdr! old-tail new-tail)
                  (set-car! head new-tail)))
       ((_ . _) (error "invalid number of arguments" poke))
       (_ (lambda (val) (poke val))))
     (defrules peek ()
       ((_) (cdr head))
       ((_ . _) (error "invalid number of arguments" peek))
       (_ (lambda () (peek))))
     body1 body+ ... (peek))))

(def (call-with-list-builder2 fun)
  (with-list-builder2 (poke peek) (fun poke peek)))

(defrules with-list-builder3 ()
  ((_ (c) body1 body+ ...) (with-list-builder3 (c _) body1 body+ ...))
  ((_ (poke peek) body1 body+ ...)
   (let* ((head (cons #f '())) ;; use a traditional implementation of queue as cons of tail and head
          (tail head))
     (defrules poke ()
       ((_ val) (let ((new-tail (cons val '())))
                  (set-cdr! tail new-tail)
                  (set! tail new-tail)))
       ((_ . _) (error "invalid number of arguments" poke))
       (_ (lambda (val) (poke val))))
     (defrules peek ()
       ((_) (cdr head))
       ((_ . _) (error "invalid number of arguments" peek))
       (_ (lambda () (peek))))
     body1 body+ ... (peek))))

(def (call-with-list-builder3 fun)
  (with-list-builder3 (poke peek) (fun poke peek)))

(def (accum1 lst)
  (let lp ((rest lst) (r []))
    (match rest
      ([e . rest]
       (lp rest (cons e r)))
      (else
       (reverse! r)))))

(def (accum2 lst)
  (let (root [#f])
    (let lp ((rest lst) (tl root))
      (match rest
        ([e . rest]
         (let (tl* [e])
           (set! (cdr tl) tl*)
           (lp rest tl*)))
        (else
         (cdr root))))))

(def (accum3 lst)
  (with-list-builder (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))

(def (accum4 lst)
  (with-list-builder1 (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))

(def (accum5 lst)
  (with-list-builder2 (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))

(def (accum6 lst)
  (with-list-builder3 (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))
(def (main n)
  (let* ((N (string->number n))
         (lst (iota N)))
    (##gc)
    (time (accum1 lst))
    (##gc)
    (time (accum2 lst))
    (##gc)
    (time (accum3 lst))
    (##gc)
    (time (accum4 lst))
    (##gc)
    (time (accum5 lst))
    (##gc)
    (time (accum6 lst))))

The alpha-converted code is:

(define accum3
  (lambda (lst)
    (let* ((head (cons '#f '())) (tail head))
      (let lp ((rest lst))
        (let* ((rest1 rest)
               (else (lambda () '#!void))
               (k
                (lambda (rest2 e)
                  (let ((new-tail (cons e '())))
                    (set-cdr! tail new-tail)
                    (set! tail new-tail))
                  (lp rest2))))
          (if (let () (declare (not safe)) (##pair? rest1))
              (let ((hd
                     (let () (declare (not safe)) (##car rest1)))
                    (tl
                     (let () (declare (not safe)) (##cdr rest1))))
                (let* ((e2 hd) (rest3 tl))
                  (k rest3 e2)))
              '#!void)))
      (cdr head))))

Variant to run only one variant at once, at which point the discrepancy between 3 and 6 becomes noise instead of being 4.5x. On the other hand, accum6 becomes 1 to 5% slower than accum2 instead of 2x faster. Whatever that means...

;;#!/usr/bin/env gxi
;;; https://gitter.im/gerbil-scheme/community?at=5eda5ea7225dc25f54ca68d4
;;; https://gist.github.com/vyzo/3db10df3a1fd886bbda5d57369455ff6

;;; gxc -O -exe -o accum accum.ss && for i in 1 2 3 4 5 6 ; do ./accum $i 100000000 ; done

(import :std/srfi/1
        :std/misc/list
        :gerbil/gambit/os)
(export main)

(def (call-with-list-builder1 fun)
  (let* ((head (cons #f '())) ;; use a traditional implementation of queue as cons of tail and head
         (poke (lambda (val)
                 (let ((old-tail (car head))
                       (new-tail (cons val '())))
                   (set-cdr! old-tail new-tail)
                   (set-car! head new-tail))))
         (peek (lambda () (cdr head))))
    (set-car! head head)
    (fun poke peek)
    (peek)))

(defrules with-list-builder1 ()
  ((_ (c r) body1 body+ ...) (call-with-list-builder1 (lambda (c r) body1 body+ ...)))
  ((_ (c) body1 body+ ...) (with-list-builder1 (c _) body1 body+ ...)))

(defrules with-list-builder2 ()
  ((_ (c) body1 body+ ...) (with-list-builder2 (c _) body1 body+ ...))
  ((_ (poke peek) body1 body+ ...)
   (let* ((head (cons #f '()))) ;; use a traditional implementation of queue as cons of tail and head
     (set-car! head head)
     (defrules poke ()
       ((_ val) (let ((new-tail (cons val '()))
                      (old-tail (car head)))
                  (set-cdr! old-tail new-tail)
                  (set-car! head new-tail)))
       ((_ . _) (error "invalid number of arguments" poke))
       (_ (lambda (val) (poke val))))
     (defrules peek ()
       ((_) (cdr head))
       ((_ . _) (error "invalid number of arguments" peek))
       (_ (lambda () (peek))))
     body1 body+ ... (peek))))

(def (call-with-list-builder2 fun)
  (with-list-builder2 (poke peek) (fun poke peek)))

(defrules with-list-builder3 ()
  ((_ (c) body1 body+ ...) (with-list-builder3 (c _) body1 body+ ...))
  ((_ (poke peek) body1 body+ ...)
   (let* ((head (cons #f '())) ;; use a traditional implementation of queue as cons of tail and head
          (tail head))
     (defrules poke ()
       ((_ val) (let ((new-tail (cons val '())))
                  (set-cdr! tail new-tail)
                  (set! tail new-tail)))
       ((_ . _) (error "invalid number of arguments" poke))
       (_ (lambda (val) (poke val))))
     (defrules peek ()
       ((_) (cdr head))
       ((_ . _) (error "invalid number of arguments" peek))
       (_ (lambda () (peek))))
     body1 body+ ... (peek))))

(def (call-with-list-builder3 fun)
  (with-list-builder3 (poke peek) (fun poke peek)))

(def (accum1 lst)
  (let lp ((rest lst) (r []))
    (match rest
      ([e . rest]
       (lp rest (cons e r)))
      (else
       (reverse! r)))))

(def (accum2 lst)
  (let (root [#f])
    (let lp ((rest lst) (tl root))
      (match rest
        ([e . rest]
         (let (tl* [e])
           (set! (cdr tl) tl*)
           (lp rest tl*)))
        (else
         (cdr root))))))

(def (accum3 lst)
  (with-list-builder (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))

(def (accum4 lst)
  (with-list-builder1 (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))

(def (accum5 lst)
  (with-list-builder2 (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))

(def (accum6 lst)
  (with-list-builder3 (push)
    (let lp ((rest lst))
      (match rest
        ([e . rest]
         (push e)
         (lp rest))
        (else (void))))))

(def accums (vector accum1 accum2 accum3 accum4 accum5 accum6))

(def (main m n)
  (let* ((N (string->number n))
         (lst (iota N))
         (M (string->number m))
         (accum (vector-ref accums (1- M))))
    (##gc)
    (time (accum lst))))

It seems we had some very weird cpu caching effects; also gc minor faults!
I think the separate test restores sanity.