#:g1: MOP vs マクロ (5)

Posted 2019-02-18 21:04:14 GMT

前回let*-like slot initialization semanticsはマクロ主体での実装でしたが、今回はMOP主体でチャレンジです。

しかし、defclassが周囲のレキシカル変数を取り込むので何にせよ全体はマクロでまとめる他なさそうですが、そこは諦めます。

あれこれ試行錯誤しましたが、今回の方針は、

shared-initializeで呼ばれる関数ですが、下記のようなものを生成します。 初期化されるインスタンスを引数に取り、内部では、専らstandard-instance-accessを使って読み書きします。

(lambda (obj)
  (symbol-macrolet ((a (standard-instance-access obj 0))
                    (b (standard-instance-access obj 1)))
    (when (eq unbound-marker (standard-instance-access obj 0))
      (setf (standard-instance-access obj 0)
            (funcall #<Function 1 subfunction of (lw:top-level-form 1) 4060007E8C>
                     nil
                     nil)))
    (when (eq unbound-marker (standard-instance-access obj 1))
      (setf (standard-instance-access obj 1)
            (funcall #<Function 2 subfunction of (lw:top-level-form 1) 4060007E34>
                     a
                     nil)))
    (when (eq unbound-marker (standard-instance-access obj 2))
      (setf (standard-instance-access obj 2)
            (funcall #<Function 3 subfunction of (lw:top-level-form 1) 4060007DAC>
                     a
                     b)))))

そして、下記がMOPチャレンジ版のコードですが、大したことはしていないのに長くなりました。

(cl:in-package :cl-user)

(ql:quickload :closer-mop)

(defpackage :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3 (:use :c2cl) #+sbcl (:shadowing-import-from :cl :defmethod))

(cl:in-package :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3)

(defconstant unbound-marker (if (boundp 'unbound-marker) unbound-marker (gensym "unbound")))

(defclass let*-slot-class (standard-class) ((let*-slots :initform nil :accessor class-let*-slots :initarg :let*-slots) (let*-initfunction :accessor class-let*-initfunction :initarg :let*-initfunction)))

(defmethod validate-superclass ((c let*-slot-class) (sc standard-class)) T)

(defclass let*-standard-object (standard-object) ())

(defun process-a-slot (slot) (loop :with name := (car slot) :for (k v) :on (cdr slot) :by #'cddr :when (eq k :initform) :append `(:initform ,v :initfunction (constantly unbound-marker)) :into initform :when (eq k :initarg) :collect v :into initargs :when (eq k :writer) :collect v :into writers :when (eq k :reader) :collect v :into readers :when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers :finally (return `(:name ,name :initargs ,initargs ,@initform :writers ,writers :readers ,readers))))

(defclass let*-direct-slot-definition (standard-direct-slot-definition) ((let*-initfunction :initarg :let*-initfunction :accessor slot-definition-let*-initfunction)))

(defmethod direct-slot-definition-class ((class let*-slot-class) &rest initargs) (find-class 'let*-direct-slot-definition))

(defmethod compute-slots :around ((class let*-slot-class)) (let* ((let*-slots (class-let*-slots class)) (slots (call-next-method)) (let*-slot#s (loop :for s :in let*-slots :for pos := (position s slots :key #'slot-definition-name) :when pos :collect (cons s pos)))) (setf (class-let*-initfunction class) (compile nil `(lambda (obj) (symbol-macrolet (,@(loop :for s :in (butlast let*-slots) :collect `(,s (standard-instance-access obj ,(cdr (assoc s let*-slot#s)))))) ,@(loop :for s :in let*-slots :for pos := (cdr (assoc s let*-slot#s)) :for argpos :from 0 :collect `(when (eq unbound-marker (standard-instance-access obj ,pos)) (setf (standard-instance-access obj ,pos) (funcall ,(slot-definition-let*-initfunction (find s (class-direct-slots class) :key #'slot-definition-name)) ,@(replace (make-list (length (cdr let*-slots))) (subseq (butlast let*-slots) 0 argpos)))))))))) slots))

(defmethod shared-initialize :after ((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys) (funcall (class-let*-initfunction (class-of obj)) obj))

(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options) (loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x)) slots) :for s :in slots :for cs := (copy-list (process-a-slot s)) :collect `(,@cs :let*-initfunction (lambda (,@(butlast slot-names)) (declare (ignorable ,@(butlast slot-names))) ,(getf cs :initform))) :into canonicalized-slots :finally (return `(eval-when (:compile-toplevel :load-toplevel :execute) (ensure-class ',name :metaclass 'let*-slot-class :direct-superclasses (adjoin 'let*-standard-object ',superclasses) :direct-slots (list ,@(mapcar (lambda (s) (destructuring-bind (&key name initargs initform initfunction writers readers let*-initfunction &allow-other-keys) s `(list :name ',name :initargs ',initargs :initform ',initform :initfunction ,initfunction :writers ',writers :readers ',readers :let*-initfunction ,let*-initfunction))) canonicalized-slots)) :let*-slots ',slot-names ,@class-options)))))

動作

(defclass* qqq ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))

(with-slots (a b c) (make-instance 'qqq) (list a b c)) ;=> (42 42 84) (with-slots (a b c) (make-instance 'qqq :c 0) (list a b c)) ;=> (42 42 0) (with-slots (a b c) (make-instance 'qqq :b 0) (list a b c)) ;=> (42 0 42) (with-slots (a b c) (make-instance 'qqq :a 0) (list a b c)) ;=> (0 0 0) (with-slots (a b c) (make-instance 'qqq :a 0 :b 1) (list a b c)) ;=> (0 1 1)

MOPにして良いことがあるのか

マクロ主体の場合は、スロットアクセスが名前参照ベースなので若干非効率効率ですが、MOPを使えば、standard-instance-access等の効率の良いアクセス方法が使えるので速くできるだろうということで、今回は、standard-instance-accessの利用を軸に組み立ててみました。

素のインスタンス生成〜初期化と比較して、マクロ版は、約1.8倍の時間のところをMOP版では、約1.3倍程度にまで抑えることができました。
まあもっと速くできそうではありますが……。

(defclass let-slot ()
  ((a :initform 42)
   (b :initform 42)
   (c :initform 42)))

(defclass* let*-slot () ((a :initform 42 :initarg :a) (b :initform a :initarg :b) (c :initform (+ a b) :initarg :c)))

(dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb::defclass* let*-slot-macro () ((a :initform 42 :initarg :a) (b :initform a :initarg :b) (c :initform (+ a b) :initarg :c)))

計時

(let ((cnt 1000000))
  (time 
   (dotimes (i cnt)
     (make-instance 'let-slot)))
  (time 
   (dotimes (i cnt)
     (make-instance 'let*-slot)))
  (time 
   (dotimes (i cnt)
     (make-instance 'let*-slot-macro))))

Timing the evaluation of (dotimes (i cnt) (make-instance 'let-slot))

User time = 1.270 System time = 0.000 Elapsed time = 1.258 Allocation = 1352109704 bytes 0 Page faults Calls to %EVAL 17000036 Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot))

User time = 1.660 System time = 0.000 Elapsed time = 1.654 Allocation = 1352029784 bytes 0 Page faults Calls to %EVAL 17000036 Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot-macro))

User time = 2.260 System time = 0.000 Elapsed time = 2.260 Allocation = 1352020600 bytes 0 Page faults Calls to %EVAL 17000036 nil

継承した場合にスロットのインデックスの位置関係はどうなるのか

具体的には下記のような場合に、standard-instance-accessが指す先がどのような構成になるのかを把握していないと使えないのですが、

(defclass A ()
  ((a :initform 0 :initarg :a)
   (b :initform 1 :initarg :b)
   (c :initform 2 :initarg :c)))

(defclass* B (A) ((x :initform 42 :initarg :x) (y :initform x :initarg :y) (z :initform (+ x y) :initarg :z)))

(with-slots (a b c x y z) (make-instance 'B :y 1) (list a b c x y z)) ;=> (0 1 2 42 1 43)

AMOPのInstance Structure Protocolの例では、compute-slotsの並び順で、standard-instance-accessのインデックスを決められる的なことが書いてあります。
実際に試してみると、継承した場合、上位クラスのスロット数分だけオフセットしたり(SBCL、LispWorks)名前とスロットの値が一致しなかったり(LispWorks)で、compute-slotsで並べた順がすなわちインデックスとはならない実装があるようです。

しょうがないので、結局名前からインデックスを求めるようにしましたが、私が何か勘違いをしているのか、もしくはこの仕様に準拠している処理系が少ないのか。

まとめ

これまでlet*風にスロットの逐次初期化を2パスで考えてみましたが、shared-initializeを差し替えてしまった方が素直なのかもしれません。
そのうち試してみようかなと思います。


HTML generated by 3bmd in LispWorks 7.0.0

comments powered by Disqus