Posted 2020-12-02 13:03:55 GMT
allocate-instance Advent Calendar 2020 2日目の記事です。
前回は、Metaobject Protocols Why We Want Them and What Else They Can Doに出てくるインスタンスを中身をハッシュテーブルにしてメモリ効率を上げる手法について紹介しましたが、大抵の実装は、インスタンスの確保まではカスタマイズせずにフックをかけてリダイレクトすることが多いということを述べました。
ということで、今回は、実際にallocate-instance
が確保するストレージをハッシュテーブルにしてみましょう。
現在の主な処理系が採用しているオブジェクト指向システムの実装は、大抵PCL(Portable Common Loops)をカスタマイズしたものです。
PCLではstandard-object
は、wrapperというクラス定義の情報とスロットを格納する配列から構成されています。
ということで、スロットを格納するオブジェクトをハッシュテーブルに差し替えれば良いのですが、そのためにstandard-object
の内部構造をいじる関数を定義しておきます。
なお、残念ながらECLは、allocate-instance
の下請け関数がCレベルで配列をアロケートするものになっており、Lispレベルではカスタマイズできないようなので今回はパスします(10行程度のCの定義を加えれば任意のオブジェクトを格納場所にできそうではありますが)。
ちなみに他の処理系も正しい作法かどうかは分からないので、その辺りはご了承ください。特に商用処理系はソースが確認できないのでdisassemble
の結果から想像して作成していたりします。
(defun alloc-fix-instance (wrapper instance-slots)
#+allegro
(excl::.primcall 'sys::new-standard-instance
wrapper
instance-slots)
#+lispworks
(sys:alloc-fix-instance wrapper instance-slots)
#+sbcl
(let* ((instance (sb-pcl::%make-instance (1+ sb-vm:instance-data-start))))
(setf (sb-kernel::%instance-layout instance) wrapper)
(setf (sb-pcl::std-instance-slots instance) instance-slots)
instance)
#+ccl
(let ((instance (ccl::gvector :instance 0 wrapper nil)))
(setf (ccl::instance.hash instance) (ccl::strip-tag-to-fixnum instance)
(ccl::instance.slots instance) instance-slots)
instance))
(defun class-wrapper (class)
#+allegro (excl::class-wrapper class)
#+lispworks (clos::class-wrapper class)
#+sbcl (sb-pcl::class-wrapper class)
#+ccl (ccl::instance-class-wrapper class))
(defun instance-wrapper (ins)
#+allegro (excl::std-instance-wrapper ins)
#+lispworks (clos::standard-instance-wrapper ins)
#+sbcl (sb-kernel::%instance-layout ins)
#+ccl (ccl::instance.class-wrapper ins))
(defun instance-slots (ins)
#+allegro (excl::std-instance-slots ins)
#+lispworks (clos::standard-instance-static-slots ins)
#+sbcl (sb-pcl::std-instance-slots ins)
#+ccl (ccl::instance.slots ins))
上記定義の関数で、standard-object
のスロット格納だけをいじることができるようになったので、hash-table-slots-class
を定義してみます。
今回のような場合、クラスのクラス定義とインスタンスのクラス定義をセットで定義することになります。
インスタンスの初期化周りもインスタンスのスロットへのアクセス方法が変更になるので、別途定義してやる必要があります。
処理系実装によっては、うまくstandard-object
の内容を引き継いでくれることもあるようですが、多分、別に定義しておいた方が良いでしょう。
また今回はslot-unbound
周りは長くなるので端折ります。
(defvar *slot-unbound*
#+lispworks clos::*slot-unbound*)
(defclass hash-table-slots-class (standard-class)
())
(defclass hash-table-slots-object (standard-object)
()
(:metaclass hash-table-slots-class))
(defmethod validate-superclass ((class hash-table-slots-class) (super standard-class))
T)
(defgeneric initialize-slot-from-initarg (class instance slotd initargs))
(defmethod initialize-slot-from-initarg (class instance slotd initargs)
(declare (ignore class))
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (gethash slotd (instance-slots instance))
value)
(return T)))))
(defgeneric initialize-slot-from-initfunction (class instance slotd))
(defmethod initialize-slot-from-initfunction (class instance slotd)
(declare (ignore class))
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (gethash slotd (instance-slots instance))
(funcall initfun)))))
(defmethod shared-initialize
((instance hash-table-slots-object) slot-names &rest initargs)
(let ((class (class-of instance)))
(dolist (slotd (class-slots class))
(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)))))
instance)
(defmethod allocate-instance ((class hash-table-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let ((tab (make-hash-table)))
(dolist (slotd (class-slots class) tab)
(setf (gethash slotd tab) *slot-unbound*)))))
(defmethod slot-value-using-class
((class hash-table-slots-class) instance (slotd slot-definition))
(gethash slotd (instance-slots instance)))
(defmethod (setf slot-value-using-class)
(val (class hash-table-slots-class) instance (slotd slot-definition))
(setf (gethash slotd (instance-slots instance))
val))
これでこんな感じに動きますが、見た目は何もかわりません……。
(describe (make-instance 'foo))
;>> #<foo 402025BBD3> is a foo
;>> a a
;>> b b
;>> c c
もちろん中身はハッシュテーブルになっています。
(let ((o (make-instance 'foo)))
(describe (instance-slots o)))
;>> #<eql Hash Table{3} 4020000D23> is a hash-table
;>> #<standard-effective-slot-definition c 422020876B> c
;>> #<standard-effective-slot-definition b 4220208753> b
;>> #<standard-effective-slot-definition a 4220208723> a
インスタンスの中身を配列からハッシュテーブルにするだけなのですが、slot-unbound周りを省略したのに結構なコード量です。
上層のプロトコルが全部正しく機能するように一式定義するのは結構手間ですが、そうそうカスタマイズする部分でもないので、妥当といえば妥当かもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0