マージソート(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)))))
