#:g1: slot-valueを排除する試み(1)

Posted 2019-11-06 19:47:19 GMT

オブジェクトへのアクセスは、slot-valueを使わず、アクセサ経由でを心掛けようとは良くいわれますが、今回は、MOPでslot-valueを回避できないかを探る試みです。

MOPには、standard-instance-accessのようなものがあるので、アクセスはstandard-instance-accessを直接使ってしまえば良かろうと思って下記のようなものを書いてみました。

アクセサがstandard-instance-accessでアクセスするインデックスを保持できれば良いだけなのですが、class-slots実行以降でしかインデックスは確定しないので、アクセサが別途インデックスを保持するように拡張し、インデックス確定後にアクセサに値を格納することにしました。

(in-package cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :closer-mop) (when (find-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6") (delete-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")))

(defpackage "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6" (:use :c2cl))

(in-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")

(eval-when (:compile-toplevel :load-toplevel :execute) (macrolet ((in-syntax (name) `(progn (defvar ,(intern name) (copy-readtable nil)) (setq *readtable* ,(intern name)))) (via-accessor-prefix-setup () `(set-macro-character #\~ (lambda (srm chr) (declare (ignore chr)) (intern (concatenate 'string (string 'via-accessor-) (string (read srm)))))))) (in-syntax "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6") (via-accessor-prefix-setup)))

;; utils (eval-when (:compile-toplevel :load-toplevel :execute) (setf (fdefinition 'a) #'make-instance) (defun fintern (package control-string &rest args) (with-standard-io-syntax (intern (apply #'format nil control-string args) (or package *package*)))) (defmacro <defclass> (name supers slots &rest class-options) `(defconstant ,(fintern (symbol-package name) "<~A>" name) (defclass ,name ,supers ,slots ,@class-options))) #+lispworks (editor:setup-indent "<defclass>" 2 2 10) 'eval-when)

(defclass ~class (standard-class) ())

(defmethod validate-superclass ((class ~class) (super standard-class)) T)

(defclass ~accessor-method (standard-accessor-method) ((slot-location :initarg :slot-location :accessor ~accessor-method-location)))

(defclass ~reader-method (~accessor-method standard-reader-method) ())

(defclass ~writer-method (~accessor-method standard-writer-method) ())

(defun ~reader-method-function-maker (method) #+(or lispworks ccl) (lambda (arg &rest next-methods) (declare (ignore next-methods)) (funcall (lambda (instance) (standard-instance-access instance (~accessor-method-location method))) arg)) #+(or sbcl) (lambda (args next-methods) (declare (ignore next-methods)) (apply (lambda (instance) (standard-instance-access instance (~accessor-method-location method))) args)))

(defmethod initialize-instance ((method ~reader-method) &rest initargs) (apply #'call-next-method method :function (~reader-method-function-maker method) initargs))

(defun ~writer-method-function-maker (method) #+(or lispworks ccl) (lambda (val arg &rest next-methods) (declare (ignore next-methods)) (funcall (lambda (val instance) (setf (standard-instance-access instance (~accessor-method-location method)) val)) val arg)) #+(or sbcl) (lambda (args next-methods) (declare (ignore next-methods)) (apply (lambda (val instance) (setf (standard-instance-access instance (~accessor-method-location method)) val)) args)))

(defmethod initialize-instance ((method ~writer-method) &rest initargs) (apply #'call-next-method method :function (~writer-method-function-maker method) initargs))

(defmethod reader-method-class ((class ~class) direct-slot &rest args) (declare (ignore args direct-slot)) (find-class '~reader-method))

(defmethod writer-method-class ((class ~class) direct-slot &rest args) (declare (ignore args direct-slot)) (find-class '~writer-method))

(defmethod finalize-inheritance :after ((class ~class)) (let ((esds (class-slots class))) (dolist (dsd (class-direct-slots class)) (dolist (reader (slot-definition-readers dsd)) (let ((meth (find-method (ensure-generic-function reader :lambda-list '(x)) nil (list class) nil))) (when meth (setf (~accessor-method-location meth) (slot-definition-location (find (slot-definition-name dsd) esds :key #'slot-definition-name)))))) (dolist (writer (slot-definition-writers dsd)) (let ((meth (find-method (ensure-generic-function writer :lambda-list '(val x)) nil (list (find-class T) class) nil))) (when meth (setf (~accessor-method-location meth) (slot-definition-location (find (slot-definition-name dsd) esds :key #'slot-definition-name)))))))))

(defmethod shared-initialize :after ((class ~class) slot-names &rest initargs) (declare (ignore slot-names initargs)) (finalize-inheritance class))

おまけに速くなるのだろうか……

理屈では間接参照のslot-valueと違って直接参照のstandard-instance-accessの方が速くなる筈ですがどうでしょう。
さすがに処理系もslot-valueでのアクセスの最適化はしていると思いますが……。

(<defclass> foo ()
  ((a :initform 0 :accessor .a)
   (b :initform 1)
   (c :initform 2 :accessor .c))
  (:metaclass ~class))

(<defclass> bar (foo) ((d :initform 3 :accessor .d)) (:metaclass ~class))

読み出し速度

LispWorksだと今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等だと余計なことをするよりslot-valueの方が速いようです……。

(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (slot-value obj 'a))))

User time = 1.240 System time = 0.000 Elapsed time = 1.242 Allocation = 1296014992 bytes 0 Page faults Calls to %EVAL 18000041

(time (let ((obj (a <foo>))) (dotimes (i (expt 10 6)) (.a obj))))

User time = 1.100 System time = 0.000 Elapsed time = 1.095 Allocation = 1296011632 bytes 0 Page faults Calls to %EVAL 17000041

書き込み速度

LispWorksだと読み出し同様、今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等でも若干速くなるかも。

(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (setf (slot-value obj 'a) 42))))

User time = 7.260 System time = 0.000 Elapsed time = 7.259 Allocation = 3126471872 bytes 0 Page faults Calls to %EVAL 20000041

(time (let ((obj (a <foo>))) (dotimes (i (expt 10 6)) (setf (.a obj) 42))))

User time = 6.020 System time = 0.060 Elapsed time = 6.074 Allocation = 3118472872 bytes 0 Page faults Calls to %EVAL 22000041

今回のまとめ

明示的にstandard-instance-accessを使うようにしても、slot-value経由より遅くなることもあるようなので、もう少し詰めて対策しないと御利益はなさそうです。
標準のオブジェクトへのアクセスは処理系が結構最適化しているのですが、ユーザー定義のメタクラス等の派生物は標準から外れるので処理系が用意している最適化の適用外になってしまうことも多いようです。

なお今回は、アクセス方法でslot-valueを外す試みでしたが、インスタンス初期化まわりでもslot-valueは使われています。
どうもslot-valueを排除するのは簡単な話ではなさそう。

〜インスタンス生成篇へつづく〜


HTML generated by 3bmd in LispWorks 7.1.2

comments powered by Disqus