リスト用のマージソート

リスト用のマージソートを書いて見た。

・以下ソース(関数はどれも破壊的)

;;; 最速(?)のoptimize宣言
(defvar fastest '(optimize (debug 0) (speed 3) (safety 0)))

;;; 2つのlistのマージ
(defun merge-list (lst1 lst2 <)
  (declare #.fastest (function <))
  (cond ((null lst1) lst2)
	((null lst2) lst1)
	 (t
	  (when (funcall < (car lst2) (car lst1))
	    (rotatef lst1 lst2))
	  (let ((head lst1))
	    (while (cdr lst1) ; whileはcommon lispには(デフォルトでは)ない
	      (when (funcall < (car lst2) (cadr lst1))
		(rotatef (cdr lst1) lst2))
	      (setf lst1 (cdr lst1)))
	    (rotatef (cdr lst1) lst2)
	    head))))

;;; listの先頭から2個ずつの要素に対してmapを行う
;;; loopでも同じことが(簡潔に)できるが高速化のために自作
(defun map-pair (fn lst)
  (declare #.fastest (function fn))
  (let ((rest lst) (cur lst))
    (loop 
      (setf (car cur) (funcall fn (car rest) (cadr rest)))
      (setf rest (cddr rest))
      (when (null rest)
	 (return))
      (setf cur (cdr cur)))
    (setf (cdr cur) nil))
  lst)

;;; マージソートを行う(ボトムアップ?)
(defun list-merge-sort (list <)
  (declare #.fastest (function <))
  (labels ((impl (lst)
             (if (null (cdr lst))
		 (car lst)
               ;; 引数lstを1段階ずつマージする
	       (impl (map-pair (lambda (a b) (merge-list a b <)) lst)))))

    ;; 一番初めは引数として、list=(a b c d ...) を((a b) (c d) ...)形式にmapしたものを渡す
    (impl (map-pair (lambda (a b)
		       (if (null b)
			   (list a)
			 (if (funcall < b a) (list b a) (list a b))))
		     list))))

sbcl(1.0.28)の組み込みのstable-sort(多分マージソート...違うかも)と比較してみる。
とりあえず、それ用のデータと比較関数を準備。

;;; ランダムリスト
(defparameter *list* (loop for i from 1 to 500000 collect (random 10000000)))
(defparameter *copy-list* (copy-list *list*))  ; ソートする前に毎回コピーする

;;; 比較関数
(defun fixnum-< (a b)
  (declare #.fastest (fixnum a b))
  (< a b))

;;; ついでに、表示する要素数を制限
(setf *print-length* 20)

比較結果

;;;;;;
;;; stable-sort(組み込み関数)
(time (setf *copy-list* (stable *copy-list* #'fixnum-<)))
Evaluation took:
  0.203 seconds of real time
  0.204013 seconds of total run time (0.204013 user, 0.000000 system)
  100.49% CPU
  642,298,895 processor cycles
  0 bytes consed
  
(12 60 172 241 250 347 363 371 384 391 411 418 425 425 442 458 464 479 510 535 ...)

;;;;;;
;;; list-merge-sort (GC無)
(time (setf *copy-list* (list-merge-sort *copy-list* #'fixnum-<)))
Evaluation took:
  0.099 seconds of real time
  0.100007 seconds of total run time (0.096006 user, 0.004001 system)
  101.01% CPU
  312,326,123 processor cycles
  3,997,688 bytes consed
  
(12 60 172 241 250 347 363 371 384 391 411 418 425 425 442 458 464 479 510 535 ...)

;;;;;;
;;; list-merge-sort (GC有)
(time (setf *copy-list* (list-merge-sort *copy-list* #'fixnum-<)))
Evaluation took:
  0.137 seconds of real time
  0.140008 seconds of total run time (0.136008 user, 0.004000 system)
  [ Run times consist of 0.032 seconds GC time, and 0.109 seconds non-GC time. ]
  102.19% CPU
  434,119,923 processor cycles
  4,001,792 bytes consed
  
(12 60 172 241 250 347 363 371 384 391 411 418 425 425 442 458 464 479 510 535 ...)

stable-sortはconseが0だが、処理速度的にはlist-merge-sortの方が早い。

※ GCが動いていない場合で2倍、動いた場合は1.5倍くらい

※ ちなみに、list-merge-sortの方は、最初のimpl呼び出し時に約(/ (length list) 2)回,list関数を呼び出してconseを行っているが、それ以降はconse0


いろいろ試してみると、比較回数(=fixnum-<が呼ばれた回数)は、どっちも同じ(8858367回)で、
どうやら宣言:(declare (function <))が、速度に大きな影響を与えているらしいことが分かった。

;; function宣言をコメントアウト: (declare #.fastest #|(function <)|#)、 (declare #.fastest #|(function fn)|#)
;; GC無: 0.141
;; GC有: 0.192 (内 0.044がGC)

;; optimize宣言(#.fastest)をコメントアウト: (declare #|#.fastest|# ...)
;; GC無: 0.108
;; GC有: 0.160 (内 0.048がGC)

optimize宣言も若干速度に影響しているが、予想よりもその度合いは小さい。


common lispだと、funcallやapplyなどに、symbolを渡してもいい仕様になっているので、
引数がfunctionだと宣言しない場合は、それがsymbolかfunctionかを決定する必要があり、
そのコストが大量データのソートなどの場合、ばかにならないようだ。(といっても大抵は無視できる程度に小さいが)


結局、全ての宣言を外して、ソート中にGCが動いている場合は、
組み込みのstable-sortと今回作成したlist-merge-sortの間に、それほど差はなかった。


ただ、どうせ(僕は)比較用の引数にsymbolを渡したりすることはないので、
宣言有りのlist-merge-sortでも、自分で使う分には問題ないだろう。

---

とりあえず今日は、ここまで。
できれば、sbclのソースも(ちゃんと)読んでみて、もう少し詳しく検証 and 可能なら改良したい。
ただ、面倒なので、また今度(...もし機会があったら)。

※ちなみに、sbclのsortとstable-sortの処理速度はほとんど変わらない。むしろ、sortの方が若干だが遅いような気がする...。

追記

最初に載せたmerge-list関数は、よく考えたら安定ではない。
マージソートは安定性が一つのうりなので、少しズルをしてしまったことになる...。

http://d.hatena.ne.jp/sile/20090624/1245861661
安定版のmerge-listも(二種類)書いてみたので載せておく。

;;;;;;
;;; utility
(defmacro a.when (expr &body body)
  `(let ((,it ,expr))
     (when ,it
       ,@body)))

;;;;;;
;;; stable merge-list
;; 1]
(defun stable-merge-list (lst1 lst2 <)
  (declare #.fastest (function <))
  (cond ((null lst1) (return-from stable-merge-list lst2))
	 ((null lst2) (return-from stable-merge-list lst1)))
  (when (funcall < (car lst2) (car lst1))
    (rotatef lst1 lst2))
  (nlet self ((l1 lst1) (l2 lst2))
    (if (cdr l1)
	(if (funcall < (car l2) (cadr l1))
	    (a.when (prog1 (cdr l2)        
	              (rplacd l2 (cdr l1))
		      (rplacd l1 l2))
		    (self (cdr l1) it))
	  (self (cdr l1) l2))
      (rplacd l1 l2)))
  lst1)

;; 2]
(defun stable-merge-list (lst1 lst2 <)
  (declare #.fastest (function <))
  (cond ((null lst1) (return-from stable-merge-list lst2))
	 ((null lst2) (return-from stable-merge-list lst1)))
  (labels
   ((fn1 (l1 l2)
      (if (cdr l1)
	  (if (funcall < (car l2) (cadr l1))
	      (progn (rotatef (cdr l1) l2)
		     (fn2 (cdr l1) l2))
	    (fn1 (cdr l1) l2))
	(rplacd l1 l2)))
    (fn2 (l1 l2)
      (if (cdr l1)
	  (if (not (funcall < (cadr l1) (car l2)))
	      (progn (rotatef (cdr l1) l2)
		     (fn1 (cdr l1) l2))
	    (fn2 (cdr l1) l2))
	(rplacd l1 l2))))
   (if (funcall < (car lst2) (car lst1))
       (progn (fn2 lst2 lst1) lst2)
     (progn (fn1 lst1 lst2) lst1))))

...... 2のコードが(特に)スゴい。

追記2

続きはこっち。