N-Queen: 高速化

こちらの記事に刺激を受けて、以前に実装したN-Queenを高速化してみた(Common Lisp版のみ)。

(defvar *fastest* '(optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))
(deftype max-board-size () '(mod #x100))

(declaim (inline check))  ; inline宣言を追加
(defun check (row queens &optional (r 1) &aux (q (car queens)))
  (declare #.*fastest*
           (max-board-size r row q))
  (or (null queens) 
      (and (/= q (+ row r) (- row r))
	   (check row (cdr queens) (1+ r)))))

;; dolistの亜種
;; - リストの走査時に各要素を変数に束縛するのと同時に、走査中の要素を除いたリストも変数に束縛する
;;   ※ 先頭要素は走査対象外
(defmacro dolist2 ((x but-x list) &body body)
  (multiple-value-bind (recur prev cur next) (values #1=(gensym) #1# #1# #1#)
    `(let ((,but-x ,list))
       (labels ((,recur (,prev &aux (,cur (cdr ,prev)))
                  (when ,cur
                    (destructuring-bind (,x . ,next) ,cur
                      (setf (cdr ,prev) ,next)
                      (locally ,@body)
                      (setf (cdr ,prev) ,cur)
                      (,recur ,cur)))))
         (,recur ,but-x)))))
#|
ex:
> (dolist2 (x but-x '(:head 1 2 3 a b c))
    (print `(:x ,x :but-x ,but-x)))
(:X 1 :BUT-X (:HEAD 2 3 A B C)) 
(:X 2 :BUT-X (:HEAD 1 3 A B C)) 
(:X 3 :BUT-X (:HEAD 1 2 A B C)) 
(:X A :BUT-X (:HEAD 1 2 3 B C)) 
(:X B :BUT-X (:HEAD 1 2 3 A C)) 
(:X C :BUT-X (:HEAD 1 2 3 A B)) 
--> NIL
|#

(defun n-queen (n)                     
  (declare #.*fastest*
           (max-board-size n))
  (nlet-acc self (queens (rows (cons :head (loop FOR i FROM 0 BELOW n COLLECT i))))
    (if (null (cdr rows))   ; rows == '(:head) 
        (accumulate queens)
      (dolist2 (row rest-rows rows)
        (when (check row queens)
          (self (cons row queens) rest-rows))))))

処理時間

	処理時間(サイズ=11)	処理時間(サイズ=12)	処理時間(サイズ=13)
nqueen(Commonlisp:本記事)	0.025秒	0.126秒	0.722秒
nqueen(CommonLisp:前回)	0.061秒	0.336秒	2.043秒
nqueen(Haskell:前回)	0.076秒	0.420秒	2.524秒
nqueen(Haskell:tsumuji)	0.040秒	0.220秒	1.244秒

結構速くなった。
コードも複雑になったけど。

N-Queen (Haskell + Common Lisp)

Etsukata blog: Haskellでlist monadを使ってN-Queens問題を解いてみました を見たのをきっかけに久しぶりにN-Queen問題を解くプログラムをHaskellで書いてみた。

---- ファイル名: nqueen.hs
---- コンパイル: ghc -O2 -o nqueen nqueen.hs  # Glasgow Haskell Compiler, Version 7.0.3

import System

-- クイーンの配置: リスト内のオフセットが列を、値が行を表す
type Queens = [Int]

-- N-Queenを解く: ボードのサイズを受け取り、全ての解答(可能な配置のリスト)を返す
nQueens :: Int -> [Queens]
nQueens n = solve n []
  where solve 0   queens = [queens]   -- 最後の列: 全てのクイーンを配置できた
        solve col queens =            -- 途中の列: 全ての行に対して配置可能かを調べ、可能なら次の列に進む
          concat $ map (solve (col-1) . (:queens)) $ filter (check queens 1) [0..(n-1)]

-- クイーンが配置可能かどうか調べる
check :: Queens -> Int -> Int -> Bool  
check [] _ _  = True
check (q:qs) r row    -- rは対角線上の(チェックすべき)クイーンの位置を知るための変数
  | q /= row && q /= row+r && q /= row-r = check qs (r+1) row
  | otherwise = False
  
-- メイン関数
main = do
  args <- getArgs
  let size = (read $ head args)::Int
  let rlt = nQueens size
  putStrLn $ show . length $ rlt

実行結果:

$ ./nqueen 12
14200

処理時間

冒頭で挙げた記事のもの(Etsutaka)、および、Common Lisp版(後述)との処理速度の比較。

	処理時間(サイズ=11)	処理時間(サイズ=12)	処理時間(サイズ=13)
nqueen(Haskell:本記事)	0.080秒	0.424秒	2.592秒
nqueen(Haskell:Etsutaka)	0.132秒	0.736秒	4.424秒
nqueen(Common Lisp)	0.071秒	0.375秒	2.289秒

この中ではCommon Lisp版が一番速くなっているけど、Haskellで効率の良いプログラムの書き方とかが全く分かっていないので、その辺を把握してちゃんと書けばHaskell版はもっと速くなるかもしれない。

Common Lisp版

Common Lisp版のソースコード。
内容的には N-Queen(1) - sileの日記 に最適化宣言を加えただけ。

(defvar *fastest* '(optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))
(deftype max-board-size () '(mod #x100))

(defun check (row queens &optional (r 1))
  (declare #.*fastest*
           (max-board-size r row))
  (or (null queens) 
      (and (/= (the max-board-size (car queens)) row (+ row r) (- row r)) 
	   (check row (cdr queens) (1+ r)))))

(defun n-queen (n)
  (declare #.*fastest*
           (max-board-size n))
  (nlet-acc self (queens (col n))
    (if (zerop col)
        (accumulate queens) 
      (dotimes (row n)
        (when (check row queens)
          (self (cons row queens) (1- col)))))))

;; SBCL-1.0.51
> (n-queen 4)
--> ((2 0 3 1) (1 3 0 2))

> (time (length (n-queen 12)))
Evaluation took:
  0.401 seconds of real time
  0.400025 seconds of total run time (0.400025 user, 0.000000 system)
  [ Run times consist of 0.012 seconds GC time, and 0.389 seconds non-GC time. ]
  99.75% CPU
  800,068,094 processor cycles
  13,926,400 bytes consed
  
--> 14200

cc-dict: ハッシュテーブル

ハッシュテーブルを実装してみた。
・cc-dict-0.0.3
チェイン法を用いたハッシュテーブルで、リンクリスト(チェイン)のノードを割り当てる際に自前のアロケータを使っている点以外は、特に変わったところもないと思う。

ベンチマーク

一応、ベンチマークも取ったので載せておく。
比較対象はg++のunordered_mapとGoogleのsparse_hash_map及びdense_hash_map。
ベンチマークプログラムにはHash Table Benchmarksに記載のものを使用させてもらった*1。
※ 実行環境は Ubuntu-11.11-64bit / Intel(R) Core(TM) i7 CPU L 620 @ 2.00GHz。

このベンチマーク結果を見る限りは、特別性能が悪い、ということはなさそう*2。

*1:ただし以下の追加・修正を施した。
　1: 検索処理時間の計測の追加
　2: もともとは文字列のベンチマークではキーの型const char*が使用されていたのをstd::stringに変更(関連)
　3: 処理時間にキー配列を生成する時間も含まれていたので、キー配列は最初にまとめて生成しておき、その後から計時を開始するように修正

*2:ベンチマークデータが結構恣意的(連番 or 乱数)なので、必ずしも実データで同様の性能がでるかは分からないけど・・・

マージソート(3): 高階関数呼び出し最適化

マージソート(1)の改良版。
ソートのような高階関数では、引数で渡した比較関数の間接呼び出しのコストも実行速度にそれなりの影響を与えるので、それを(マクロをほとんど使わずに)できるだけ低く抑えるための試み。

比較関数最適化

まず、比較関数自体の実行コストを下げるために、汎用的な数値比較関数ではなく、より特殊化されたものを使用するようにする。

;; fixnum用の比較関数
(define-symbol-macro fixnum< (lambda (x y) (declare (fixnum x y)) (< x y)))

;;; fixnum< を使用した場合の処理時間
;;;
;;; 大量データのソート速度
;;; 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 fixnum<)))
        (r2 (time (merge-sort:sort d2 fixnum<))))
   (equal r1 r2)))

Evaluation took:
  1.366 seconds of real time  ; stable-sort# 1.366秒 (前回 2.484秒)
  1.360085 seconds of total run time (1.360085 user, 0.000000 system)
  99.56% CPU
  2,723,515,890 processor cycles
  0 bytes consed
  
Evaluation took:
  0.541 seconds of real time  ; merge-sort:sort# 0.541秒 (前回 1.662秒)
  0.540034 seconds of total run time (0.540034 user, 0.000000 system)
  99.82% CPU
  1,079,254,874 processor cycles
  0 bytes consed
  
--> T

後は、ここからどれだけ短縮できるか。

実装

今回のマージソート実装。
八割方は前と同じ。
まず、ほとんど変更がない前半部分から載せる。(変更箇所はコメントで記載)

(defpackage merge-sort
  (:use common-lisp)
  (:shadow :common-lisp sort)
  (:export sort))
(in-package :merge-sort)

;; inline-sort関数とsort-impl関数がinline宣言に加わっている。前者は今回新たに追加される関数
(declaim (inline halve merge-lists inline-sort sort-impl)  
         (optimize (speed 3) (debug 0) (safety 0)))

(defun halve (n)
  (declare (fixnum n))
  (multiple-value-bind (n1 x) (floor n 2)
    (values (+ n1 x) n1)))

(defmacro cdr! (list new-cdr)
  `(setf (cdr ,list) ,new-cdr))

(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)))))
   
(defun merge-lists (list1 list2 test key)
  (declare (function test key))
  (labels ((less-equal-than (list1 list2)  ; 安定ソートになるように比較方法が若干修正されている
             (not (funcall test (funcall key (car list2)) (funcall key (car list1)))))
           (recur (head tail l1 l2)
             (cond ((null l1)               (cdr! tail l2) head)
                   ((null l2)               (cdr! tail l1) head)
                   ((less-equal-than l1 l2) (recur head (cdr! tail l1) (cdr l1) l2))
                   (t                       (recur head (cdr! tail l2) l1 (cdr l2))))))
    (declare (inline less-equal-than))
    (if (less-equal-than list1 list2)
        (recur list1 list1 (cdr list1) list2)
      (recur list2 list2 list1 (cdr list2)))))

次はsort-impl関数。
量は多くないけど、ここが一番重要な変更箇所。

;; 前回は、sort-impl関数自体で再帰処理を行っていたのを、
;; 再帰部分をrecur関数に括り出すように修正。
;;
;; これによって、sort-impl関数に対してinline宣言を行うことが可能になる。
;;
;; sort-impl関数がinline展開可能となると、
;; inline-sort関数(後述) => sort-impl関数 => merge-lists関数、の
;; 全てがinline展開されるようになるため、
;; コンパイラが(inline-sort関数の引数で渡され)merge-lists関数内でfuncallされている
;; testとkeyの情報を知ることができるようになり、間接呼び出しを除去する等といった
;; 最適化が可能となる(と思っている)。
(defun sort-impl (list size test key)
  (labels ((recur (list size)
             (declare (fixnum size))
             (if (= 1 size)
                 (values list (prog1 (cdr list) (cdr! list nil)))
               (multiple-value-let* (((size1 size2) (halve size))
                                     ((list1 rest) (recur list size1))
                                     ((list2 rest) (recur rest size2)))
                 (values (merge-lists list1 list2 test key) rest)))))
    (recur list size)))

最後はsort関数。
inline展開の有無を選択するための引数を追加してみた。
※ 単にsort関数をinline宣言するだけでも良いのだが、常に展開されるようになってしまうのも避けたかったの若干(無駄に)凝ってみた

;; inline引数を追加。これが真の場合は、inline展開される。
(defun sort (list test &key (key #'identity) inline)
  (declare (list list)
           (function test key)
           (ignore inline)
           (optimize (speed 3) (safety 2) (debug 2)))
  (when list
    (values (sort-impl list (length list) test key))))

;; sort関数のinline展開版。上でinline宣言されている以外は、sort関数と基本的に同様。
(defun inline-sort (list test &key (key #'identity))
  (declare (list list)
           (optimize (speed 3) (safety 0) (debug 0)))
  (when list
    (values (sort-impl list (length list) test key))))

;; sort関数のinline引数が真の場合に、(sort関数の代わりに)inline-sort関数を呼び出すためのコンパイラマクロ
(define-compiler-macro sort (&whole form list test &key (key '#'identity) inline)
  (if inline
      `(inline-sort ,list ,test :key ,key)
    form))

前回*1と比べて、本質的に異なるのは、sort-impl関数がinline展開可能になった、という点だけ。

計時

今回追加した関数(オプション)を加えて、再度計測。

;;; 大量データのソート速度
;;; 100万要素のリストが対象
(sb-sys:without-gcing
 (let* ((data (loop REPEAT 1000000 COLLECT (random 10000000)))
        (d1 (copy-seq data))
        (d2 (copy-seq data))
        (d3 (copy-seq data))
        (r1 (time (stable-sort d1 fixnum<)))
        (r2 (time (merge-sort:sort d2 fixnum<)))
        (r3 (time (merge-sort:sort d3 fixnum< :inline t)))) 
   (list (equal r1 r2)
         (equal r1 r3))))

Evaluation took:
  1.336 seconds of real time  ; stable-sort# 1.336秒
  1.332083 seconds of total run time (1.332083 user, 0.000000 system)
  99.70% CPU
  2,664,840,158 processor cycles
  0 bytes consed
  
Evaluation took:
  0.555 seconds of real time  ; merge-sort:sort# 0.555秒
  0.552034 seconds of total run time (0.552034 user, 0.000000 system)
  99.46% CPU
  1,107,829,062 processor cycles
  0 bytes consed
  
Evaluation took:
  0.382 seconds of real time  ; merge-sort:sort(inline)# 0.382秒
  0.376024 seconds of total run time (0.376024 user, 0.000000 system)
  98.43% CPU
  761,537,180 processor cycles
  0 bytes consed
  
--> (T 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))
        (d3 (copy-tree data))
        (r1 (time (loop FOR d IN d1 COLLECT (stable-sort d fixnum<))))
        (r2 (time (loop FOR d IN d2 COLLECT (merge-sort:sort d fixnum<))))
        (r3 (time (loop FOR d IN d3 COLLECT (merge-sort:sort d fixnum< :inline t)))))
   (list (equal r1 r2)
         (equal r1 r3))))

Evaluation took:
  0.072 seconds of real time ; stable-sort# 0.072秒
  0.072004 seconds of total run time (0.072004 user, 0.000000 system)
  100.00% CPU
  144,958,896 processor cycles
  327,680 bytes consed
  
Evaluation took:
  0.058 seconds of real time  ; merge-sort:sort# 0.058秒
  0.056003 seconds of total run time (0.056003 user, 0.000000 system)
  96.55% CPU
  116,927,902 processor cycles
  163,840 bytes consed
  
Evaluation took:
  0.036 seconds of real time   ; merge-sort:sort(inline)# 0.036秒
  0.032002 seconds of total run time (0.032002 user, 0.000000 system)
  88.89% CPU
  72,255,454 processor cycles
  163,840 bytes consed
  
--> (T T)

今回のように比較関数自体の実行コストが低い場合だと、関数呼び出し(funcall)部分を含めてinline化するだけで、処理時間が2/3程度に削減できていることが分かる。

*1:マージソート(1) - sileの日記

マージソート(2): 要素数が少ない部分リストの特別扱い

昨日に作成したマージソートに手を加えたもの。
要素数が少ない部分リスト*1には、(再帰的な)マージソートではなく、ソーティングネットワーク的なソートを適用することで高速化を図った。
けど、結果的にはほとんど効果がなかった。

計時

まず計測結果から載せる。

;;; 大量データのソート速度
;;; 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.542 seconds of real time  ; stable-sort# 2.542秒 (前回 2.484秒)
  2.536158 seconds of total run time (2.536158 user, 0.000000 system)
  99.76% CPU
  5,071,126,128 processor cycles
  0 bytes consed
  
Evaluation took:
  1.691 seconds of real time   ; merge-sort:sort# 1.691秒 (前回 1.662秒)
  1.688106 seconds of total run time (1.688106 user, 0.000000 system)
  99.82% CPU
  3,373,722,509 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.207 seconds of real time  ; stable-sort# 0.207秒 (前回 0.204秒)
  0.204013 seconds of total run time (0.204013 user, 0.000000 system)
  98.55% CPU
  414,010,874 processor cycles
  327,680 bytes consed
  
Evaluation took:
  0.174 seconds of real time   ; merge-sort:sort# 0.174秒 (前回 0.176秒)
  0.172011 seconds of total run time (0.172011 user, 0.000000 system)
  98.85% CPU
  346,667,396 processor cycles
  163,840 bytes consed
  
--> T

見ての通り、全くと云って良いほど(前回と)結果に差異がない。
少しくらいは速くなるかと期待していたのだけれど・・・。

ソースコード

今回の実装のソースコード。
特に何かが改善されたということでもないので、コメントはいつも以上に手抜き。

(defpackage merge-sort
  (:use common-lisp)
  (:shadow :common-lisp sort)
  (:export sort))
(in-package :merge-sort)

(declaim (inline halve last! merge-lists less-equal-than
                 sort2 sort3 sort4 sort5)
         (optimize (speed 3) (debug 0) (safety 0)))

(defun halve (n)
  (declare (fixnum n))
  (multiple-value-bind (n1 x) (floor n 2)
    (values (+ n1 x) n1)))

(defmacro cdr! (list new-cdr)
  `(setf (cdr ,list) ,new-cdr))

(defun last! (list)
  (prog1 (cdr list) (cdr! list nil)))

(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)))))
   
(defun less-equal-than (list1 list2 test key)
  (declare (function test key))
  (not (funcall test (funcall key (car list2)) (funcall key (car list1)))))

(defun merge-lists (list1 list2 test key)
  (declare (function test key))
  (labels ((recur (head tail l1 l2)
             (cond ((null l1) (cdr! tail l2) head)
                   ((null l2) (cdr! tail l1) head)
                   ((less-equal-than l1 l2 test key) 
                    (recur head (cdr! tail l1) (cdr l1) l2))
                   (t                 
                    (recur head (cdr! tail l2) l1 (cdr l2))))))
    (if (less-equal-than list1 list2 test key)
        (recur list1 list1 (cdr list1) list2)
      (recur list2 list2 list1 (cdr list2)))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun symb (&rest args)
    (intern (format nil "~{~a~}" args))))

(defun sort2 (list test key &aux (l1 list) (l2 (cdr list)))
  (unless (less-equal-than l1 l2 test key)
    (rotatef (car l1) (car l2)))
  (values l1 (last! l2)))


          ;; (vars (a b c) (list key)
          ;;   body)
          ;;
          ;; =>
          ;; (let* ((a list)
          ;;        (b (cdr a))
          ;;        (c (cdr b)))
          ;;   (let ((_a (funcall key (car a)))
          ;;         (_b (funcall key (car b)))
          ;;         (_c (funcall key (car c))))
          ;;     body))
(macrolet ((vars (vars (list key) &body body)
             `(let* ,(loop FOR prev = nil THEN var
                           FOR var IN vars
                           FOR i fixnum FROM 0
                           COLLECT (if prev 
                                       `(,var (cdr ,prev))
                                     `(,var ,list)))
                (declare (function ,key))
                (let ,(loop FOR var IN vars
                            COLLECT `(,(symb '_ var) (funcall ,key (car ,var))))
                  ,@body)))
           (swap-if-greater-than (x y test)
             `(unless (less-equal-than ,x ,y ,test #'identity)
                (rotatef (car ,x) (car ,y))
                (rotatef ,(symb '_ x) ,(symb '_ y)))))

  (defun sort3 (list test key)
    (vars (a b c) (list key)
      (swap-if-greater-than a c test)
      (swap-if-greater-than a b test)
      (swap-if-greater-than b c test)
      (values a (last! c))))
  
  (defun sort4 (list test key)
    (vars (a b c d) (list key)
      (swap-if-greater-than a c test)
      (swap-if-greater-than b d test)
      (swap-if-greater-than a b test)
      (swap-if-greater-than c d test)
      (swap-if-greater-than b c test)
      (values a (last! d))))

  (defun sort5 (list test key)
    (vars (a b c d e) (list key)
      (swap-if-greater-than a b test)
      (swap-if-greater-than d e test)
      (swap-if-greater-than a c test)
      (swap-if-greater-than b c test)
      (swap-if-greater-than a d test)
      (swap-if-greater-than c d test)
      (swap-if-greater-than b e test)
      (swap-if-greater-than b c test)
      (swap-if-greater-than d e test)
      (values a (last! e)))))

(defun sort-impl (list size test key)
  (declare (fixnum size))
  (case size
    (5 (sort5 list test key))
    (4 (sort4 list test key))
    (3 (sort3 list test key))
    (otherwise
     (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)))))

(defun sort (list test &key (key #'identity) &aux (size (length list)))
  (declare (list list)
           (function test key)
           (optimize (speed 3) (safety 2) (debug 2)))
  (case size
    ((0 1) list)
    (2 
     (values (sort2 list test key)))
    (otherwise
     (values (sort-impl list size test key)))))

*1:具体的には要素数が5以下の部分リスト

マージソート(1)

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

;;;; 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

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

=関数よりもeql関数の方が速かった(間接呼び出し時)

以下、sbcl-1.0.51-x86-64-linuxでの実行結果。

;; 計時用関数
(defun compare-time (fn nums1 nums2)
  (declare (optimize (speed 3) (safety 0) (debug 0))
           (function fn))
  (time
    (loop FOR n1 fixnum IN nums1
          FOR n2 fixnum IN nums2
          WHEN (funcall fn n1 n2)
          SUM 1)))

;; fixnum用の=関数
(declaim (inline fixnum=))
(defun fixnum= (a b)
  (declare (fixnum a b)
           (optimize (speed 3) (safety 0) (debug 0)))
  (= a b))

;; データ
(defparameter *nums1* (loop REPEAT 10000000 COLLECT (random 1000000)))
(defparameter *nums2* (loop REPEAT 10000000 COLLECT (random 1000000)))

;;;; 比較
;; =関数
(compare-time #'= *nums1* *nums2*)
Evaluation took:
  1.312 seconds of real time
  1.300000 seconds of total run time (1.300000 user, 0.000000 system)
  99.09% CPU
  2,616,703,170 processor cycles
  0 bytes consed
==> 12

;; fixnum=関数
(compare-time #'fixnum= *nums1* *nums2*)
Evaluation took:
  0.367 seconds of real time
  0.350000 seconds of total run time (0.320000 user, 0.030000 system)
  95.37% CPU
  732,105,438 processor cycles
  0 bytes consed
==> 12

;; eql関数
(compare-time #'eql *nums1* *nums2*)
Evaluation took:
  0.202 seconds of real time
  0.190000 seconds of total run time (0.190000 user, 0.000000 system)
  94.06% CPU
  403,706,880 processor cycles
  0 bytes consed
==>

eql関数の方がだいぶ効率的。少し意外。

直接使用するなら=関数とeqlの間に差異はない。(fixnum=関数はなぜか遅い)

;; =
(time
 (locally
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (loop FOR n1 fixnum IN *nums1*
        FOR n2 fixnum IN *nums2*
        WHEN (= n1 n2)
        SUM 1)))
Evaluation took:
  0.074 seconds of real time
  0.080000 seconds of total run time (0.080000 user, 0.000000 system)
  108.11% CPU
  147,692,292 processor cycles
  0 bytes consed
==> 12

;; fixnum=
(time
 (locally
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (loop FOR n1 fixnum IN *nums1*
        FOR n2 fixnum IN *nums2*
        WHEN (fixnum= n1 n2)
        SUM 1)))
Evaluation took:
  0.299 seconds of real time
  0.300000 seconds of total run time (0.300000 user, 0.000000 system)
  100.33% CPU
  595,071,324 processor cycles
  0 bytes consed
==> 12

;; eql
(time
 (locally
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (loop FOR n1 fixnum IN *nums1*
        FOR n2 fixnum IN *nums2*
        WHEN (eql n1 n2)
        SUM 1)))
Evaluation took:
  0.076 seconds of real time
  0.070000 seconds of total run time (0.070000 user, 0.000000 system)
  92.11% CPU
  150,384,648 processor cycles
  0 bytes consed
==> 12