#:g1: 超螺旋なMOP

Posted 2021-12-23 19:39:29 GMT

Lisp一人 Advent Calendar 2021 24日目の記事です。

MOPについて面白そうな文献がないかウェブを漁っていたら、面白そうな論文を見付けました。

Meta-Helixというのは、クラス⇔インスタンスの関係に加えて、implemented-ofというインスタンス⇔実装の中身、という関係を入れたことで関係が螺旋状になっているのに由来するようですが、一応論文の流れを解説すると、CLOS MOPとTiny CLOS MOPを検討し、これらが持つ問題をMeta-Helical MOPで解決しようというところです。
AvoidingConfusion in Metacircularityというタイトルですが、CLOS MOPの方ではslot-valueslot-value-using-classの定義を無限ループさせてしまうことはたまにあるので、確かにそうかなという気はします。
ただし、この論文ではCLOS MOPのそういう超循環的な構成はプログラムとしては理解しやすいという長所はあり、Tiny CLOSのように、スロットと実装のフィールドを分けるのは複雑さを増している、としています。

さて、では超螺旋なMOPだとどういった構成になるのかというと、上述のようにシンプルにオブジェクトにimplemented-ofという関係を付け加えただけです。

昨年、このブログでallocate-instance アドベントカレンダーというのを開催してみましたが、バッキングストレージを別のオブジェクトにするというのは何パタンか試していて、オブジェクトの一連のスロットが別のオブジェクトというパタンかと思います。

なお、Meta-Helixは、コンパイル時/実行時の両方での実現を視野に入れたMOPですが、この論文では説明の都合上実行時のMeta-Helical MOPについての解説が主です。

……ということで実行時超螺旋MOPを実現するメタクラスを下記のように書いてみました。
なお、コードを単純にするため、オブジェクトのスロットをいじるのに自作のライブラリを使っています。

;; https://github.com/g000001/slotted-objects
(ql:quickload '(closer-mop slotted-objects))

(defpackage "ee552d98-e6ee-53f5-98a6-09edb2b2b5ea" (:use c2cl slotted-objects))

(in-package "ee552d98-e6ee-53f5-98a6-09edb2b2b5ea")

(defclass meta-helix-class (slotted-class) ((implemented-by :initform (find-class 'standard-class) :accessor class-implemented-by :initarg :implemented-by)))

(defmethod validate-superclass ((c meta-helix-class) (s standard-class)) T)

(defclass meta-helix-object (slotted-object) () (:metaclass meta-helix-class))

(defgeneric implemented-by (object))

(defmethod implemented-by ((object meta-helix-object)) (instance-slots object))

(defmethod allocate-instance ((class meta-helix-class) &rest initargs) (allocate-slotted-instance (class-wrapper class) (make-instance (class-implemented-by class))))

(defmethod slot-value-using-class ((class meta-helix-class) instance (slotd slot-definition)) (slot-value-using-class (class-implemented-by class) (implemented-by instance) slotd))

(defmethod (setf slot-value-using-class) (value (class meta-helix-class) instance (slotd slot-definition)) (setf (slot-value-using-class (class-implemented-by class) (implemented-by instance) slotd) value))

#+lispworks (defmethod clos:process-a-class-option ((class meta-helix-class) (name (eql :implemented-by)) value) (unless (and value (null (cdr value))) (error "meta-helix-class :implemented-by must have a single value.")) `(,name ',(car value)))

#-lispworks (defmethod ensure-class-using-class :around ((class meta-helix-class) name &rest initargs &key (implemented-by nil implemented-by-p)) (if (and implemented-by-p (consp implemented-by)) (apply #'call-next-method class name :implemented-by (car implemented-by) initargs) (call-next-method)))

論文の例を試してみる

まず、xyのスロットを有するpointオブジェクトを考えます。

(defclass point ()
  (x y))

このオブジェクトにスロットアクセスの履歴を付けたい、という場合、履歴スロット含んだpoint*pointの実装オブジェクトとして定義します。
このオブジェクトは何等メタな細工はされていないstandard-objectのサブクラスオブジェクトです。

(defclass point* ()
  ((history :initform '())
   (x :initform 0)
   (y :initform 0)))

このpoint*を利用するようにpoint側を定義します。

(defclass history-class (meta-helix-class)
  ())

(defclass history-object () () (:metaclass history-class))

(defclass point (meta-helix-object) (x y) (:metaclass history-class) (:implemented-by point*))

論文のコード例に似せて、history-class/history-objectを定義しましたが、関係が捻れているので逆にわかり辛いかもしれません。
論文には:implemented-byの関係を記述する方法が記載されていないようですが、クラスのオプションで適当に指定することにしました。

そしてスロットのアクセス時にhistoryスロットに履歴を記録するようにします。

(defmethod slot-value-using-class ((class history-class) object (slotd slot-definition))
  (let* ((implemented-by (implemented-by object))
         (slot-name (slot-definition-name slotd)))
    (push `(slot-value ,slot-name)
          (slot-value implemented-by 'history))
    (slot-value implemented-by slot-name)))

(defmethod (setf slot-value-using-class) (value (class history-class) object (slotd slot-definition)) (let* ((implemented-by (implemented-by object)) (slot-name (slot-definition-name slotd))) (push `((setf slot-value) ,slot-name) (slot-value implemented-by 'history)) (setf (slot-value implemented-by slot-name) value)))

一見して判るようにimplemented-byでリダイレクトしているだけです。

これでこのように使えます。

(let ((point (make-instance 'point)))
  (setf (slot-value point 'x) 42)
  (slot-value point 'y)
  (slot-value point 'x)
  (slot-value (implemented-by point) 'history))((slot-value x) (slot-value y) ((setf slot-value) x)) 

コンパイル時超螺旋MOP

コンパイル時MOPというのは、基本的にコンパイル時にのみ存在するメタオブジェクトを操作してあれこれするものですが、implemented-byの関係は、Common Lispであれば、マクロやコンパイラマクロ等で、コンパイル時に展開してしまえそうです。
例えば、上記の例は、

(let ((point (make-instance 'point*)))
  (progn
    (push `((setf slot-value) x)
          (slot-value point 'history))
    (setf (slot-value point 'x) 42))
  (progn
    (push `(slot-value y)
          (slot-value point 'history))
    (slot-value point 'y))
  (progn
    (push `(slot-value x)
          (slot-value point 'history))
    (slot-value point 'x))
  (slot-value point 'history))((slot-value x) (slot-value y) ((setf slot-value) x)) 

という風に展開すれば良いことになります。

まとめ

Meta-Helixという名称は特に広まっていないようですが、実行時MOPとコンパイル時MOPを繋ぐような概念かなと思いました。
これまでこのブログでも<MOP vs マクロ>のようなことを書いてきましたが、implemented-ofの関係で整理できないか試してみたいところです。

関連


HTML generated by 3bmd in LispWorks 8.0.0

comments powered by Disqus