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