Scheme:MOP:InstancePool

Scheme:MOP:InstancePool

動機

あるクラス(およびその派生クラス)の全てのインスタンスのセットを保持しておきたい、 ということがよくある。例えば定義ファイルをパーズしてゆく最中にどんどん定義を 表すインスタンスを作っていって、後からまとめて処理したり検索したりするとか。 インスタンスを作るたびに明示的にレジストレーションしていってもいいんだが、 クラススロットを使って基底クラスのinitializeでレジストレーションするように すれば派生クラスでは何も考えなくてよい。

  (define-class <foo> ()
    ...
    (all-instances :allocation :class :init-value ())
    )
  
  (define-method initialize ((self <foo>) initargs)
    (next-method)
    (push! (slot-ref self 'all-instances) self)))

こうしとけば、(class-slot-ref <foo> 'all-instances) でいつでも全ての<foo> およびその派生クラスのインスタンスのリストが得られる。

あまりにたびたびこのパターンのコードを書いているので、 これは部品化すべきではないかと考えた。 (「プログラムにパターンを見付けたら、それはどこかがおかしいというサインだ… 十分な抽象化を行っていないということを意味する」 from 技術野郎の復讐)

サブクラシングによる方法

ストレートだが、うまく動かない方法。

  (define-class <instance-pool-mixin> ()
    (all-instances :allocation :class :init-value ()))
  (define-method initialize ((self <instance-pool-mixin>) initargs)
    (next-method)
    (push! (slot-ref self 'all-instances) self)))
  (define (get-all-instances class)
    (class-slot-ref class 'all-instances))
  
  (define-class <foo> (<instance-pool-mixin>)
    ...)

これだと、all-instancesは全ての<instance-pool-mixin>の派生クラスで 共有されてしまうので、instance poolを使いたいクラスツリーが複数ある 場合は困る。

  (define-class <instance-pool-mixin> ()
    (all-instances :allocation :each-subclass :init-value ()))

アロケーション:each-subclassを使うと、スロットall-instancesはサブクラス毎に 割り当てられるので、<instance-pool-mixin>を継承するクラスが複数あっても 別々にインスタンスのリストを持てる。ただしこれだと、<instance-pool-mixin> を継承したクラス<foo>から更に別のクラス<bar>を継承した場合、 <bar>は<bar>独自のリストを持ってしまう。<foo>を継承したクラス全ての インスタンスは一括管理したいのだ。

MOPによる方法(1)

やりたいことを整理する。<instance-pool-mixin>を直接継承しているクラスが 木の「根」となって、その派生クラスのインスタンスは全て「根」のもとに 記録される。しかし別の木を<instance-pool-mixin>から直接派生して作ったら、 そちらのインスタンスは別に管理される、ということだ。

ならば、クラスの定義ルーチン内で、そのクラスが直接<instance-pool-mixin>を 直接継承しているかどうかを調べて、その場合だけall-instancesスロットを 定義してやれば良い。

  (define-class <instance-pool-meta> (<class>)  ; メタクラス
    ())
  
  (define-class <instance-pool-mixin> ()        ; 基底クラスはスロット無し
    ()
    :metaclass <instance-pool-meta>)
  
  ;; MOPメソッド compute-slots は、クラスのdirect-supers, direct-slots
  ;; およびclass-precedence-listが計算された後で呼ばれ、そのクラスの
  ;; 持つべきスロットのリストを返すメソッド。ここではクラスが
  ;; <instance-pool-mixin>を直接継承している場合に、direct-slotsに 
  ;; all-instancesスロットの定義を追加してやる。
  (define-method compute-slots ((class <instance-pool-meta>))
    (when (memq <instance-pool-mixin> (class-direct-supers class))
      (push! (slot-ref class 'direct-slots)
             '(all-instances :allocation :class :init-value ())))
    ;; 実際の計算はシステムのcompute-slotsに任せる
    (next-method))
  
  (define-method initialize ((self <instance-pool-mixin>) initargs)
    (next-method)
    (push! (slot-ref self 'all-instances) self))
  
  (define-method get-all-instances ((class <instance-pool-meta>))
    (class-slot-ref class 'all-instances))

direct-slotsを副作用で変更してるのがちょっと気持悪いけど、 この通りちゃんと動く。

  gosh> (define-class <x> (<instance-pool-mixin>) ())  ;まずは<x>を直接派生
  <x>
  gosh> (make <x>)
  #<<x> 0x8119fe4>
  gosh> (make <x>)
  #<<x> 0x8119fdc>
  gosh> (get-all-instances <x>)         ; 全ての<x>のインスタンスがある
  (#<<x> 0x8119fdc> #<<x> 0x8119fe4>)
  gosh> (define-class <y> (<x>) ())     ; <y> を <x>から派生 
  <y>
  gosh> (make <y>)
  #<<y> 0x8119fc4>
  gosh> (make <y>)
  #<<y> 0x8119fbc>
  gosh> (get-all-instances <x>)         ; 全て <x>のインスタンスのリストに入る  
  (#<<y> 0x8119fbc> #<<y> 0x8119fc4> #<<x> 0x8119fdc> #<<x> 0x8119fe4>)
  gosh> (define-class <z> (<instance-pool-mixin>) ()) ;<z>を別のクラス木の根とする
  <z>
  gosh> (make <z>)
  #<<z> 0x8119fa4>
  gosh> (make <z>)
  #<<z> 0x8119f9c>
  gosh> (get-all-instances <z>)         ; こっちには<z>のインスタンスだけ
  (#<<z> 0x8119f9c> #<<z> 0x8119fa4>)
  gosh> (get-all-instances <x>)         ; <x>のリストは変化なし
  (#<<y> 0x8119fbc> #<<y> 0x8119fc4> #<<x> 0x8119fdc> #<<x> 0x8119fe4>)
  gosh> (get-all-instances <y>)         ; <y>のリストは<x>のリストと同じ
  (#<<y> 0x8119fbc> #<<y> 0x8119fc4> #<<x> 0x8119fdc> #<<x> 0x8119fe4>)

注:Gaucheのオブジェクトシステム、およびそれの元となったSTklosのシステムでは、 親クラスが何かのメタクラスのインスタンスである場合、派生したクラスも 自動的にそのメタクラスのインスタンスになる。Guileのオブジェクトシステムも STklosを元にしているので同じはず。一方、CLOSのMOPでは派生クラスのメタクラスは 明示的に指定しないとstandard-metaclassになったと思った。確か。 (確認しようかと思ったら "The Art of Metaobject Protocol" が荷物のどこかに埋もれてしまっているので 見付けられない)
--g000001: Common LispのデフォルトのメタクラスについてはANSI CLでstandard-classであると定められています:CLHS:defclass

気になる点

上記の方法で一応動くが、汎用的なライブラリとするには気になる点がいくつかある。

共に<instance-pool-mixin>を使ってる別々のクラス木から多重継承したらどうなる?

例えば、こんなふうになった場合。

  (define-class <a> (<instance-pool-mixin>) ...)
  (define-class <b> (<instance-pool-mixin>) ...)
  (define-class <c> (<a> <b>) ...)

クラス<c>のインスタンスは、クラス木<a>とクラス木<b>のどちらのリストに 追加されるべきか。

上の実装では、class precedence listで先に来ている<a>の方にしか追加されない。 直観的には<c>のインスタンスは<a>のインスタンスでもあり<b>のインスタンス でもあるのだから、両方のリストに追加されるべきだろう。

派生クラスが、all-instancesというスロットを自分で定義しちゃったらどうなる?

システムのcompute-slotsは、同名のスロットがあった場合は派生クラスに 近いほうの定義を優先するから、派生クラスから見えるall-instancesは 派生クラスのものになる。従ってそのクラスのインスタンスのinitializeメソッドは 派生クラスから見えるall-instancesの方に追加され、クラス木の根には 追加されない。

コンテキストによってインスタンスのリストを複数持ちたい時があるんじゃない?

例えばあるファイルを解析している期間に作られたインスタンスは まとめておきたいけど、ファイルを解析し終ったらそれは捨てちゃって また新しくリストを始めたいとか。

まあここまで来るとアプリケーションの構造にかかわって来るので、 インスタンスリストをクラス内に持つべきかどうかという議論になるが。 ファイル解析のコンテキストを表すクラス内に持つ方が自然かな。

MOPによる方法(2)

気になる点の最初の2つは要するに、インスタンスプールを参照するのに all-instancesという固定した名前を全クラスで使い回してるから問題になっているのだ とも言える。

インスタンスプールそのものはクロージャに隠蔽し、 かつ各クラスが自分の属するインスタンスプールのリストを持っておいてやれば良い。

  (use srfi-1)
  
  (define-class <instance-pool-meta> (<class>)
    ((instance-pool:pool  :accessor instance-pool-of :init-value #f)
     ;; - このクラスが<instance-pool-mixin>を直接継承している場合、
     ;;   プールを管理するクロージャを持つ。そうでない場合は#f
     (instance-pool:pools :accessor instance-pools-of)
     ;; - このクラスのインスタンスが属するべきプールを管理するクロージャのリスト
     ))
  
  (define-method instance-pool-of (obj) #f) ; fallback
  
  (define-class <instance-pool-mixin> ()
    ()
    :metaclass <instance-pool-meta>)
  
  ;; クラスのinitialize。クラスを作成する時に呼ばれる
  (define-method initialize ((class <instance-pool-meta>) initargs)
    (next-method)
    ;; クラスがpool mixinを直接継承している場合に限り、新たに
    ;; プールを管理するクロージャを作成する
    (when (memq <instance-pool-mixin> (class-direct-supers class))
      (set! (instance-pool-of class)
            (let ((pool '()))
              (lambda args
                (if (null? args)
                    pool
                    (push! pool (car args)))))))
    ;; 継承しているクラスからプールを取り出してリストにする
    (set! (instance-pools-of class)
          (filter-map instance-pool-of (class-precedence-list class)))
    )
  
  ;; インスタンスのinitialize
  (define-method initialize ((self <instance-pool-mixin>) initargs)
    (next-method)
    (for-each (lambda (pool) (pool self))
              (instance-pools-of (class-of self))))
  ;; プールを直接管理するクラス(pool mixinを直接継承しているクラス)ではなく、
  ;; 派生クラスに対してget-all-instancesが呼ばれた場合にどうするかは
  ;; 議論の余地があるが、ここではエラーとした。
  (define-method get-all-instances ((class <instance-pool-meta>))
    (cond ((instance-pool-of class)
           => (lambda (pool) (pool)))
          (else
           (errorf "class ~s is not a root of instance-pool class tree" class))))

クラスに対するinitializeとインスタンスに対するinitializeを混同しないように。 以下、動作例。

  gosh> (define-class <x> (<instance-pool-mixin>) ())
  <x>
  gosh> (instance-pool-of <x>)     ; <x>はプールを持つ
  #<closure 0x8169b40(args)>
  gosh> (instance-pools-of <x>)
  (#<closure 0x8169b40(args)>)
  gosh> (make <x>)
  #<<x> 0x8119fb8>
  gosh> (make <x>)
  #<<x> 0x8119fac>
  gosh> (get-all-instances <x>)    ; インスタンスが登録されている
  (#<<x> 0x8119fac> #<<x> 0x8119fb8>)
  gosh> (define-class <y> (<x>) ()); <y>を<x>から派生
  <y>
  gosh> (instance-pool-of <y>)     ; <y>はプールを持たない
  #f
  gosh> (instance-pools-of <y>)    ; <y>のインスタンスは<x>のプールに登録される
  (#<closure 0x8169b40(args)>)
  gosh> (make <y>)
  #<<y> 0x8119f74>
  gosh> (make <y>)
  #<<y> 0x8119f68>
  gosh> (get-all-instances <x>)    ; 御覧の通り。
  (#<<y> 0x8119f68> #<<y> 0x8119f74> #<<x> 0x8119fac> #<<x> 0x8119fb8>)
  gosh> (define-class <z> (<instance-pool-mixin>) ())
  <z>
  gosh> (instance-pool-of <z>)     ; <z>も自分のプールを持つ
  #<closure 0x81c3570(args)>
  gosh> (instance-pools-of <z>)
  (#<closure 0x81c3570(args)>)
  gosh> (make <z>)
  #<<z> 0x8119f34>
  gosh> (make <z>)
  #<<z> 0x8119f28>
  gosh> (get-all-instances <z>)
  (#<<z> 0x8119f28> #<<z> 0x8119f34>)
  gosh> (define-class <u> (<x> <z>) ()) ; <u>を<x>と<z>から派生
  <u>
  gosh> (instance-pool-of <u>)     ; <u> は自分のプールは持たないが…
  #f
  gosh> (instance-pools-of <u>)    ; …複数のプールに属することになる
  (#<closure 0x8169b40(args)> #<closure 0x81c3570(args)>)
  gosh> (make <u>)
  #<<u> 0x8119eec>
  gosh> (get-all-instances <x>)    ; <x>のプールにも…
  (#<<u> 0x8119eec> #<<y> 0x8119f68> #<<y> 0x8119f74> #<<x> 0x8119fac> #<<x> 0x8119fb8>)
  gosh> (get-all-instances <z>)    ; <z>のプールにも。
  (#<<u> 0x8119eec> #<<z> 0x8119f28> #<<z> 0x8119f34>)

インスタンスプールのクロージャが保持されているスロットは、 アプリケーションのクラス<x>や<z>そのものに定義されているのではなく、 (class-of <x>)や(class-of <z>) に定義されている。 別の言い方をすれば、「MOPによる方法(1)」では<x>や<z>のインスタンスから インスタンスリストを保持するスロットが見えたが、 この方法では<x>や<z>のインスタンスからinstance-pool:pool等のスロットは 直接は見えない。 したがって、アプリケーションの方でうっかり同名のスロットを定義してしまう 危険はかなり少なくなる。

もちろん、アプリケーションのクラスのメタクラスがメタクラスを多重継承するような ことをする場合は、メタクラス同士でのスロット名の衝突の可能性はある。 わざと変なスロット名にしてあるのはそのためだ。 まあ、メタクラスを多重継承するような使い方はかなりレアであるし、 そういうベースクラスを設計する人は各メタクラスのプロトコルは十分に 調べるだろうから、それほど問題にはならないと思う。

MOPによる拡張

「MOPによる方法(2)」では、インスタンスプールの実装そのものは クラスのinitializeルーチンの中にハードコードされてしまっている。 だがそれらをメソッドにしてやれば、アプリケーションがインスタンスプールの 実装をカスタマイズできるようになる。

  (define-method instance-pool-create-pool ((class <instance-pool-meta>))
    (let ((pool '()))
      (lambda args
        (if (null? args)
            pool
            (push! pool (car args))))))
  
  (define-method instance-pool-compute-pools ((class <instance-pool-meta>))
    (filter-map instance-pool-of (class-precedence-list class)))
  
  (define-method initialize ((class <instance-pool-meta>) initargs)
    (next-method)
    (when (memq <instance-pool-mixin> (class-direct-supers class))
      (set! (instance-pool-of class)
            (instance-pool-create-pool class)))
    (set! (instance-pools-of class)
          (instance-pool-compute-pools class))
    )

メソッドinstance-pool-create-poolは、直接<instance-pool-mixin>を継承する クラスが作られる時に呼ばれ、プールを管理するクロージャを返す。 メソッドinstance-pool-compute-poolsは、<instance-pool-mixin>の派生クラス が作られる時に呼ばれ、そのクラスが属すべきインスタンスプールのリストを 作って返すメソッド。

これらのメソッドをオーバライドすれば、例えば「コンテキスト毎に インスタンスプールを切替えるクラス」みたいなのが作れる。

Tag: gauche.mop.instance-pool


Last modified : 2021/01/01 22:32:17 UTC