#:g1: 隠しスロットで遅延初期化なスロット

Posted 2020-12-10 17:54:31 GMT

allocate-instance Advent Calendar 2020 11日目の記事です。

このブログで度々取り上げているECLOSというMOPの拡張にlazy-classという初期化をアクセス時まで遅延させる機能があるのですが、今回はこの遅延初期化を二次元配列で実装してみようと思います。

遅延初期化の仕様

(defclass foo (lazy-init-object)
  ((a :initform 0 :initialization :read)
   (b :initform 1 :initialization :access)
   (c :initform 2))
  (:metaclass lazy-init-class))

こんな感じに:initializationでスロット読み取り時(:read)や、スロット更新時(:access)が指定された場合、その時まで初期化は遅延されます。

本家ECLOSでは、さらにスロット間の初期化順序の関係性を記述することが可能ですが、論文の記述だけだと若干挙動が不明なのと、かなり複雑になるので、今回は初期化タイミングの機能に絞ります。

実装

今回実装した遅延の仕組みは非常に単純で、二次元配列で隠しスロットを付加し、そこに初期化関数のクロージャーを詰め、指定のタイミングで呼び出すだけです。
詰め込みにはshared-initializeを使いますが、安易にshared-initializeの中でslot-value-using-classを呼ぶと無限ループするので注意しましょう。自分はこのパターンを良くやってしまいます(自分だけか)
大したことはしていないのですが、スロットにオプションを追加すると長くなります……。

(defpackage "2fa9989a-2db4-50b0-953d-4285ca2aaa88" 
  (:use c2cl slotted-objects))

(cl:in-package "2fa9989a-2db4-50b0-953d-4285ca2aaa88")

(defclass lazy-init-class (slotted-class) ())

#+lispworks (defmethod clos:process-a-slot-option ((class lazy-init-class) option value already-processed-options slot) (if (eq option :initialization) (list* :initialization value already-processed-options) (call-next-method)))

(defclass lazy-init-object (slotted-object) () (:metaclass slotted-class))

(defconstant slot-dim 0)

(defconstant init-dim 1)

(defmethod allocate-instance ((class lazy-init-class) &rest initargs) (declare (ignore initargs)) (allocate-slotted-instance (class-wrapper class) (make-array `(2 ,(length (class-slots class))) :initial-element (make-unbound-marker))))

(defclass lazy-init-slot-definition (slot-definition) ((initialization :initform nil :accessor slot-definition-initialization :initarg :initialization)))

(defclass lazy-init-direct-slot-definition (standard-direct-slot-definition lazy-init-slot-definition) ())

(defmethod direct-slot-definition-class ((class lazy-init-class) &rest initargs) (find-class 'lazy-init-direct-slot-definition))

(defclass lazy-init-effective-slot-definition (standard-effective-slot-definition lazy-init-slot-definition) ())

(defmethod effective-slot-definition-class ((class lazy-init-class) &rest initargs) (find-class 'lazy-init-effective-slot-definition))

(defmethod compute-effective-slot-definition ((class lazy-init-class) name direct-slot-definitions) (declare (ignore name)) (let ((eslotd (call-next-method))) (dolist (dslotd direct-slot-definitions) (when (typep dslotd (find-class 'lazy-init-slot-definition)) (setf (slot-definition-initialization eslotd) (slot-definition-initialization dslotd)))) eslotd))

(defmethod initialize-slot-from-initarg ((class lazy-init-class) instance slotd initargs) (let ((slot-initargs (slot-definition-initargs slotd))) (loop :for (initarg value) :on initargs :by #'cddr :do (when (member initarg slot-initargs) (setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd)) value) (return T)))))

(defmethod initialize-slot-from-initfunction ((class lazy-init-class) instance slotd) (let ((initfun (slot-definition-initfunction slotd))) (unless (not initfun) (setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd)) (funcall initfun)))))

(defmethod shared-initialize ((instance lazy-init-object) slot-names &rest initargs) (let* ((class (class-of instance)) (slotds (class-slots class))) (dolist (slotd slotds) (setf (aref (instance-slots instance) init-dim (slot-definition-location slotd)) (lambda () (unless (initialize-slot-from-initarg class instance slotd initargs) (when (or (eq T slot-names) (member (slot-definition-name slotd) slot-names)) (initialize-slot-from-initfunction class instance slotd)))))) ;; eager init (dolist (slotd slotds) (when (null (slot-definition-initialization slotd)) (let ((slots (instance-slots instance)) (loc (slot-definition-location slotd))) (funcall (aref slots init-dim loc)) (setf (aref slots init-dim loc) nil))))) instance)

(defmethod slot-value-using-class ((class lazy-init-class) instance (slotd slot-definition)) (let ((loc (slot-definition-location slotd)) (slots (instance-slots instance))) (case (slot-definition-initialization slotd) ((:read) (when (aref slots init-dim loc) (funcall (aref slots init-dim loc)) (setf (aref slots init-dim loc) nil))) (otherwise nil)) (aref slots slot-dim loc)))

(defmethod (setf slot-value-using-class) (value (class lazy-init-class) instance (slotd slot-definition)) (let ((loc (slot-definition-location slotd)) (slots (instance-slots instance))) (case (slot-definition-initialization slotd) ((:read :access) (when (aref slots init-dim loc) (funcall (aref slots init-dim loc)) (setf (aref slots init-dim loc) nil))) (otherwise nil)) (setf (aref slots slot-dim loc) value)))

動作

(defclass foo (lazy-init-object)
  ((a :initform 0 :initialization :read)
   (b :initform 1 :initialization :access)
   (c :initform 2))
  (:metaclass lazy-init-class))

(let ((obj (make-instance 'foo))) (instance-slots obj)) ;スロットデータの中身を覗いてみる → #2A((#<Slot Unbound Marker> #<Slot Unbound Marker> 2) (#<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B14> #<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B3C> #<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B64>))

(let ((obj (make-instance 'foo))) (with-slots (a b c) obj a b c) (instance-slots obj)) → #2A((0 #<Slot Unbound Marker> 2) (nil #<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 406001227C> nil)) ; :read で初期化された (let ((obj (make-instance 'foo))) (with-slots (a b c) obj a (setq b 42) c) (instance-slots obj)) → #2A((0 42 2) (nil nil nil)) ; :readと:access で初期化された

まとめ

スロット初期化の遅延ですが、個人的には遅延させたい局面に遭遇したことがないので、いまいちぴんと来ません。大きなリソースを割り付けたい場合などにはできるだけ遅延させると効率が良いのかも。

メタクラスの定義やスロット定義では似たようなものを毎度書くので、defmetaclassのようなものを定義して使っている人もいます。

Eric L. Peterson氏のdefmetaclassは、なかなか良い圧縮具合と使い勝手っぽいので真似してみたいところですが、全部のパターンがマクロで上手く纏められるかというと、そうでもないのがなんとも悩ましい。

参考


HTML generated by 3bmd in LispWorks 7.0.0

comments powered by Disqus