#:g1: インスタンスの中身をハッシュテーブルにする

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