benchmark of 'Deriving Pure, Naturally-Recursive Operations for Processing Tail-Aligned Lists'

lcs.scm

(import (rnrs) (only (chezscheme) time))
;;(import (rnrs) (only (racket base) time))
;;(import (rnrs) (time))

(define (tt a1 a2) a1)
(define (ff a1 a2) a2)
(define (slot-f f l) (fold-right (lambda (a f) (f a)) f l))
(define (build-k j as k)
  (lambda (r)
    (lambda (a1)
      (if (eqv? as a1)
          (k (cons as r))
          (j r)))))

(define (compose f . rest)
  (if (null? rest)
      f
      (let ((g (apply compose rest)))
        (lambda args
          (call-with-values (lambda () (apply g args)) f)))))
(define (two->one s) (lambda (f) (compose (two->one s) f s)))

(define (lcs l1 l2)
  (call/cc
   (lambda (j)
     (define (lcs l1 l2 k1 k2)
       (cond ((null? l1) ((two->one ff) (slot-f (k1 '()) l2)))
             ((null? l2) ((two->one tt) (slot-f (k2 '()) l1)))
             (else ((lcs (cdr l1) (cdr l2)
                         (build-k j (car l1) k1)
                         (build-k j (car l2) k2))
                    (car l1) (car l2)))))
     (lcs l1 l2 j j))))

;; naive
(define (lcp l1 l2)
  (if (or (null? l1) (null? l2) (not (eqv? (car l1) (car l2))))
      '()
      (cons (car l1) (lcp (cdr l1) (cdr l2)))))
(define (lcs-n l1 l2) (reverse (lcp (reverse l1) (reverse l2))))


(define (list-tabulate len proc)
  (do ((i (- len 1) (- i 1))
       (ans '() (cons (proc i) ans)))
      ((< i 0) ans)))

(define l1-same
  (reverse (list-tabulate 100000 (lambda (i) (mod i 10)))))
(define l2-same
  (reverse (list-tabulate 100000 (lambda (i) (mod i 10)))))

(define (run-bench l1 l2)
  (time (lcs-n l1 l2))
  (time (lcs l1 l2)))

(run-bench l1-same l2-same)

(define l2-diff
  (reverse (list-tabulate 100000 (lambda (i) (mod i 100)))))
(run-bench l1-same l2-diff)

results.txt

$ sash -r6 test2.scm

;;  (lcs-n l1 l2)
;;  0.032639 real    0.048000 user    0.020000 sys

;;  (lcs l1 l2)
;;  0.128253 real    0.208000 user    0.004000 sys

;;  (lcs-n l1 l2)
;;  0.002950 real    0.004000 user    0.000000 sys

;;  (lcs l1 l2)
;;  0.028780 real    0.044000 user    0.000000 sys

$ plt-r6rs test2.scm
cpu time: 4 real time: 5 gc time: 0
cpu time: 96 real time: 94 gc time: 64
cpu time: 0 real time: 2 gc time: 0
cpu time: 4 real time: 4 gc time: 0

$ scheme --program test2.scm
(time (lcs-n l1 ...))
    1 collection
    0.005151428s elapsed cpu time, including 0.002442072s collecting
    0.005150779s elapsed real time, including 0.002443266s collecting
    9614256 bytes allocated, including 3624384 bytes reclaimed
(time (lcs l1 ...))
    4 collections
    0.016340934s elapsed cpu time, including 0.009058406s collecting
    0.016340303s elapsed real time, including 0.009062417s collecting
    35285008 bytes allocated, including 27367680 bytes reclaimed
(time (lcs-n l1 ...))
    1 collection
    0.001860735s elapsed cpu time, including 0.000804889s collecting
    0.001860352s elapsed real time, including 0.000805533s collecting
    3200960 bytes allocated, including 9933824 bytes reclaimed
(time (lcs l1 ...))
    1 collection
    0.003294629s elapsed cpu time, including 0.002073054s collecting
    0.003294375s elapsed real time, including 0.002073888s collecting
    12896368 bytes allocated, including 2974640 bytes reclaimed