MOPを使つた永續オブジェクトの實裝

はじめに

西暦2001年にボストンで開かれた Franz Developer Symposium において、 Paul Graham という人の talk session があり、 彼がそのころ作つていた、 yahoo store でのアプリケイションについての話が出ました。 その時、会場から「データベースは何を使つていますか」との問に對し、 「Unix File System だ」と答が返つたのをとても印象深く覺えています。

プログラムを書いていてデータベースが欲しくなる事はままありますが、 Common Lisp 使いであれば、 RDB などの DBMS を使うよりも、 簡易な永續オブジェクトシステムを作つてしまえ、 という事は誰でも考えます。 上の Graham の話も、 おそらくそれに近い文脈で出て來た發言であろうと思います。

Common Lisp の永續オブジェクトライブラリーは搜せばいくつもあり、その中の一つ、 Allegro CL にバンドルされている、 AllegroCache は、 いつも便利に使わせてもらつているのですが、 open source では無いために、 Allegro CL で開發したプログラムを、いざ SBCL などへ移植する際に、 AllegroCache を使つていると面倒な話になります。

今回、たまたま、あるプロジェクトで Allegro CL (+ AllegroCache) で書いたアプリケイションを、 SBCL へ移植する必要が生じ、 CLOS (Common Lisp Object System) を擴張して AllegroCache 互換な永續オブジェクトシステムを書いてみました。 とても naive な作りになつていますから、 CLOS MOP の好い入門になるのではないかと思い、 以下にその實裝メモを殘します。

AllegroCache

AllegroCache は、 CLOS オブジェクトを永續化するためのライブラリーです。 AllegroCache Tutorial を見ながら、ざつとその仕樣を概觀してみます。

今、或るグラフ構造をなすデータ構造を考え、それを永續オブジェクトとして保存したい、 とします。その場合、下が、永續オブジェクトに對應するクラス定義例になります。

(defclass node ()
  ((name :initarg :name :reader name :index :any-unique)
   (children :initarg :children :reader children)
   (max-depth :initform nil :accessor max-depth :index :any))
  (:metaclass persistent-class))

普通の defclass に比べて特徴的なのは、 :metaclass を指定している事、 スロット定義の中に、 :index :any-unique とか :index :any などの記述が見られる事、 の二点です。

この例の場合、 node インスタンスに與えられる名前 name はユニークである事が求められるとして、

(name :initarg :name :reader name :index :any-unique)

と記述しています。

node の子供を持つスロット children には普通のリストを持たせれば好いので、 :index 指定は必要なく、普通に、

(children :initarg :children :reader children)

と書きます。

また、グラフ構造の深さを max-depth とし、後々、 或る特定の深さを持つた構造を、数あるインスタンスの中から引いてきたいとすると、

(max-depth :initform nil :accessor max-depth :index :any)

のようにスロットを定義しておきます。

node クラスのインスタンスは、普通に MAKE-INSTANCE で作る事ができます。 1

> (make-instance 'node :name "foo")
#<node "foo" max-depth: nil>
> (make-instance 'node :name "bar")
#<node "bar" max-depth: nil>

生成されたインスタンスは :index 指定されたスロット値で檢索をかける事ができる。

> (retrieve-from-index 'node 'name "foo")
#<node "foo" max-depth: NIL>
> (retrieve-from-index 'node 'name "bar")
#<node "bar" max-depth: NIL>

"bar" を "foo" の子供に指定し、 max-depth を計算させてみましょう。 2

> (setf (slot-value ** 'children) (list *)
        (slot-value *  'children) (list))
NIL
> (compute-max-depth ***)
2

以下 max-depth での檢索例。

> (retrieve-from-index 'node 'max-depth 2)
#<node "foo" max-depth: 2>
> (retrieve-from-index 'node 'max-depth 1 :all t)
(#<node "bar" max-depth: 1>)
> (retrieve-from-index 'node 'max-depth 0)
NIL

最後に doclass マクロの利用例を示します。

> (doclass (object 'node)
    (format t "#<node ~S max-depth: ~S>~%" 
            (name object) (max-depth object)))
#<node "bar" max-depth: 1>
#<node "foo" max-depth: 2>
NIL

Meta Classes

さて、上に説明したような object system を MOP (MetaObject Protocol) を使つて構築してみます。

最初に必要なのは :metaclass 指定に使われるメタクラスの定義です。

(defclass persistent-class (standard-class)
  ((persistent-instances :accessor persistent-instances
                         :initform (make-array 0 :fill-pointer t :adjustable t)
                         :allocation :class)
   (persistent-max-oid :accessor persistent-max-oid :initform -1 :allocation :class)
   (class-instances :accessor class-instances :initform '())))

persistent-class のスロットは三つ用意しました。

  1. 生成された全ての永續インスタンスを仕舞つておく persistent-instances スロット。
    親クラスに persistent-class を持つ全てのクラス、 即ち永續クラスに共通のスロットなので :allocation :class とします。
  2. persistent-max-oid ですが、これは生成された永續インスタンスにID (通し番号) をふるための記憶場所。 これも :allocation :class とします。
  3. クラス毎の永續インスタンスを仕舞つておくための class-instances スロット。
    こちらは :allocation :instance です。

次に必要なのは、メタクラスに persistent-class を持つ全てのインスタンス、 即ち永續インスタンスの、親クラス (superclass) になるべきクラスです。

(defclass persistent-standard-object ()
  ((db-object-oid :accessor db-object-oid
                  :initarg :db-object-oid
                  :initform 0)
   (deleted-instance-p :accessor deleted-instance-p
                       :initarg :deleted-instance-p
                       :initform nil)))

ここでは必要なスロットを二つ用意します。

  1. db-object-oid は全ての永續インスタンスが共通に持つスロットで、 インスタンスID (通し番号) が置かれる。
  2. DELETE-INSTANCE 3 で消されたインスタンスに立てるフラッグ deleted-instance-p
    これも全ての永續インスタンスが共通に持つスロット。

Initializing Class Metaobjects

基盤のクラス定義が揃つたら、 永續クラス (persistent-class を親クラスに持つ class metaobject) の初期化メソッドを定義します。 ここでの仕事は、永續クラスの direct-superclasses リストへ persistent-standard-object を強制的に差し込んでやる事です。 こうする事により、永續インスタンスは、 どれも persistent-standard-object を繼承する事になります。

(defmethod shared-initialize :around ((class persistent-class) slot-names
                                      &rest rest
                                      &key (direct-slots nil direct-slots-p)
                                           (direct-superclasses nil direct-superclasses-p))
  "Append persistent-standard-object to direct-superclasses of the class."
  (symbol-macrolet ((persistent-standard-object
                        (load-time-value (find-class 'persistent-standard-object))))
    (when direct-superclasses-p
      ;; Ensure persistent-standard-object is in the superclass list.
      (unless (member persistent-standard-object direct-superclasses)
        (setf direct-superclasses
          (append direct-superclasses
                  (list persistent-standard-object))))))
  (unless direct-slots-p
    (return-from shared-initialize (call-next-method)))
  (remf rest :direct-slots)
  (apply #'call-next-method class slot-names
         (append (when direct-slots-p (list :direct-slots direct-slots))
                 (if direct-superclasses-p
                     (list* :direct-superclasses direct-superclasses rest)
                   rest))))

永續クラスの初期化定義につづいて、永續インスタンスの初期化定義をします。

  1. db-object-oid をセットし、
  2. persistent-instancesclass-instances に、 それぞれ新しいインスタンスをプッシュしてやる

のがここでの仕事です。 永續インスタンスは、常に persistent-standard-object を superclass に持ちますから、 以下のような定義となります。

(defmethod initialize-instance :after ((instance persistent-standard-object) &rest args)
  (declare (ignore args))
  (with-slots (persistent-instances persistent-max-oid class-instances)
      (class-of instance)               ; metaclass
    (setf (db-object-oid instance)
      (incf persistent-max-oid))
    (vector-push-extend instance persistent-instances)
    (push instance class-instances)))

メタクラス定義廻りの大枠はこれで終りです。

slot definition 定義が未だ濟んでおらず、 index 指定などはできませんが、 繼承関係が期待通りになつているかを確認しておきましょう。

> (defclass foo ()
    ((x) (y) (z))
    (:metaclass persistent-class))
#<PERSISTENT-CLASS FOO>
> (class-of *)
#<STANDARD-CLASS PERSISTENT-CLASS>
> (make-instance 'foo)
#<FOO @ #x10000c07572>
> (class-of *)
#<PERSISTENT-CLASS FOO>
> (class-direct-superclasses *)
(#<STANDARD-CLASS PERSISTENT-STANDARD-OBJECT>)

Slot Definition Metaobjects

さてここからは、本永續オブジェクトシステムの核となる slot definition metaobject を定義していきますが、 slot definition には direct slot definition と effective slot definition の二種類があり、それぞれ定義をします。

先づ、 上例の node クラス定義のところで見た、 :index 指定されたスロットに對應する direct slot definition の型を、以下の樣に定義します。

(defclass indexed-direct-slot-definition (standard-direct-slot-definition)
  ((index :initarg :index :accessor slot-definition-index)))

そうして、メソッド DIRECT-SLOT-DEFINITION-CLASS を定義して、 クラス初期化の際に、適切な型を持つた slot definition class metaobject が受け取れるように細工します。 (クラスが初期化される際に、其其のスロット定義が、一旦 direct slot definition metaobject へ変換される事、そして、その型を決めるのに、 DIRECT-SLOT-DEFINITION-CLASS が呼ばれる事が MetaObject Protocol で決まつています。)

(defmethod direct-slot-definition-class ((class persistent-class) &rest initargs &key index &allow-other-keys)
  "永續クラスの direct-slot-definition-class"
  (declare (ignore initargs))
  (ccase index
    ((:any :any-unique)
     'indexed-direct-slot-definition)
    ((nil)
     (call-next-method))))

次に、 effective slot definition を定義します。 effective slot definition metaobject には、 スロット値をインデクシングするためのハッシュテーブルを持たせます。 :index :any とされたときと、 :index :any-uniq とされたときで、 それぞれ別の型を用意します。

(defclass indexed-effective-slot-definition (standard-effective-slot-definition)
  ())                           ; superclass of e-s-d

(defclass index-any-effective-slot-definition (indexed-effective-slot-definition)
  ((index :initarg :index :accessor slot-definition-index :initform (make-hash-table :test #'equal))))

(defclass index-any-unique-effective-slot-definition (indexed-effective-slot-definition)
  ((index :initarg :index :accessor slot-definition-index :initform (make-hash-table :test #'equal))))

compute-effective-slot-definition

こうしておいて今度は COMPUTE-EFFECTIVE-SLOT-DEFINITION を定義します。 (クラスの繼承関係が整理され、最終的に得られるスロット定義が、 effective slot definition metaobject です。 effective slot definition metaobject を算出するために呼ばれるメソッドが、 COMPUTE-EFFECTIVE-SLOT-DEFINITION である事、そしてその型を決めるのに、 EFFECTIVE-SLOT-DEFINITION-CLASS が呼ばれる事が MetaObject Protocol で決まつています。)

本件において、 COMPUTE-EFFECTIVE-SLOT-DEFINITION で必要とされるのは、本質的には、 メソッド EFFECTIVE-SLOT-DEFINITION-CLASS が、 effective slot definition metaobject の型を決める事が出來るためのフラッグをセツトするだけです。

但し、クラスが再定義されたときに、 スロット値のインデックスを保持しているハッシュテーブルまでリニューアルされては困るので、 その對應コードが追加してあります。

(defvar *index*)

(defmethod effective-slot-definition-class ((class persistent-class) &rest initargs)
  (declare (ignore initargs))
  (ccase *index*
    (:any 'index-any-effective-slot-definition)
    (:any-unique 'index-any-unique-effective-slot-definition)
    ((nil) (call-next-method))))

(defmethod compute-effective-slot-definition ((class persistent-class) slot-name dsds)
  "永續クラスの effective-slot-definition の算出"
  (let* ((dsd (find-if (lambda (dsd)
                         (and (typep dsd 'indexed-direct-slot-definition)
                              (eq slot-name (slot-definition-name dsd))))
                       dsds))
         ;; e-s-d の型を決めるための flag セット
         (*index* (and dsd (slot-definition-index dsd))))
    ;; 既に finelize されてゐるときは、前の e-s-d を使ひ廻す。
    ;; さもないと新に e-s-d が alloc されて、以前の index が消えてしまふ
    (if (class-finalized-p class)
        (let ((esd (find-if (lambda (esd) ; esd already exists?
                              (and (typep esd 'indexed-effective-slot-definition)
                                   (eq slot-name (slot-definition-name esd))))
                            (class-slots class))))
          (if (and esd dsd)             ; yes, esd already exists
              esd
            (call-next-method)))
      (call-next-method))))

適切に slot definition metaobject が取れているか否かを確認しておきましょう。

> (defclass node ()
    ((name :initarg :name :reader name :index :any-unique)
     (children :initarg :children :reader children)
     (max-depth :initform nil :accessor max-depth :index :any))
    (:metaclass persistent-class))
#<PERSISTENT-CLASS NODE>
> (finalize-inheritance *)
NIL
> (class-direct-slots **)
(#<INDEXED-DIRECT-SLOT-DEFINITION NAME @ #x10000f09e72>
 #<STANDARD-DIRECT-SLOT-DEFINITION CHILDREN @ #x10000f0f1a2>
 #<INDEXED-DIRECT-SLOT-DEFINITION MAX-DEPTH @ #x10000f123b2>)
> (class-slots ***)
(#<STANDARD-EFFECTIVE-SLOT-DEFINITION DB-OBJECT-OID @ #x10000b57902>
 #<STANDARD-EFFECTIVE-SLOT-DEFINITION DELETED-INSTANCE-P @ #x10000b57932>
 #<INDEX-ANY-UNIQUE-EFFECTIVE-SLOT-DEFINITION NAME @ #x10000b57962>
 #<STANDARD-EFFECTIVE-SLOT-DEFINITION CHILDREN @ #x10000b3d0d2>
 #<INDEX-ANY-EFFECTIVE-SLOT-DEFINITION MAX-DEPTH @ #x10000b57992>)

slot-makunbound-using-class and (setf slot-value-using-class)

ここ迄來れば、後は、 (SETF SLOT-VALUE)SLOT-MAKUNBOUND を定義して、 スロット値のインデクシングを制御する事ができれば、ほぼ出來上りです。

(SETF SLOT-VALUE) と SLOT-MAKUNBOUND からは各々、 (SETF SLOT-VALUE-USING-CLASS)SLOT-MAKUNBOUND-USING-CLASS が呼ばれる事が MOP で決まつていますので、これらを定義します。

SLOT-MAKUNBOUND-USING-CLASS ではハッシュテーブルから値を除いてやればよろしい。

(defmethod slot-makunbound-using-class ((class persistent-class)
                                        object
                                        (esd index-any-effective-slot-definition))
  (let ((slot-name (slot-definition-name esd))
        (hashtable (slot-definition-index esd)))
    (when (slot-boundp object slot-name)
      (let* ((old-value (slot-value object slot-name))
             (old-list (gethash old-value hashtable)))
        (setf (gethash old-value hashtable)
          (delete object old-list :key #'second :test #'equal)))))
  (call-next-method))

(defmethod slot-makunbound-using-class ((class persistent-class)
                                        object
                                        (esd index-any-unique-effective-slot-definition))
  (let ((slot-name (slot-definition-name esd))
        (hashtable (slot-definition-index esd)))
    (when (slot-boundp object slot-name)
      (let ((old-value (slot-value object slot-name)))
        (when (eq object (gethash old-value hashtable))
          (remhash old-value hashtable)))))
  (call-next-method))

(SETF SLOT-VALUE-USING-CLASS) では、一旦 slot-makunbound して、 新たな値をハッシュ登録した後、 setf するという戰略です。

(defmethod (setf slot-value-using-class) (value
                                          (class persistent-class)
                                          object
                                          (esd index-any-effective-slot-definition))
  (let ((slot-name (slot-definition-name esd))
        (hashtable (slot-definition-index esd)))
    (slot-makunbound object slot-name)
    (let ((new-list (gethash value hashtable)))
      (setf (gethash value hashtable)
        (cons (list value object) new-list))))
  (call-next-method))

(defmethod (setf slot-value-using-class) (value
                                          (class persistent-class)
                                          object
                                          (esd index-any-unique-effective-slot-definition))
  (let ((slot-name (slot-definition-name esd))
        (hashtable (slot-definition-index esd)))
    (slot-makunbound object slot-name)
    (unless (null (remhash value hashtable))
      (warn "Value ~A not unique." value))
    (setf (gethash value hashtable) object))
  (call-next-method))

retrieve-from-index

後は、検索函數である RETRIEVE-FROM-INDEX を定義してやれば、 先に擧げた AllegroCache Tutorial の例が動き始めます。 4

(defmethod retrieve-from-index ((class persistent-class) slot-name value &key (all nil) (oid nil))
  (let ((esd (find-if (lambda (esd)
                        (eq slot-name (slot-definition-name esd)))
                      (class-slots class))))
    (without-deleted-instance (oid)
      (retrieve-esd-from-index esd value :all all))))

(defmethod retrieve-from-index ((class symbol) slot-name value &key (all nil) (oid nil))
  (retrieve-from-index (find-class class) slot-name value :all all :oid oid))

(defmethod retrieve-esd-from-index ((esd index-any-unique-effective-slot-definition)
                                    value &key (all nil))
  (let* ((hashtable (slot-definition-index esd))
         (gethash (gethash value hashtable)))
    (if (null all)
        gethash
      (if (not (null gethash))
          (list gethash)
        nil))))

(defmethod retrieve-esd-from-index ((esd index-any-effective-slot-definition)
                                    value &key (all nil))
  (let* ((hashtable (slot-definition-index esd))
         (gethash (gethash value hashtable)))
    (if (null all)
        (second (first (remove-if #'deleted-instance-p gethash :key #'second)))
      (mapcar #'second gethash))))

doclass

最後に DOCLASS を定義しておきます。

(defmacro doclass ((var class-expr) &body body)
  (let ((class (gensym))
        (class-object (gensym))
        (instances (gensym)))
    `(let* ((,class ,class-expr)
            (,class-object (if (symbolp ,class) (find-class ,class) ,class))
            (,instances (remove-if #'(lambda (instance)
                                       (or (null instance)
                                           (deleted-instance-p instance)))
                                   (class-instances ,class-object))))
       (dolist (,var ,instances) ,@body))))

Database

以上、ここに紹介したソースだけでは、 肝心の永續化する部分が全く拔けており、データベースとしては、 何の役にも立ちませんが、 CLOS MOP の面白いところだけは紹介できたと思いますので、 あとは github に置いてあるソースで遊んでみて下さい。

Footnotes:

1 AllegroCache Tutorial からの追加定義 1

(defmethod print-object ((node node) stream)
 (format stream "#<node ~s max-depth: ~s>"
                (name node) (max-depth node)))

2 AllegroCache Tutorial からの追加定義 2

(defun compute-max-depth (node)
  (let ((max 0))
    (dolist (child (children node))
      (setq max (max max (compute-max-depth child))))
    (setf (max-depth node) (1+ max))))

3 DELETE-INSTANCE の定義

(defmethod delete-instance ((instance persistent-standard-object))
  (setf (deleted-instance-p instance) t)
  instance)

4 マクロ追加定義

(defmacro without-deleted-instance ((&optional oidp) body)
  (let ((oid (gensym))
        (obj (gensym)))
    `(let ((,obj ,body)
           (,oid ,oidp))
       (setq ,obj
         (if (listp ,obj)
             (remove-if #'deleted-instance-p ,obj)
           (if (deleted-instance-p ,obj)
               nil
             ,obj)))
       (if (null ,oid)
           ,obj
         (if (listp ,obj)
             (mapcar #'db-object-oid ,obj)
           (db-object-oid ,obj))))))

Author: 数理システム知識工學部

Date: 2014-04-24 11:45:01 JST

Generated by Org version 7.8.11 with Emacs version 24

© Mathematical Systems Inc. 2014