#:g1

痕跡を残さないS式コメント

Posted 2019-12-21 18:10:57 GMT

コメントをS式で書く方式のcommentは、古くはMACLISPに、最近だとClojureにありますが、中身を無視してnil(MACLISPだと'comment)を返すシンプルなフォームです。

(comment 0 1 2)
→ nil

commentの中身もS式として成立していないといけないのですが、動いているコードをコメントアウトする分には大抵問題になることはないでしょう。

Common Lispで書くとするとこんな感じになります。

(defmacro comment (&body body)
  (declare (ignore body))
  nil)

S式コメントには一つ問題があり、nil等の値を残してしまうので、commentを残す場所には配慮する必要があります。

(vector (list 42))
→ #((42)) 

(vector (comment (list 42))) → #(nil)

ここで一捻りして、nilではなく(values)を置いてみるとどうでしょうか。

(defmacro comment (&body body)
  (declare (ignore body))
  '(values))

(values)は0個の返り値を返しますが、Common Lispの場合は値が評価される場所ではnilとなります。
つまり、nilと書いた場合と大差ないのですが、

(vector (comment (list 42)))
→ #(nil) 

#.を付けると、痕跡を消すことができます。

(vector #.(comment (list 42)))
→ #() 

リーダーマクロの書法の一つとして、値を出力したくない場合は、(values)を使うというのがあるのですが、これを利用した格好です。

まとめ

#.(comment ...)だとちょっと長いので、普段は、(comment ...)で書き、必要になったら#.を足す、という使い方をすれば、そこそこ便利に使えるかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

MOPでSoA

Posted 2019-12-17 17:58:29 GMT

構造体の配列を作成する方法として、

  • 構造体を配列に配置する(AoS: Array of Structures)
  • 配列の構造体を作る(SoA: Structure of Arrays)

があるようですが、SoAの方が効率が良いらしいです。

Common Lispでいうと、インスタンスの配列を作成するか、インスタンスのスロットを配列にするかになりますが、MOP細工でインスタンスのスロットは配列にはせずに通常のままでSoAな構成にしてみよう、というのが今回の趣旨です。

  • クラスメタオブジェクトにインスタンスのスロットを配列として保持し、
  • allocate-instanceでスロットの配列に配置。
  • インデックスはインスタンスのデータ部が空き地なのでここに格納

といった風に構成してみました。
LispWorks依存ですが、standard-objectの構造はメジャーどころは大体一緒なので移植は簡単だと思います。

動作

(defclass 🐱 (soa-object)
  ((a :initform 0 :type bit :initarg :a)
   (b :initform #\. :type character :initarg :b)
   (c :initform nil :type boolean :initarg :c))
  (:metaclass soa-class)
  (:pool-size 0))

(instance# (class-prototype (find-class '🐱))) → 0

(class-slot-vectors (find-class '🐱))((a . #*) (b . "") (c . #()))

(set '🐱 (make-instance '🐱 :a 0 :b #\- :c T)) → #<🐱 40201E2BFB>

(mapcar (lambda (s) (cons (car s) (elt (cdr s) (instance# 🐱)))) (class-slot-vectors (find-class '🐱)))((a . 0) (b . #\-) (c . t))

(dotimes (i 100) (make-instance '🐱 :a 1 :b #\. :c nil)) → nil

(class-slot-vectors (find-class '🐱))((a . #*001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111) (b . "^@-....................................................................................................") (c . #(nil t nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)))

(with-slots (a b c) (make-instance '🐱 :a 1 :b #\. :c nil) (list a b c))(1 #\. nil)

実装

堅牢性に難ありですが、概念実証くらいにはなるかなというところです。

(defpackage "e477e14c-8275-5c00-82d3-82f8adcd1567"
  (:use :c2cl))

(in-package "e477e14c-8275-5c00-82d3-82f8adcd1567")

(defclass soa-class (standard-class) ((pool-size :initform 256 :accessor instance-pool-size :initarg :pool-size) (instance-index :initform 0 :accessor instance-index) (slot-vectors :initform nil :accessor class-slot-vectors)))

(defmethod validate-superclass ((c soa-class) (s standard-class)) T)

(defclass soa-object () () (:metaclass Soa-class))

(defun instance# (soa-object) (clos::%svref Soa-object 1))

(defmethod allocate-instance ((class soa-class) &rest initargs) (let* ((class (clos::ensure-class-finalized class))) (prog1 (sys:alloc-fix-instance (clos::class-wrapper class) (instance-index class)) (incf (instance-index class)))))

(defmethod shared-initialize ((instance soa-object) slot-names &rest initargs) (flet ((initialize-slot-from-initarg (class instance slotd) (let ((slot-initargs (slot-definition-initargs slotd)) (name (slot-definition-name slotd))) (loop :for (initarg value) :on initargs :by #'cddr :do (when (member initarg slot-initargs) (setf (slot-value-using-class class instance name) value) (return t))))) (initialize-slot-from-initfunction (class instance slotd) (let ((initfun (slot-definition-initfunction slotd)) (name (slot-definition-name slotd))) (unless (not initfun) (setf (slot-value-using-class class instance name) (funcall initfun)))))) (let ((class (class-of instance))) (dolist (slotd (class-slots class)) (unless (initialize-slot-from-initarg class instance slotd) (when (or (eq t slot-names) (member (slot-definition-name slotd) slot-names)) (initialize-slot-from-initfunction class instance slotd))))) instance))

(defun soa-instance-access (class obj key) (elt (cdr (assoc key (class-slot-vectors class))) (instance# obj)))

(defun (setf soa-instance-access) (val class obj key) (when (> (instance# obj) (1- (instance-pool-size class))) (setf (instance-pool-size class) (1+ (instance# obj))) (dolist (slot (class-slot-vectors class)) (adjust-array (cdr slot) (instance-pool-size class)))) (setf (elt (cdr (assoc key (class-slot-vectors class))) (instance# obj)) val))

(defmethod slot-value-using-class ((c Soa-class) inst slot-name) (soa-instance-access c inst slot-name))

(defmethod (setf slot-value-using-class) (newvalue (c Soa-class) inst slot-name) (setf (soa-instance-access c inst slot-name) newvalue))

(defmethod ensure-class-using-class :after ((class soa-class) name &rest initargs &key) (when (consp (instance-pool-size class)) (setf (instance-pool-size class) (car (instance-pool-size class)))) (setf (class-slot-vectors class) (mapcar (lambda (s) (cons (slot-definition-name s) (make-array (instance-pool-size class) :element-type (or (slot-definition-type s) T) :adjustable T :initial-element (funcall (slot-definition-initfunction s))))) (class-slots class))))

まとめ

Common LispはC風に効率よく構造体を配列に詰められないのか、等々の質問はたまにみかけるのですが、今回のように高次のデータ構造的に記述して低次のデータ構造にマッピングする方法もなくはないかなとは思います。
直截的な回答としてはFFIでメモリの塊をいじる方法などになりそうですが。


HTML generated by 3bmd in LispWorks 7.0.0

Allegro CLのfixed-indexスロット再現リベンジ

Posted 2019-12-11 17:12:32 GMT

先日書いたAllegro CLのfixed-indexスロットアクセスを真似してみるの記事では、任意の値でslot-definition-loctionを確定させる術を分かっていなかったので、中途半端なことになっていました。
compute-slots :aroundを使った確定方法が分かったのでリベンジします。

動作

(<defclass> foo ()
  ((a :initarg :a fixed-index 2 :accessor foo-a)
   (b :initarg :b fixed-index 4 :accessor foo-b)
   (c :initarg :c :accessor foo-c))
  (:metaclass fixed-index-slot-class))

(mapcar (lambda (s) (list (slot-definition-name s) (slot-definition-location s))) (class-slots <foo>))((c 0) (a 2) (b 4))

(let ((foo (a 'foo))) (setf (foo-a foo) 'a) (setf (foo-b foo) 'b) (setf (foo-c foo) 'c) (std-instance-slots foo)) → #(c #<Slot Unbound Marker> a #<Slot Unbound Marker> b)

実装について

  • インデックスが指定されていないスロットは、先頭から空いている番地に差し込みます。
  • slot-value-using-classがいつものごとくLispWorks依存です(AMOP準拠でない) なおかつ遅そうです。

実装

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop))

(defpackage "506dccfc-1d3a-5b8c-9203-948447c433b4" (:use :c2cl))

(in-package "506dccfc-1d3a-5b8c-9203-948447c433b4")

;; utils (eval-when (:compile-toplevel :load-toplevel :execute) (setf (fdefinition 'a) #'make-instance) (defun fintern (package control-string &rest args) (with-standard-io-syntax (intern (apply #'format nil control-string args) (or package *package*)))) (defmacro <defclass> (name supers slots &rest class-options) `(defconstant ,(fintern (symbol-package name) "<~A>" name) (defclass ,name ,supers ,slots ,@class-options))))

(<defclass> fixed-index-slot-class (standard-class) ())

(defmethod validate-superclass ((c fixed-index-slot-class) (s standard-class)) T)

(<defclass> fixed-index-slot-definition (standard-slot-definition) ((fixed-index :initform nil :initarg fixed-index :accessor slot-definition-fixed-index)))

(<defclass> fixed-index-direct-slot-definition (fixed-index-slot-definition standard-direct-slot-definition) ())

(<defclass> fixed-index-effective-slot-definition (fixed-index-slot-definition standard-effective-slot-definition) ())

(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs) (declare (ignore initargs)) <fixed-index-direct-slot-definition>)

(defmethod effective-slot-definition-class ((c fixed-index-slot-class) &rest initargs) (declare (ignore initargs)) <fixed-index-effective-slot-definition>)

(defmethod compute-effective-slot-definition ((class fixed-index-slot-class) name direct-slot-definitions) (declare (ignore name)) (let ((effective-slotd (call-next-method))) (dolist (slotd direct-slot-definitions) (when (typep slotd <fixed-index-slot-definition>) #-allegro (setf (slot-definition-fixed-index effective-slotd) (slot-definition-fixed-index slotd)) #+allegro (setf (slot-value effective-slotd 'excl::location) (slot-definition-fixed-index slotd)) (return))) effective-slotd))

(defmethod allocate-instance ((class fixed-index-slot-class) &rest initargs) (let* ((class (clos::ensure-class-finalized class)) (slotds (class-slots class)) (max-index (loop :for s :in slotds :maximize (slot-definition-location s)))) (sys:alloc-fix-instance (clos::class-wrapper class) (sys:alloc-g-vector$fixnum (1+ max-index) clos::*slot-unbound*))))

(defmethod compute-slots :around ((class fixed-index-slot-class)) (let* ((slotds (call-next-method)) (indecies (mapcan (lambda (s) (and (slot-definition-fixed-index s) (list (slot-definition-fixed-index s)))) slotds)) (free-indecies (loop :for i :from 0 :to (apply #'max indecies) :unless (find i indecies) :collect i))) (dolist (s slotds) (if (slot-definition-fixed-index s) (setf (slot-definition-location s) (slot-definition-fixed-index s)) (setf (slot-definition-location s) (pop free-indecies)))) (sort (copy-list slotds) #'< :key #'slot-definition-location)))

(defun standard-instance-boundp (instance index) (not (eq clos::*slot-unbound* (standard-instance-access instance index))))

(defmethod slot-value-using-class ((class fixed-index-slot-class) instance slot-name) (let* ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)) (loc (slot-definition-location slotd))) (cond ((not slotd) (slot-missing class instance slot-name 'slot-makunbound)) ((null (standard-instance-boundp instance loc)) (slot-unbound class instance slot-name)) (T (standard-instance-access instance loc)))))

(defmethod (setf slot-value-using-class) (val (class fixed-index-slot-class) instance slot-name) (let* ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)) (loc (slot-definition-location slotd))) (if (not slotd) (slot-missing class instance slot-name 'slot-makunbound) (setf (standard-instance-access instance loc) val))))

(declaim (inline std-instance-slots)) (defun std-instance-slots (inst) #+allegro (excl::std-instance-slots inst) #+sbcl (sb-pcl::std-instance-slots inst) #+lispworks (clos::standard-instance-static-slots inst))

まとめ

インスタンスのスロットをベクタ上に任意に配置したり、ハッシュテーブルにしてみたり、ということができることは分かりましたが、標準から逸れたことをすると、どうもスロットのアクセス周りを全部書かないといけないっぽいですね。


HTML generated by 3bmd in LispWorks 7.0.0

MOPで隠しスロットの実現

Posted 2019-12-09 19:26:03 GMT

ここ最近、standard-instance-accessでインスタンス内部のベクタに直接アクセスするようなことを試していましたが、インデックスを求める方法があやふやでした。
compute-slotsで並んだ順で確定するのは分かっていたのですが、並び順ということは飛び飛びにはできないわけで、どうしたものかと考えていましたが、compute-slotsの説明を良く読んだら、compute-slotsのプライマリメソッドでスロット定義を並べて、compute-slots:aroundメソッドでslot-definition-locationの内容を確定するようなことが書いてあります。

In the final step, the location for each effective slot definition is
set. This is done by specified around-methods; portable methods cannot
take over this behavior. For more information on the slot definition
locations, see the section ``Instance Structure Protocol.''

ということでSBCLのMOP実装を確認してみましたが、やはり:aroundlocationを設定していました。なるほど。

compute-slots:aroundを乗っ取るには、さらなる:aroundを定義するしかないわけですが、どうも可搬性のためにはいじってはいけない場所のようです。

とはいえ、インデックスの設定方法が分かったので、試しに今回は、X3J13-88-003R-DRAFTのコード例にあるfaceted-slot-classを動かしてみたいと思います。

faceted-slot-class

X3J13-88-003Rのドラフトにはindex-in-instanceというAPIが存在していて、スロット名からインデックスを算出する仕組みになっていたようです。

このindex-in-instanceの利用例として、0、2、4…をスロット、1、3、5…をファセットとして配置するメタクラスを定義しています。

動作は下記のようになります。

(defclass zot ()
  ((a :initform 42)
   (b :initform 43)
   (c :initform 44))
  (:metaclass faceted-slot-class))

(let ((o (make-instance 'zot))) (values (with-slots (a b c) o (list a b c)) (loop :for index :from 0 :repeat (compute-instance-size (class-of o)) :collect (standard-instance-access o index))))(42 43 44) (42 #<Slot Unbound Marker> 43 #<Slot Unbound Marker> 44 #<Slot Unbound Marker>)

;;; ファセットに値を設定 (let ((o (make-instance 'zot))) (setf (slot-facet o 'a) 'facet-a) (setf (slot-facet o 'b) 'facet-b) (setf (slot-facet o 'c) 'facet-c) (values (with-slots (a b c) o (list a b c)) (loop :for index :from 0 :repeat (compute-instance-size (class-of o)) :collect (standard-instance-access o index))))(42 43 44) (42 facet-a 43 facet-b 44 facet-c)

実装

ということで実装ですが、元のコードのAPIをできるだけ残したかったのですが、どうもコンセプトコードのようで実際に動かすと色々矛盾がある様子。
その辺りは適当に辻褄を合せました。
しかし、辻褄が合わないところもあり、

  • compute-slotの中でindex-in-instanceを使って綺麗にカスタマイズしたいが、index-in-instanceが使うスロット情報は遡ればcompute-slotを利用するので循環が発生する

等は、index-in-instanceの内容をcompute-slotの中にベタ書きで展開することで回避しています。

以下、LispWorks依存なコードです。
LispWorks標準のslot-value-using-classは、スロットのインデックスが隙間無く並んでいることを前提としていて、疎な配置にすると動作がおかしくなるので、自前で定義しています。

(ql:quickload :closer-mop)

(defpackage "2f1cccc9-c776-5726-9e68-91d2d9042169" (:use :c2cl))

(in-package "2f1cccc9-c776-5726-9e68-91d2d9042169")

(defgeneric index-in-instance (class description))

(defmethod index-in-instance ((class cl:standard-class) description) (typecase description (symbol (position description (class-slots class) :key #'slot-definition-name)) (T (error "Don't understand the description ~S." description))))

(defgeneric compute-instance-size (class))

(defmethod compute-instance-size ((class cl:standard-class)) (length (class-slots class)))

(defclass faceted-slot-class (standard-class) ())

(defmethod validate-superclass ((c faceted-slot-class) (s standard-class)) T)

(defmethod compute-instance-size ((class faceted-slot-class)) (* 2 (call-next-method)))

(defmethod allocate-instance ((class faceted-slot-class) &rest initargs) (let ((class (clos::ensure-class-finalized class))) (sys:alloc-fix-instance (clos::class-wrapper class) (sys:alloc-g-vector$fixnum (compute-instance-size class) clos::*slot-unbound*))))

(defmethod index-in-instance ((class faceted-slot-class) description) (cond ((symbolp description) (let ((index (call-next-method))) (and index (* 2 index)))) ((and (consp description) (eq (car description) 'facet)) (1+ (index-in-instance class (cadr description)))) (T (error "Don't understand the description ~S." description))))

(defun standard-instance-access* (instance description trap not-bound-function missing-function) (declare (ignore trap)) (let* ((class (class-of instance)) (index (index-in-instance class description))) (cond ((null index) (funcall missing-function instance description)) ((not (numberp index)) (slot-value index 'value)) ((null (standard-instance-boundp instance index)) (funcall not-bound-function instance description)) (T (standard-instance-access instance index)))))

(defun (setf standard-instance-access*) (val instance description trap not-bound-function missing-function) (declare (ignore trap not-bound-function)) (let* ((class (class-of instance)) (index (index-in-instance class description))) (cond ((null index) (funcall missing-function instance description)) ((not (numberp index)) (slot-value index 'value)) (T (setf (standard-instance-access instance index) val)))))

(defun standard-instance-boundp (instance index) (not (eq clos::*slot-unbound* (standard-instance-access instance index))))

(defun slot-facet (instance slot-name) (standard-instance-access* instance (list 'facet slot-name) nil #'facet-unbound #'facet-missing))

(defun (setf slot-facet) (new-value instance slot-name) (setf (standard-instance-access* instance (list 'facet slot-name) nil #'facet-unbound #'facet-missing) new-value))

(defun facet-unbound (instance facet) (error "The facet ~S is unbound in the object ~S" (cadr facet) instance))

(defun facet-missing (instance facet) (error "The facet ~S is missing from the object ~S" (cadr facet) instance))

(defmethod compute-slots :around ((class faceted-slot-class)) (let ((slotds (call-next-method))) (dolist (s slotds) ;; Base case (setf (slot-definition-location s) (* 2 (position s slotds)))) slotds))

(defmethod slot-value-using-class ((class faceted-slot-class) instance slot-name) (let ((index (index-in-instance class slot-name))) (cond ((null index) (slot-missing class instance slot-name 'slot-makunbound)) ((not (numberp index)) (slot-value index 'value)) ((null (standard-instance-boundp instance index)) (slot-unbound class instance slot-name)) (T (standard-instance-access instance index)))))

まとめ

index-in-instanceは、class-slotsslot-definition-nameslot-definition-locationの組み合わせとも大差ないともいえますが、index-in-instanceの方がスロット名とインデックスの関係が明確になる上にカスタマイズしやすそうな気もします。
今回の例では、index-in-instanceを呼びまくっていますが、ちょっと遅そうなので、クラスにインデックスを保持させる方が良いかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

文字列中にダブルクォートが頻出してエスケープが面倒な時はシンボルで記述して変換

Posted 2019-12-08 19:31:12 GMT

表題の通りなのですが、Clozure CLのマニュアルのソースを眺めていて、こんな記述をみつけました。

  • doc/manual/implementation.ccldoc

(item "r13 is used to hold the TCR on PPC32 systems; it's not used on PPC64."))
(item #:|r14 (symbolic name loc-pc) is used to copy "pc-locative" values between main memory and special-purpose PPC registers (LR and CTR) used intern function-call and return instructions.|)

一応解説すると、マニュアルは文字列のリストで記述されていて、文字列の表記には文字列でもシンボルでも使えるようにしてあるので、ダブルクォートのエスケープが面倒な時にはシンボルで記述する(上記の例ではインターンを嫌ってか自由シンボル)ということです。

上記の例ではマクロ展開時の処理ですが、実行時ならば、

(string '|"""foo "bar" baz"""|)
→ "\"\"\"foo \"bar\" baz\"\"\"" 

となり、リード時処理なら文字列を直に書いているのと同一です。

#.(string '|"""foo "bar" baz"""|)
≡ "\"\"\"foo \"bar\" baz\"\"\"" 

個人的には以前から思い付きでやっていたことなのですが、自分以外にもこんなことしている人をみつけた記念に記事にしてみました。


HTML generated by 3bmd in LispWorks 7.0.0

ECLOSのself-referent-classを再現してみる

Posted 2019-12-04 20:14:19 GMT

最近はECLOSを再現して遊んでいますが、今回は、self-referent-classというメタクラスを再現してみます。

なお、self-referent-classについては、ECLOSの論文に詳しいので参照してください。

挙動を確認してみる

説明はあるとはいえ、マニュアルや仕様書ではないので、実際実装してみようとすると良くわからないところはありますが、インスタンスの初期化時に他のスロットを参照できること=自己参照、ということのようです。 論文の解説によれば、大体下記のような挙動になります。

  • 初期化時に自己のインスタンスをselfという変数で参照可能
  • (slot-name self)という形式で自身の式より左側のスロットを参照可能

    • しかしこれがcreatorparentの機能なのか判然としない

(defclass horizontal-line (self-referent-object)
  ((x1 :accessor x1 :initarg :x1 :type real)
   (x2 :accessor x2 :initarg :x2 :type real)
   (y :accessor y :initarg :y :type real)
   (point1 :initform (make-point (x1 self)
                                 (y self)))
   (point2 :initform (make-point (x2 self)
                                 (y self))))
  (:metaclass self-referent-class))

(set' obj (make-instance 'horizontal-line :x1 1 :x2 2 :y 3))

(slot-value obj 'x1) → 1 (slot-value obj 'x2) → 2

(slot-value obj 'point1)(1 3)

(slot-value obj 'point2)(2 3)

実装のヒント

論文にはCommon LispのMOPについて問題点が何点も指摘されていますが、スロット定義のinitfunctionが引数を取らないことも指摘しています。
この指摘の中で、この問題を回避するためにスペシャル変数経由で渡していると書いてあるのですが、だとすると、shared-initializeの中のスロット初期化関数にスペシャル変数経由でselfを渡しているのでしょう。

shared-initialize:aroundを使ってスペシャル変数の囲いはこんな風に書けるでしょう。

(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs)
  (let ((*self-referent-object-self* instance))
    (declare (special *self-referent-object-self*))
    (call-next-method)))

あとは、initfunction

(lambda (&aux (self *self-referent-object-self*)) 
  (declare (special *self-referent-object-self*))
  ...)

のようなものに差し替えればOKです。

(slot-name self)のような形式は、スロット名の局所関数を作成し、ensure-class-using-classの周りに展開されるようにすれば良さそうです。

以上で、想像される展開は下記のようになります。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (flet ((x1 (self) (slot-value self 'x1))
         (x2 (self) (slot-value self 'x2))
         (y (self) (slot-value self 'y))
         (point1 (self) (slot-value self 'point1))
         (point2 (self) (slot-value self 'point2)))
    (def:def (lisp:defclass horizontal-line)
      (clos::ensure-class-without-lod 'horizontal-line
                                      :metaclass
                                      'self-referent-class
                                      :direct-slots
                                      (list (list :name 'x1
                                                  :readers '(x1)
                                                  :writers '((setf x1))
                                                  :initargs '(:x1)
                                                  :type 'real)
                                            (list :name 'x2
                                                  :readers '(x2)
                                                  :writers '((setf x2))
                                                  :initargs '(:x2)
                                                  :type 'real)
                                            (list :name 'y
                                                  :readers '(y)
                                                  :writers '((setf y))
                                                  :initargs '(:y)
                                                  :type 'real)
                                            (list :name 'point1
                                                  :initform
                                                  '(make-point (x1 self) (y self))
                                                  :initfunction
                                                  #'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
                                                      (declare (special zreclos.meta::*self-referent-object-self*))
                                                      (make-point (x1 self) (y self))))
                                            (list :name 'point2
                                                  :initform
                                                  '(make-point (x2 self) (y self))
                                                  :initfunction
                                                  #'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
                                                      (declare (special zreclos.meta::*self-referent-object-self*))
                                                      (make-point (x2 self) (y self)))))
                                      :direct-superclasses '(self-referent-object)
                                      :location
                                      (def:location)))))

実装してみる

defclassがメタクラスに応じて任意の展開にディスパッチされると便利なのですが、LispWorksだとexpand-defclassというのがあるので、ここに展開メソッドを追加してやることでdefclassの兄弟マクロを定義せずに済みました。

このexpand-defclassですが、X3J13-88-003Rにあるのと同じ大体同じインターフェイスです。

他にもスロットのオプションの展開等にもLispWorksには便利なメソッドがあるので使ってみました(非公開APIですが) ちなみに、これらはclass-prototypeをディスパッチに利用するのですが、昔からこういう使い方は或る種の定番だったようです。

などなどですが、ベタベタにLispWorks依存になっています。

(defclass self-referent-class (standard-class)
  ()
  (:metaclass standard-class))

(defmethod validate-superclass ((c self-referent-class) (s standard-class)) T)

(defun make-creator-function-form (slot-form) (let ((name (car slot-form))) `(,name (self) (slot-value self ',name))))

(defmethod clos::expand-defclass ((prototype self-referent-class) metaclass name superclasses slots class-options) (destructuring-bind (eval-when opts &body body) (call-next-method) `(,eval-when ,opts (flet (,@(mapcar #'make-creator-function-form slots)) ,@body))))

(defclass self-referent-object (standard-object) () (:metaclass self-referent-class))

(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs) (let ((*self-referent-object-self* instance)) (declare (special *self-referent-object-self*)) (call-next-method)))

;; from alexandria (defun flatten (tree) "Traverses the tree in order, collecting non-null leaves into a list." (let (list) (labels ((traverse (subtree) (when subtree (if (consp subtree) (progn (traverse (car subtree)) (traverse (cdr subtree))) (push subtree list))))) (traverse tree)) (nreverse list)))

(defun non-trivial-initform-initfunction-p (initform) #+lispworks7.1 (loop :for (name ntifif) :on (flatten initform) :thereis (and (eq 'hcl:lambda-name name) (eq 'clos::non-trivial-initform-initfunction ntifif))) #+lispworks7.0 (let ((x initform)) (and (consp x) (eq 'function (car x)) (eq 'lambda (caadr x)))))

(defgeneric make-sr-class-initfunction-form (class ifform))

(defmethod make-sr-class-initfunction-form ((class self-referent-class) ifform) (if (non-trivial-initform-initfunction-p ifform) (destructuring-bind (function (lambda arg &body body)) ifform (declare (ignore arg)) `(,function (,lambda (&aux (self *self-referent-object-self*)) (declare (special *self-referent-object-self*)) ,@body))) ifform))

(defmethod clos::canonicalize-defclass-slot ((prototype self-referent-class) slot) (let* ((plist (copy-list (cdr (call-next-method)))) (ifform (getf plist :initfunction))) (if (getf plist :initform) (progn (remf plist :initfunction) `(list ,@plist :initfunction ,(make-sr-class-initfunction-form prototype ifform))) (progn `(list ,@plist)))))

まとめ

expand-defclassは便利なのでLispWorks限らず他でも使いたいところですが、このあたりは統一されてないんですよねえ。


HTML generated by 3bmd in LispWorks 7.0.0

SBCLにcaseのジャンプテーブル最適化が入ったので試してみる

Posted 2019-11-27 20:02:15 GMT

昨日リリースされたSBCL 1.5.9にcaseのジャンプテーブル最適化が入ったようなので早速どんなものか試してみたいと思います。

とりあえず若干わざとらしいものを試してみます。
caseのキーに0から511までの数値をシャッフルしたものを指定して分岐し、さらに二段目のcaseで元に戻すのを5回繰り返すのを1000繰り返してみます。

(defconstant nbranch 512)

;; alexandria (defun shuffle (sequence &key (start 0) end) "Returns a random permutation of SEQUENCE bounded by START and END. Original sequece may be destructively modified, and share storage with the original one. Signals an error if SEQUENCE is not a proper sequence." (declare (type fixnum start) (type (or fixnum null) end)) (etypecase sequence (list (let* ((end (or end (length sequence))) (n (- end start))) (do ((tail (nthcdr start sequence) (cdr tail))) ((zerop n)) (rotatef (car tail) (car (nthcdr (random n) tail))) (decf n)))) (vector (let ((end (or end (length sequence)))) (loop for i from start below end do (rotatef (aref sequence i) (aref sequence (+ i (random (- end i)))))))) (sequence (let ((end (or end (length sequence)))) (loop for i from (- end 1) downto start do (rotatef (elt sequence i) (elt sequence (+ i (random (- end i))))))))) sequence)

(defmacro casetabletest (x) (let ((xy (loop :for x :across (shuffle (let ((vec (make-sequence 'vector nbranch))) (dotimes (i nbranch vec) (setf (elt vec i) i)))) :for i :from 0 :collect (list i x)))) `(case (case ,x ,@xy (otherwise -1)) ,@(mapcar #'reverse xy) (otherwise -1))))

(defun casetest (&aux (n 0)) (dotimes (i nbranch n) (incf n (casetabletest (casetabletest (casetabletest (casetabletest (casetabletest i))))))))

(compile 'casetest)

(time (dotimes (i 1000) (casetest)))

SBCL 1.5.8

t% /l/sbcl/1.5.8/bin/sbcl --no-sysinit --no-userinit --load /tmp/case.lisp --quit 
This is SBCL 1.5.8, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.

SBCL is free software, provided as is, with absolutely no warranty. It is mostly in the public domain; some portions are provided under BSD-style licenses. See the CREDITS and COPYING files in the distribution for more information. Evaluation took: 1.986 seconds of real time 1.990000 seconds of total run time (1.990000 user, 0.000000 system) 100.20% CPU 6,537,459,720 processor cycles 0 bytes consed

SBCL 1.5.9

t% /l/sbcl/1.5.9/bin/sbcl --no-sysinit --no-userinit --load /tmp/case.lisp --quit 
This is SBCL 1.5.9, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.

SBCL is free software, provided as is, with absolutely no warranty. It is mostly in the public domain; some portions are provided under BSD-style licenses. See the CREDITS and COPYING files in the distribution for more information. Evaluation took: 0.056 seconds of real time 0.060000 seconds of total run time (0.060000 user, 0.000000 system) 107.14% CPU 184,341,012 processor cycles 0 bytes consed

この極端な例では35倍も速くなっています。
まあこんなことはそうそうないですが!

ちなみに類似の最適化を実施するClozure CLでも同じ位のスピードが出るようです。

t% /l/ccl/1.11.5/lx86cl64 -n -l /tmp/case.lisp -e '(quit)'
(DOTIMES (I 1000) (CASETEST))
took 55,783 microseconds (0.055783 seconds) to run.
During that period, and with 8 available CPU cores,
     60,000 microseconds (0.060000 seconds) were spent in user mode
          0 microseconds (0.000000 seconds) were spent in system mode

発動ルールを探る

上記の例では最適化が発動しましたが、caseのジャンプテーブル化ではそんなに大きなテーブルは作らないことがほとんどなので、SBCLではどういう縛りがあるか確認してみます。

発動ルールは、src/compiler/ir2opt.lispshould-use-jump-table-pの中に記述されているようで、

  • キーの最大値から最小値を引いたもの+1がテーブルサイズ
  • テーブルサイズは分岐の数の二倍が上限

のようです。

(defun should-use-jump-table-p (chain &aux (choices (car chain)))
  ;; Dup keys could exist. REMOVE-DUPLICATES from-end can handle that:
  ;;  "the one occurring earlier in sequence is discarded, unless from-end
  ;;   is true, in which case the one later in sequence is discarded."
  (let ((choices (remove-duplicates choices :key #'car :from-end t))) 
    ;; Convert to multiway only if at least 4 key comparisons would be needed.
    (unless (>= (length choices) 4)
      (return-from should-use-jump-table-p nil))
    (let ((values (mapcar #'car choices)))
      (cond ((every #'fixnump values)) ; ok
            ((every #'characterp values)   
             (setq values (mapcar #'sb-xc:char-code values)))
            (t
             (return-from should-use-jump-table-p nil)))
      (let* ((min (reduce #'min values))
             (max (reduce #'max values))
             (table-size (1+ (- max min )))
             (size-limit (* (length values) 2)))
        ;; Don't waste too much space, e.g. {5,6,10,20} would require 16 words
        ;; for 4 entries, which is excessive.
        (when (and (<= table-size size-limit)
                   (can-encode-jump-table-p min max))
          ;; Return the new choices
          (cons choices (cdr chain)))))))

上記ルールからすると、一つ置きで配置された整数のキーは最適化されますが、二つ置きだとルールから外れるので最適化されないことが分かります。
一応試してみましょう。

(defun foo2 (x)
  (declare (type fixnum x))
  #.`(case x
       ,@(loop :for i :from 0 :by 2 :repeat 10
               :collect (list i i))
       (otherwise -1)))

; disassembly for FOO2
; Size: 110 bytes. Origin: #x52DF52DA                         ; FOO2
; 2DA:       498B4510         MOV RAX, [R13+16]               ; thread.binding-stack-pointer
; 2DE:       488945F8         MOV [RBP-8], RAX
; 2E2:       4C8BDB           MOV R11, RBX
; 2E5:       4983FB24         CMP R11, 36
; 2E9:       774E             JNBE L10
; 2EB:       488D0526FFFFFF   LEA RAX, [RIP-218]              ; = #x52DF5218
; 2F2:       42FF2498         JMP QWORD PTR [RAX+R11*4]
; 2F6: L0:   BA04000000       MOV EDX, 4
; 2FB: L1:   488BE5           MOV RSP, RBP
; 2FE:       F8               CLC
; 2FF:       5D               POP RBP
; 300:       C3               RET
; 301: L2:   BA08000000       MOV EDX, #x8                    ; is_lisp_thread
; 306:       EBF3             JMP L1
; 308: L3:   BA0C000000       MOV EDX, 12
; 30D:       EBEC             JMP L1
; 30F: L4:   BA10000000       MOV EDX, 16
; 314:       EBE5             JMP L1
; 316: L5:   BA14000000       MOV EDX, 20
; 31B:       EBDE             JMP L1
; 31D: L6:   BA18000000       MOV EDX, 24
; 322:       EBD7             JMP L1
; 324: L7:   BA1C000000       MOV EDX, 28
; 329:       EBD0             JMP L1
; 32B: L8:   BA20000000       MOV EDX, 32
; 330:       EBC9             JMP L1
; 332: L9:   BA24000000       MOV EDX, 36
; 337:       EBC2             JMP L1
; 339: L10:  48C7C2FEFFFFFF   MOV RDX, -2
; 340:       EBB9             JMP L1
; 342: L11:  31D2             XOR EDX, EDX
; 344:       EBB5             JMP L1
; 346:       CC10             INT3 16                         ; Invalid argument count trap

(defun foo3 (x)
  (declare (type fixnum x))
  #.`(case x
       ,@(loop :for i :from 0 :by 3 :repeat 10
               :collect (list i i))
       (otherwise -1)))

; disassembly for FOO3
; Size: 154 bytes. Origin: #x52DF53CE                         ; FOO3
; 3CE:       498B5D10         MOV RBX, [R13+16]               ; thread.binding-stack-pointer
; 3D2:       48895DF8         MOV [RBP-8], RBX
; 3D6:       4885C0           TEST RAX, RAX
; 3D9:       0F8483000000     JEQ L9
; 3DF:       4883F806         CMP RAX, 6
; 3E3:       750B             JNE L1
; 3E5:       BA06000000       MOV EDX, 6
; 3EA: L0:   488BE5           MOV RSP, RBP
; 3ED:       F8               CLC
; 3EE:       5D               POP RBP
; 3EF:       C3               RET
; 3F0: L1:   4883F80C         CMP RAX, 12
; 3F4:       7507             JNE L2
; 3F6:       BA0C000000       MOV EDX, 12
; 3FB:       EBED             JMP L0
; 3FD: L2:   4883F812         CMP RAX, 18
; 401:       7507             JNE L3
; 403:       BA12000000       MOV EDX, 18
; 408:       EBE0             JMP L0
; 40A: L3:   4883F818         CMP RAX, 24
; 40E:       7507             JNE L4
; 410:       BA18000000       MOV EDX, 24
; 415:       EBD3             JMP L0
; 417: L4:   4883F81E         CMP RAX, 30
; 41B:       7507             JNE L5
; 41D:       BA1E000000       MOV EDX, 30
; 422:       EBC6             JMP L0
; 424: L5:   4883F824         CMP RAX, 36
; 428:       7507             JNE L6
; 42A:       BA24000000       MOV EDX, 36
; 42F:       EBB9             JMP L0
; 431: L6:   4883F82A         CMP RAX, 42
; 435:       7507             JNE L7
; 437:       BA2A000000       MOV EDX, 42
; 43C:       EBAC             JMP L0
; 43E: L7:   4883F830         CMP RAX, 48
; 442:       7507             JNE L8
; 444:       BA30000000       MOV EDX, 48
; 449:       EB9F             JMP L0
; 44B: L8:   4883F836         CMP RAX, 54
; 44F:       48C7C2FEFFFFFF   MOV RDX, -2
; 456:       41BB36000000     MOV R11D, 54
; 45C:       490F44D3         CMOVEQ RDX, R11
; 460:       EB88             JMP L0
; 462: L9:   31D2             XOR EDX, EDX
; 464:       EB84             JMP L0
; 466:       CC10             INT3 16                         ; Invalid argument count trap

まとめ

SBCLのcaseのジャンプテーブル化は、キーをそこそこ密に配置する必要がある様子。
ちなみに、caseの最適化と本記事では書いてきましたが、Clozure CLと同じく、コンパイラが最適化で実施するので、Lispのレベルではifの組み合わせが最適化のルールに合致していれば発動します。

SBCLには最近細かい最適化が入ってきていますが今後も地味に速くなって行きそうです。

関連記事


HTML generated by 3bmd in LispWorks 7.0.0

スロットのアクセス時まで初期化を遅らせる

Posted 2019-11-24 20:54:15 GMT

ECLOSのlazy-classというのを再現してみようかなと思っているのですが、このlazy-slotには初期化のタイミングが、通常の初期化時と、スロット読み取り時直前とで二通りで選択可能です。
lazy-classには、他にも初期化の依存関係を記述する機能があるのですが、とりあえずそれは置いて、初期化タイミングだけ切り出して実現方法を考えてみました。
上手く行けば、初期化の依存関係を記述する機能と、初期化タイミングの指定は後でmixinできるでしょう。

あれこれ考えて作成してみましたが、下記のように動作します。

(defconstant <i@robj>
  (defclass i@robj (initialize-at-read-object)
    ((a :initform 'a :initialize-at-read-p T)
     (b :initform 'b :accessor b)
     (c :initform 'c :accessor c))
    (:metaclass initialize-at-read-class)))

(class-slots <i@robj>)(#<initialize-at-read-effective-slot-definition a 402023D19B> #<initialize-at-read-effective-slot-definition b 402023D37B> #<initialize-at-read-effective-slot-definition c 402023D3EB>)

(class-initialize-at-read-slots <i@robj>)(#<initialize-at-read-effective-slot-definition a 4020235393>)

(let ((o (make-instance <i@robj>))) (list (slot-boundp o 'a) (slot-value o 'a) (slot-value o 'b) (slot-value o 'c)))(nil a b c)

実装した内容としては、

  • 読み取り時初期化のスロットをclass-initialize-at-read-slotsとして取得することにする
  • 読み取り時初期化のスロットはshared-initializeでは初期化を飛す
  • 読み取り時初期化のスロットは、初回の読み取りは未束縛のため、slot-unboundが起動されるので、ここで初期化する
  • スロットの初期化を条件によりスキップしないといけないのでshared-initializeを置き換え

位です。

実現したいことは単純なので、どうにかコードを圧縮したいところですが、MOPのコードはどうも長くなってしまいますね。
まあ、そんなに頻繁に書くものでもないので長くても良いのか……。

今回の場合は、slot-unboundを使ってスロットの初期化をすれば良いので、クラスごとに定義することにはなるもののMOPをカスタマイズしなくてもslot-unboundの定義だけすれば、正味五六行の追加で済みそうではあります。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop))

(defpackage "a86f7ecc-112d-5ccb-9280-20798a2e36b4" (:use :c2cl))

(in-package "a86f7ecc-112d-5ccb-9280-20798a2e36b4")

;; utils (eval-when (:compile-toplevel :load-toplevel :execute) (defun package-symbolconc (package-spec &rest frobs) (values (intern (with-standard-io-syntax (with-output-to-string (out) (dolist (elt frobs) (unless (typep elt '(or symbol string fixnum character)) (error "The value ~A is not of type (OR SYMBOL STRING FIXNUM CHARACTER)." elt)) (princ elt out)))) package-spec))) (defun symbolconc (&rest frobs) (declare (dynamic-extent frobs)) (apply #'package-symbolconc *package* frobs)))

(defclass initialize-at-read-class (standard-class) ((initialize-at-read-slots :initform nil :accessor class-initialize-at-read-slots)) (:metaclass standard-class))

(defclass initialize-at-read-object (standard-object) () (:metaclass initialize-at-read-class))

(defmethod validate-superclass ((c initialize-at-read-class) (s standard-class)) T)

(macrolet ((defslotd (name) (let ((class (symbolconc name '-class)) (slotd (symbolconc name '-slot-definition)) (dslotd (symbolconc name '-direct-slot-definition)) (eslotd (symbolconc name '-effective-slot-definition)) (slotp (symbolconc 'slot-definition- name '-p))) `(progn (defclass ,slotd (standard-slot-definition) ((,(symbolconc name '-p) :initform nil :accessor ,slotp :initarg ,(package-symbolconc :keyword name '-p)))) (defclass ,dslotd (,slotd standard-direct-slot-definition) ()) (defclass ,eslotd (,slotd standard-effective-slot-definition) ()) (defmethod direct-slot-definition-class ((class ,class) &rest initargs) (declare (ignore initargs)) (find-class ',dslotd)) (defmethod effective-slot-definition-class ((class ,class) &rest initargs) (declare (ignore initargs)) (find-class ',eslotd)) (defmethod compute-effective-slot-definition ((class ,class) name direct-slot-definitions) (declare (ignore name)) (let ((eslotd (call-next-method))) (dolist (dslotd direct-slot-definitions) (when (typep dslotd (find-class ',slotd)) (setf (,slotp eslotd) (,slotp dslotd)) (return))) eslotd)) (defmethod slot-unbound ((class ,class) (instance ,(symbolconc name '-object)) name) (let ((slotd (find name (,(symbolconc 'class- name '-slots) class) :key #'slot-definition-name))) (let ((result (funcall (slot-definition-initfunction slotd)))) (setf (slot-value instance name) result) result))) (defmethod compute-slots :around ((class ,class)) (let ((slots (call-next-method))) (setf (,(symbolconc 'class- name '-slots) class) (remove-if-not #',slotp slots)) slots)))))) (defslotd initialize-at-read))

(defun initialize-slot-from-initarg (class instance slotd initargs) (let ((slot-initargs (slot-definition-initargs slotd))) (loop :for (initarg value) :on initargs :by #'cddr :do (when (and (member initarg slot-initargs) (not (slot-definition-initialize-at-read-p slotd))) (setf (slot-value-using-class class instance slotd) value) (return t)))))

(defun initialize-slot-from-initfunction (class instance slotd) (let ((initfun (slot-definition-initfunction slotd))) (unless (or (not initfun) (slot-boundp-using-class class instance slotd)) (unless (slot-definition-initialize-at-read-p slotd) (setf (slot-value-using-class class instance slotd) (funcall initfun))))))

(defmethod shared-initialize ((instance initialize-at-read-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))


HTML generated by 3bmd in LispWorks 7.0.0

STklosのメタクラス継承(をCommon Lispで)

Posted 2019-11-17 15:55:00 GMT

前回は、ECLOSが提供するdefclass:metaclassオプション省略時のメタクラスの自動算出について書きましたが、今回はTiny CLOSの流れを汲むSTklos系のメタクラスメタクラスの自動算出です。

Tiny CLOSが動くScheme処理系は結構あるようですが、より処理系と統合されたり構文が改良されたりしているのがSTklos系のようです。

  • STklos
  • Guile
  • Gauche
  • Sagitarius

上記あたりがSTklos系のようですが、Tiny CLOSの系譜をいまいち把握できていないので外しているかもしれません。
上記の継承関係は、

(defclass stklos (tiny-clos clos dylan) ())
(defclass guile (stklos) ())
(defclass gauche (stklos guile) ())
(defclass sagitarius (gauche) ())

っぽいですが。

とりあえず、今回のメタクラスの自動算出に関しては、上記処理系で共通なのでSTklos系ということにしましょう。

STklosメタクラスの自動算出アルゴリズム

Gauche: 7.5.1 クラスのインスタンシエーション等に解説されていますが、

  1. define-class:metaclassが明示されていればそれを使う
  2. 指定がなければ

    • ダイレクトスーパークラスのメタクラスのクラス順位リスト中を調べて
    • メタクラスが一つに定まればそれを使う
    • 複数なら、その複数のメタクラスをスーパークラスとするメタクラスを生成して使う

となります。

メタクラスのクラス順位リスト中をどう調べるのかは、コードは簡単なので詳細はコードを眺めた方が早いでしょう。
下記は、GuileのコードをCommon Lispに移植したものです。

オリジナルではクラス名をgensymで生成していますが、下記ではスーパークラス名のリストを名前としてみています。

(defpackage "d65706d7-0478-5a48-b39b-0dd8c0ff2563"
  (:use :c2cl))

(in-package "d65706d7-0478-5a48-b39b-0dd8c0ff2563")

(let ((table-of-metas '())) (defun ensure-metaclass-with-supers (meta-supers) (let ((entry (assoc meta-supers table-of-metas :test #'equal))) (if entry ;; Found a previously created metaclass (cdr entry) ;; Create a new meta-class which inherit from "meta-supers" (let* ((name (mapcar #'class-name meta-supers)) (new (make-instance 'standard-class :name name :direct-superclasses meta-supers :direct-slots '()))) (setf (find-class name) new) (push (cons meta-supers new) table-of-metas) new)))))

(defun ensure-metaclass (supers) (if (endp supers) (find-class 'standard-class) (let* ((all-metas (mapcar #'class-of supers)) (all-cpls (mapcan (lambda (m) (copy-list (cdr (class-precedence-list m)))) all-metas)) (needed-metas '())) ;; Find the most specific metaclasses. The new metaclass will be ;; a subclass of these. (mapc (lambda (meta) (when (and (not (member meta all-cpls)) (not (member meta needed-metas))) (setq needed-metas (append needed-metas (list meta))))) all-metas) ;; Now return a subclass of the metaclasses we found. (if (endp (cdr needed-metas)) (car needed-metas) ; If there's only one, just use it. (ensure-metaclass-with-supers needed-metas)))))

(defpackage stklos (:use) (:export defclass))

(defmacro stklos:defclass (name superclasses slots &rest class-options) (let* ((metaclass (ensure-metaclass (mapcar (lambda (s) (or (find-class s nil) (make-instance 'standard-class :name s))) superclasses))) (metaclass (case (class-name metaclass) (forward-referenced-class (find-class 'standard-class)) (otherwise metaclass)))) (clos::expand-defclass (class-prototype metaclass) (class-name metaclass) name superclasses slots class-options)))

動作確認

定義できたので動作を確認していきます。

(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)

(defconstant <a> (defclass a () () (:metaclass a-class)))

(defconstant <b> (defclass b () () (:metaclass b-class)))

前回と同じく、a-classb-classc-classとメタクラスを定義し、a-classをメタクラスとしたab-classをメタクラスとしたbを作成します。

ここで、

(defclass c (a b)
  ())

とした場合に、cのメタクラスがどのように求まるかを確認してみます。

(ensure-metaclass (list <a> <b>))
→ #<standard-class (a-class b-class) 42E014EC0B> 

ECLOSではc-classが算出されましたが、STklosでは新たにメタクラスが生成されています。
なお、一度生成されたメタクラスはensure-metaclass-with-supersが保持していて、同様のメタクラスの組み合わせが既に存在すれば、それが使われるので重複して生成することはありません。

(defconstant <c>
  (stklos:defclass c (a b)
    ()))

(defconstant <d> (stklos:defclass d (a b) ()))

(class-name (class-of <c>))(a-class b-class)

(class-name (class-of <d>))(a-class b-class)

(eq (class-of <c>) (class-of <d>)) → t

(find-class (class-name (class-of <d>))) → #<standard-class (a-class b-class) 42E014EC0B>

まとめ

今回は、STklos系のメタクラスの自動算出を眺めてみました。
メタクラスのサブクラス方向を探しに行くECLOSとは違って、STklosは継承の最下層になっているメタクラスを集め、複数なら合成して返す、という感じでした。

ちょっと試してみた感じでは、開発時のようにクラスの再定義や削除、同じ定義が別名で定義されたり(実際には名前を付け替えているつもり)が頻発する環境だと、ECLOSが探索するサブクラスのメンテナンスがなおざりになることが多いので、算出された結果も開発者の直感からすると古い情報に基いてしまったりすることがあるようです。
まあ、正しくクラスを削除、再定義すれば良いのでそういうユーティリティを充実させるのも良いかもしれません。

STklos系は、動的にメタクラスを生成するのと、クラス順位リストがサブクラスに比べてきっちり更新されるので、トラブルらしいトラブルには遭遇していません。

さて、どちらの方式が便利なのか……。 しばらく両方の方式を日々比較検討試していきたいと思います。


HTML generated by 3bmd in LispWorks 7.0.0

ECLOSのメタクラス継承

Posted 2019-11-16 21:47:29 GMT

うまいタイトルが考えつかなかったので、「ECLOSのメタクラス継承」というタイトルになりましたが、ECLOSが提供するdefclass:metaclassオプション省略時のメタクラスの自動算出についてです。

なお、ECLOSについては、

に詳しいので参照してください。

ECLOSのメタクラスの自動算出アルゴリズム

Common Lispでは、カスタマイズしたメタクラスをdefclassで利用する際には明示的に:metaclassを指定しないといけないのですが、結構めんどうです。
上記文献によれば、ECLOSは、

  1. defclass:metaclassがあればそれを使う
  2. 指定がなければ、

    • ダイレクトスーパークラスの集合をSとする。
    • それらのメタクラスの集合をM(S)とする。
    • Sの要素のサブクラス関係の推移閉包の集合をM*(S)とする。
    • M*(S)の要素の共通部分をTとする。
    • Tがサブクラス関係の木を成していれば、その根を、さもなくば、standard-classをメタクラスとする

というアルゴリズムでこの問題を解決します。

いまいち解釈に自信がありませんが、とりあえずそのままコードにしてみました。
推移閉包を求めるコードは、Tiny CLOSのものが手頃だったので、これを利用しています。

(defpackage "31f04d2f-2dc5-523c-a129-1478406e4677" 
  (:use :c2cl))

(in-package "31f04d2f-2dc5-523c-a129-1478406e4677")

(defun build-transitive-closure (get-follow-ons) (lambda (x) (labels ((track (result pending) (if (endp pending) result (let ((next (car pending))) (if (member next result) (track result (cdr pending)) (track (cons next result) (append (funcall get-follow-ons next) (cdr pending)))))))) (track '() (list x)))))

(defun compute-metaclass (dsupers &key (default-metaclass-name nil)) (block nil ;;Let C be a class, if ;;a) the definition of C includes a (:metaclass M) option then M is the metaclass of C. (when default-metaclass-name (return (find-class default-metaclass-name))) (when (endp dsupers) (return (find-class 'standard-class))) ;;b) let S be the set of direct superclasses of C (let* ((| S | dsupers) (| M(S) | (mapcar #'class-of | S |)) ;;and let M*(S) be the set of transitive closures of the subclass relation applied to the elements of M(S) (| M*(S) | (mapcar (build-transitive-closure #'class-direct-subclasses) | M(S) |)) ;;and let T be the intersection of the sets composing M*(S) (| T | (reduce #'intersection | M*(S) |))) ;;then if T forms a tree according to the subclass relation (if (and (not (null | T |)) (every #'subtypep | T | (cdr | T |))) ;;then the root of T is the metaclass of C (car (reverse | T |)) ;;otherwise STANDARD-CLASS is the metaclass of C. (find-class 'standard-class)))))

(defpackage eclos (:use) (:export defclass))

(defun ensure-class-soft (name) (or (find-class name nil) (make-instance 'standard-class :name name)))

#+lispworks (defmacro eclos:defclass (name superclasses slots &rest class-options) (let* ((metaclass-name (cadr (find :metaclass class-options :key #'car))) (metaclass (compute-metaclass (mapcar #'ensure-class-soft superclasses) :default-metaclass-name metaclass-name)) (metaclass (case (class-name metaclass) (forward-referenced-class (find-class 'standard-class)) (otherwise metaclass)))) (clos::expand-defclass (class-prototype metaclass) (class-name metaclass) name superclasses slots class-options)))

動作確認

さて、定義できたので動作を確認していきます。

(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)

(defconstant <a> (defclass a () () (:metaclass a-class)))

(defconstant <b> (defclass b () () (:metaclass b-class)))

a-classb-classc-classとメタクラスを定義し、a-classをメタクラスとしたab-classをメタクラスとしたbを作成します。

ここで、

(defclass c (a b)
  ())

とした場合に、cのメタクラスが適切に求まれば良いのですが、上記で定義したcompute-metaclassで確認してみます。

(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class c-class 4160314BC3> 

;; c-classを削除 (progn (reinitialize-instance (find-class 'c-class) :direct-superclasses nil) (setf (find-class 'c-class) nil))

;; メタクラスが求まらなかったので、デフォルト値のstandard-classを返す (compute-metaclass (list <a> <b>)) → #<lisp:standard-class standard-class 41A0997013>

;; メタクラス再作成 (defclass c-class (b-class a-class) ()) → #<lisp:standard-class c-class 40202BE5AB>

(compute-metaclass (list <a> <b>)) → #<lisp:standard-class c-class 40202BE5AB>

とりあえず大丈夫そうなので、eclos:defclassを使ってcを定義してみます。

(eclos:defclass c (a b)
  ())
→ #<c-class c 402072C593> 

まとめ

以上の動作をみて分かるように、メタクラスを多重継承する場合は、予め多重継承したメタクラスを用意しておく必要がありますが、用意さえしておけば勝手に見付けてくれるのが便利といえば便利かもしれません。
メタクラス継承の自動算出は、STklos、Guile、Gauche等のSTklos系OOPSでも行なわれています。
ECLOSとは異なったアルゴリズムが使われているので、次回はそちらを眺めたりCommon Lispで実装してみます。


HTML generated by 3bmd in LispWorks 7.0.0

Older entries (2318 remaining)