マージソート(1)

common lisp algorithm speed

久々にマージソートを実装してみたら、結構良いものができたので載せておく。
まずはパッケージ定義とグルーバルな宣言。

;;;; SBCL-1.0.51 (x86-64)
(defpackage merge-sort
  (:use common-lisp)
  (:shadow :common-lisp sort)
  (:export sort))
(in-package :merge-sort)

(declaim (inline halve merge-lists)
         (optimize (speed 3) (debug 0) (safety 0)))

ユーティリティ関数とマクロ。

;; 整数nを二分割する関数
;; => (values n1 n2)
;;
;; nが奇数の場合は (= (1+ n1) n2) となる
(defun halve (n)
  (declare (fixnum n))
  (multiple-value-bind (n1 x) (floor n 2)
    (values (+ n1 x) n1)))

;; listのcdr部を更新するマクロ
(defmacro cdr! (list new-cdr)
  `(setf (cdr ,list) ,new-cdr))

;; 複数のmultiple-value-bindの使用を簡略化するためのマクロ
;;
;; (multiple-value-let* (((a b) (values 1 2))
;;                       ((c d) (values 3 4)))
;;   (list a b c d))
;; =>
;; (multiple-value-bind (a b) (values 1 2)
;;    (multiple-value-bind (c d) (values 3 4)
;;        (list a b c d)))
(defmacro multiple-value-let* (bind-specs &body body)
  (if (null bind-specs)
      `(locally ,@body)
    (destructuring-bind ((vars exp) . rest) bind-specs
      `(multiple-value-bind ,vars ,exp
         (multiple-value-let* ,rest ,@body)))))

マージソート実装。

;; list1とlist2をマージしたリストを返す
(defun merge-lists (list1 list2 test key)
  (declare (function test key))
  (labels ((not-less-than (l1 l2)
             (not (funcall test (funcall key (car l1)) (funcall key (car l2))))) ; XXX: これでは安定ソートにならない！
           (recur (head tail l1 l2)
             (cond ((null l1)             (cdr! tail l2) head)
                   ((null l2)             (cdr! tail l1) head)
                   ((not-less-than l1 l2) (recur head (cdr! tail l2) l1 (cdr l2)))
                   (t                     (recur head (cdr! tail l1) (cdr l1) l2)))))
    (declare (inline not-less-than))
    (if (not-less-than list1 list2)
        (recur list2 list2 list1 (cdr list2))
      (recur list1 list1 (cdr list1) list2))))

;; マージソート
;; => (values ソート済みリスト=(subseq list 0 size) 
;;            未ソートリスト=(subseq list size))
(defun sort-impl (list size test key)
  (declare (fixnum size))
  (if (= 1 size)
      (values list (prog1 (cdr list) (cdr! list nil)))
    (multiple-value-let* (((size1 size2) (halve size))
                          ((list1 rest) (sort-impl list size1 test key))
                          ((list2 rest) (sort-impl rest size2 test key)))
      (values (merge-lists list1 list2 test key) rest))))

;; 公開用の関数: listが空でなければ、sort-implに処理を任せる
(defun sort (list test &key (key #'identity))
  (declare (list list)
           (function test key)
           (optimize (speed 3) (safety 2) (debug 2)))
  (when list
    (values (sort-impl list (length list) test key))))

以上。

計時

SBCLの組み込みのマージソート(stable-sort関数)との比較。

;;; 大量データのソート速度
;;; 100万要素のリストが対象
(sb-sys:without-gcing
 (let* ((data (loop REPEAT 1000000 COLLECT (random 10000000)))
        (d1 (copy-seq data))
        (d2 (copy-seq data))
        (r1 (time (stable-sort d1 #'<)))
        (r2 (time (merge-sort:sort d2 #'<))))
   (equal r1 r2))) ; ソート結果が正しいかの確認

Evaluation took:
  2.484 seconds of real time   ; stable-sort# 2.484秒
  2.476154 seconds of total run time (2.368148 user, 0.108006 system)
  99.68% CPU
  4,955,234,522 processor cycles
  0 bytes consed
  
Evaluation took:
  1.662 seconds of real time   ; merge-sort:sort# 1.662秒
  1.652103 seconds of total run time (1.592099 user, 0.060004 system)
  99.40% CPU
  3,315,393,750 processor cycles
  0 bytes consed
 
--> T  ; ソート結果は正しい


;;; 少量データのソート速度
;;; 平均50要素のリスト x 1万 が対象
(sb-sys:without-gcing
 (let* ((data (loop REPEAT 10000 
                    COLLECT (loop REPEAT (random 100) 
                                  COLLECT (random 10000))))
        (d1 (copy-tree data))
        (d2 (copy-tree data))
        (r1 (time (loop FOR d IN d1 COLLECT (stable-sort d #'<))))
        (r2 (time (loop FOR d IN d2 COLLECT (merge-sort:sort d #'<)))))
   (equal r1 r2)))

Evaluation took:
  0.204 seconds of real time  ; stable-sort# 0.204秒
  0.204012 seconds of total run time (0.204012 user, 0.000000 system)
  100.00% CPU
  407,272,146 processor cycles
  294,912 bytes consed
  
Evaluation took:
  0.176 seconds of real time  ; merge-sort:sort# 0.176秒
  0.172010 seconds of total run time (0.172010 user, 0.000000 system)
  97.73% CPU
  351,409,803 processor cycles
  163,840 bytes consed
  
--> T

自分の環境で試した限りでは、なかなか良好な結果となった。