list-sortを書き換え

ふとTwitterで以下のページを言及しているツイートを見つけた。

ソート済みのリストに対する破壊的マージソートの改良

これはlist-sortのパフォーマンス改善に使えると思い、早速実装。この記事書く前に全部置き換えてコミットしてしまったのと元々Sagittariusのlist-sortはYpsilonのものを使っていたので、以下のコード(速度計測)はYpsilonで確認。

(import (rnrs)
        (time)
        (srfi :8)
        (srfi :27)
        (srfi :42))

(define sorted-list (list-ec (: x 100000) x))
(define reverse-sorted-list (reverse sorted-list))
(define nearly-sorted-list1 (list-ec (: x  100000)
                                     (if (zero? (random-integer 1000))
                                         (random-integer 100000)
                                         x)))
(define random-list (list-ec (: x 100000)
                             (random-integer 100000)))

(time (list-sort < sorted-list))
(time (list-sort < reverse-sorted-list))
(time (list-sort < nearly-sorted-list1))
(time (list-sort < random-list))

(define (list-sort2 proc lst)
  (define (merge-list! proc head lst1 lst2 tail)
    (let loop ()
      (cond ((proc (car lst2) (car lst1))
             (set-cdr! tail lst2)
             (set! tail lst2)
             (let ((rest (cdr lst2)))
               (cond ((null? rest)
                      (set-cdr! lst2 lst1)
                      (cdr head))
                     (else
                      (set! lst2 rest)
                      (loop)))))
            (else
             (set-cdr! tail lst1)
             (set! tail lst1)
             (let ((rest (cdr lst1)))
               (cond ((null? rest)
                      (set-cdr! lst1 lst2)
                      (cdr head))
                     (else
                      (set! lst1 rest)
                      (loop))))))))
  (define (fast-merge-list! proc try? head lst1 tail1 lst2 tail2 rest)
    (if try?
        (cond ((not (proc (car lst2) (car tail1)))
               (set-cdr! tail1 lst2)
               (values lst1 tail2 rest))
              ((proc (car tail2) (car lst1))
               (set-cdr! tail2 lst1)
               (values lst2 tail1 rest))
              (else 
               (values (merge-list! proc head lst1 lst2 head)
                       (if (null? (cdr tail1))
                           tail1
                           tail2)
                       rest)))
        (values (merge-list! proc head lst1 lst2 head)
                (if (null? (cdr tail1))
                    tail1
                    tail2)
                rest)))
  (define (do-sort lst size head)
    (define (recur lst size)
      (cond ((= size 1)
             (let ((h (list (car lst))))
               (values h h (cdr lst))))
            ((= size 2)
             (let* ((a (car lst))
                    (ad (cadr lst))
                    (h (if (proc ad a)
                           (list ad a)
                           (list a ad))))
               (values h (cdr h) (cddr lst))))
            (else
             (let ((half (div size 2)))
               (receive (lst1 tail1 rest) (recur lst half)
                 (receive (lst2 tail2 rest) (recur rest (- size half))
                   (fast-merge-list! proc (>= size 8) head
                                           lst1 tail1
                                           lst2 tail2
                                           rest)))))))
      (receive (lst tail size) (recur lst size)
        lst))
    (define (divide lst)
      (let loop ((acc 1) (lst lst))
        (cond ((null? (cdr lst)) (values acc '()))
              (else
               (if (proc (car lst) (cadr lst))
                   (loop (+ acc 1) (cdr lst))
                   (values acc (cdr lst)))))))
    (receive (n lst2) (divide lst)
      (if (null? lst2)
          lst
          (let* ((head (cons '() '()))
                 (r (do-sort lst2 (length lst2) head)))
            (merge-list! proc head (list-head lst n) r head))))))

(newline)
(display 'list-sort2) (newline)
(time (list-sort2 < sorted-list))
(time (list-sort2 < reverse-sorted-list))
(time (list-sort2 < nearly-sorted-list1))
(time (list-sort2 < random-list))

オリジナル(SBCL)のコードはdevide相当のものはないのだけれど、これがあるのと無いのではソート済みのリストが渡された際のパフォーマンスが全然違う(10倍程度)ので入っている。
以下が結果。

% Ypsilon test2.scm

;;  0.006001 real    0.0 user    0.0 sys

;;  0.16501 real    0.327602 user    0.0 sys

;;  0.194012 real    0.374402 user    0.0 sys

;;  0.302017 real    0.624004 user    0.0 sys

list-sort2

;;  0.007 real    0.0 user    0.0 sys

;;  0.116007 real    0.202801 user    0.0 sys

;;  0.16201 real    0.249602 user    0.0 sys

;;  0.254015 real    0.343202 user    0.0 sys

ソート済以外は高速になっているのが分かる。(ソート済みは一緒のはず)。
Sagittariusで検証した際はreversed-sorted-listで倍速、nearly-sorted-list1ではほぼ倍速。random-listは2割程度とYpsilonと同程度の速度改善であった。

どうでもいいのだが、 moshで上記のコードを走らせる(list-headをtakeにする等の変更が必要だが)と劇的に遅くなる。どの処理系でも速度改善になるというわけではないらしい。

どうでもいい追記その２。
moshのlist-sortはスタックを激しく使用するらしく、reversed-sorted-listで45回のスタック拡張が発生した。(ちょっと手を入れて、スタックの拡張が起きるとwarningメッセージ出すようにしてある。)

どうでもいい追記その３．
Ypsilonでもリストの要素数を200万個以上にするとメモリが足らなくなった。オリジナルは末尾再帰じゃないのでしょうがないのか。改善されたのは速度だけではないのもいい感じである。