Posted 2020-12-07 18:39:35 GMT
allocate-instance Advent Calendar 2020 8日目の記事です。
allocate-instanceでカスタマイズしたいような場面について考えていますが、
あたりがある気がしていますが、今回は、インスタンス群の組織化で考えてみたいと思います。
論理・代数・データベースという本を読んでいて、昔のデータベースの構成方法にCODASYL Setというのがあることを知ったのですが、これはナビゲーショナルデータベースや、ネットワーク型データモデルの先駆けらしいです。
親子関係にあるオブジェクトでリンクトリストを作る感じですが、インスタンス群を組織化するのに隠しスロットが使えそうなので試してみましょう。
オブジェクトはownerとmemberに分かれ、ownerが作る循環リストにメンバーが接続していくという感じです。
CODASYL Setのシンプルな構成は、循環する一方向リストですが、追加や検索の便宜を図ってownerへのポインタと前後のポインタを持つことが多いそうなので、そういう構成で書いてみます。
(defpackage "c247a8da-b119-500b-b556-47ff40b1347a"
(:use c2cl slotted-objects))
(in-package "c247a8da-b119-500b-b556-47ff40b1347a")
(defclass codasyl-class (slotted-class)
((owner :accessor codasyl-class-owner :initform nil :initarg :owner)))
#+lispworks
(defmethod clos:process-a-class-option ((class codasyl-class) (name (eql :owner)) value)
(unless (and value (null (cdr value)))
(error "codasyl-class: :owner must have a single value."))
`(,name ,(car value)))
(defclass codasyl-object (slotted-object)
()
(:metaclass codasyl-class))
(defclass codasyl-element ()
((slots :accessor codasyl-element-slots :initarg :slots)
(owner :accessor codasyl-element-owner :initarg :owner :initform nil)
(next :accessor codasyl-element-next :initform nil)
(prev :accessor codasyl-element-prev :initform nil)))
(defmethod allocate-instance ((class codasyl-class) &rest initargs)
(let* ((slots (make-instance 'codasyl-element
:slots (make-sequence 'vector
(length (class-slots class))
:initial-element (make-unbound-marker))))
(instance (allocate-slotted-instance (class-wrapper class) slots)))
(setf (codasyl-element-owner slots) instance)
(setf (codasyl-element-prev slots) instance)
(setf (codasyl-element-next slots) instance)
instance))
(defmethod slot-value-using-class ((class codasyl-class) instance (slotd slot-definition))
(elt (codasyl-element-slots (instance-slots instance))
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class codasyl-class) instance (slotd slot-definition))
(setf (elt (codasyl-element-slots (instance-slots instance))
(slot-definition-location slotd))
value))
(defun find-last-codasyl-element (owner)
(loop :for elt := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots elt))
:when (eq (codasyl-element-next (instance-slots elt)) owner)
:return elt))
(defmethod initialize-instance :after ((instance codasyl-object) &rest initargs)
(let ((slot-data (instance-slots instance)))
(let ((default-owner (codasyl-element-owner slot-data))
(new-owner (codasyl-class-owner (class-of instance))))
;; if instance is member type
(and (codasyl-class-owner (class-of instance))
(unless (eq default-owner new-owner)
;; set the new owner
(setf (codasyl-element-owner slot-data) new-owner)
(let ((last (find-last-codasyl-element (codasyl-element-owner slot-data))))
;; concatenate the new member
(setf (codasyl-element-prev slot-data) last)
(setf (codasyl-element-next (instance-slots last)) instance)
(setf (codasyl-element-next slot-data) new-owner)))))))
(defun walk-codasyl-members (owner fn)
(loop :for e := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots e))
:until (eq e owner)
:do (funcall fn e)))
(defun map-codasyl-members (owner fn)
(loop :for e := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots e))
:until (eq e owner)
:collect (funcall fn e)))
循環構造を作るので無駄に長くなりました……。
(defclass owner-foo (codasyl-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass codasyl-class))
(defclass member-foo (codasyl-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass codasyl-class)
(:owner (class-prototype (find-class 'owner-foo))))
;; 10個生成する
(dotimes (i 10)
(make-instance 'member-foo))
;;
(map-codasyl-members (codasyl-class-owner (find-class 'member-foo))
(lambda (m)
(with-slots (a b c) m
(list a b c))))
→ ((0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2))
1970年代のリソース環境では、循環リストにする価値はあったんだと思いますが、普通のリストにすれば結構単純化できそうです。
要素を別途リストで管理すれば良いのですが、今回のポイントは要素内に隠しスロットで前後および親へのポインタを持つということでしょうか。
Linuxのリスト実装の構造体のトリックがありますが、今回のようなクラスを定義してmixinして使うとリストが作れる的なクラスも実現できたりしそうです。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-06 21:21:25 GMT
allocate-instance Advent Calendar 2020 7日目の記事です。
これまで、allocate-instanceで確保するストレージをスロット付きオブジェクトというところまで拡大して、データ構造を差し替えたりしてみましたが、現時点で考え付くものをまとめてみたいと思います(ネタ切れともいう)
今回も共通の処理は、slotted-objectsにまとめたものを利用します。
(defpackage "e718761d-aab2-548a-aa32-d3ba5e48b3ce"
(:use c2cl slotted-objects))(in-package "e718761d-aab2-548a-aa32-d3ba5e48b3ce")
先日も似たようなことをやっていましたが、symbol-plistをストレージにしたらどうかという試みです。
(defclass symbol-class (slotted-class)
())
(defclass symbol-object (slotted-object)
()
(:metaclass symbol-class))
(defmethod allocate-instance ((class symbol-class) &rest initargs)
(let ((sym (gentemp (string (class-name class)))))
(setf (symbol-plist sym)
(mapcan (lambda (s)
(list s (make-unbound-marker)))
(class-slots class)))
(allocate-slotted-instance (class-wrapper class)
sym)))
(defmethod slot-value-using-class ((class symbol-class) instance (slotd slot-definition))
(get (instance-slots instance) slotd))
(defmethod (setf slot-value-using-class) (value (class symbol-class) instance (slotd slot-definition))
(setf (get (instance-slots instance) slotd)
value))
(defclass symbol-foo (symbol-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass symbol-class))
シンボルはplistだけを利用するのですが、インスタンスをシンボルの値にするの方が色々応用がききそうです。
(let ((obj (make-instance 'symbol-foo)))
(set (instance-slots obj) obj)
(instance-slots obj))
→ symbol-foo4symbol-foo4
→ #<symbol-foo 4020099DF3>
(symbol-plist 'symbol-foo4)
→
(#<standard-effective-slot-definition a 42202D39D3>
0
#<standard-effective-slot-definition b 42202D4B93>
1
#<standard-effective-slot-definition c 42202D4D2B>
2)
(incf (slot-value symbol-foo4 'a) 100)
→ 100
(symbol-plist 'symbol-foo4)
→
(#<standard-effective-slot-definition a 42202D39D3>
100
#<standard-effective-slot-definition b 42202D4B93>
1
#<standard-effective-slot-definition c 42202D4D2B>
2)
(defclass alist-class (slotted-class)
())
(defclass alist-object (slotted-object)
()
(:metaclass alist-class))
(defmethod allocate-instance ((class alist-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(mapcar (lambda (s)
(cons s (make-unbound-marker)))
(class-slots class))))
(defmethod slot-value-using-class ((class alist-class) instance (slotd slot-definition))
(cdr (assoc slotd (instance-slots instance))))
(defmethod (setf slot-value-using-class)
(value (class alist-class) instance (slotd slot-definition))
(setf (cdr (assoc slotd (instance-slots instance)))
value))
(defclass alist-foo (alist-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass alist-class))
構造が似ているだけに、シンボルのplistと大差ありません。
シンボルのplistやリストをオブジェクトと連携させた際の応用としては、古えのAIプログラム等は、シンボルのplistやリスト操作を駆使したものが多いので、そういうリストとシンボルの塊のプログラムにマッピングをして見通しの良いプログラムに段階的に変換したりするのに使えたりするかもしれません。
(let ((obj (make-instance 'alist-foo)))
(incf (slot-value obj 'c) 100)
(instance-slots obj))
→
((#<standard-effective-slot-definition a 402019DFB3> . 0)
(#<standard-effective-slot-definition b 402019E01B> . 1)
(#<standard-effective-slot-definition c 402019E083> . 102)) ハッシュテーブルをストレージにするのは先日試しました
データ効率向上以外の応用としては、クロージャー+ハッシュテーブルなプログラムをクラスを利用したものに変換するのに使えたりするかもしれません。
AoSな構成については先日書きました。
1990年代のMOPの応用例の考察として、LispマシンにあったAREAというGC対象外の手動でメモリ管理する領域にインスタンスのストレージを確保する、というのがちょくちょく出てきます。
大きい配列をそのような領域に確保するという目的には丁度良いかもしれません。
AoSの逆のSoAについてはAoSと似たような応用が考えられますが、配列要素にガッチリ型を指定可能なので、型検査のメリットを活かすスロットの一つの実現方法としてSoAを利用するというのもありかなと思ったりしています。
(defclass struct-class (slotted-class)
())
(defmethod ensure-class-using-class :before ((class struct-class) name &rest initargs)
(eval `(defstruct ,(intern (concatenate 'string (string (class-name class)) (string '-struct)))
,@(mapcar (lambda (s)
(list (slot-definition-name s) (make-unbound-marker)))
(class-slots class)))))
(defclass struct-object (slotted-object)
()
(:metaclass struct-class))
(defmethod allocate-instance ((class struct-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(funcall (fdefinition
(intern
(concatenate 'string
(string 'make-)
(string (class-name class))
(string '-struct)))))))
(defmethod slot-value-using-class ((class struct-class) instance (slotd slot-definition))
(slot-value (instance-slots instance) (slot-definition-name slotd)))
(defmethod (setf slot-value-using-class) (value (class struct-class) instance (slotd slot-definition))
(setf (slot-value (instance-slots instance) (slot-definition-name slotd))
value))
(defclass struct-foo (struct-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass struct-class))
段々屋上屋っぽくなってきましたが、これも既存の構造体メインで構築したプログラムを、段階的に徐々に変換するのに使えたりもすかもしれません(上例ではクラス定義時に構造体を定義していますが)
(let ((obj (make-instance 'struct-foo)))
(incf (slot-value obj 'c) 100)
(instance-slots obj))
→ #S(struct-foo-struct :a 0 :b 1 :c 102) (defclass class-class (slotted-class)
())
(defmethod ensure-class-using-class :before ((class class-class) name &rest initargs &key direct-slots)
(ensure-class-using-class (find-class 'standard-class)
(intern (concatenate 'string (string name) (string '-storage)))
:direct-slots direct-slots))
(defclass class-object (slotted-object)
()
(:metaclass class-class))
(defmethod allocate-instance ((class class-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-instance (intern (concatenate 'string
(string (class-name class))
(string '-storage))))))
(defmethod slot-value-using-class ((class class-class) instance (slotd slot-definition))
(slot-value (instance-slots instance) (slot-definition-name slotd)))
(defmethod (setf slot-value-using-class) (value (class class-class) instance (slotd slot-definition))
(setf (slot-value (instance-slots instance) (slot-definition-name slotd))
value))
完全に屋上屋ですが、既存の定義をニコイチにしてスロット名をつけかえたりできるかもしれません。
(defclass class-foo (class-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass class-class))(let ((obj (make-instance 'class-foo)))
(incf (slot-value obj 'c) 100)
(describe (instance-slots obj)))
⇒
#<class-foo-storage 40200BA7F3> is a class-foo-storage
a 0
b 1
c 102
当初の計画ではデータ構造ごとにエントリーを書いていればallocate-instanceアドベントカレンダーの25日間はしのげるかなと思ったのですが、話が広げられないので今回一つにまとめて書いてしまいました。
あと18ネタをどう捻り出すか……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-05 23:00:44 GMT
allocate-instance Advent Calendar 2020 6日目の記事です。
今回は、allocate-instanceを含めたInstance Structure Protocol(ISP)について書きたいと思います。
Advances in Object-Oriented Metalevel Architectures and Reflectionというオブジェクト指向プログラミングの本で、ECLOSというCLOS MOPの活用事例の紹介論文があるのですが、この論文の補遺にKiczales先生が1990年代前半に考えていたCLOS MOPのISPの改善案が紹介されています。
改善案では、
compute-getter-and-setterを導入slot-value-using-class、standard-instance-access、funcallable-standard-instance-accessの廃止というのが主なところですが、compute-getter-and-setterはTiny CLOS系でお馴染です。
ここで紹介されている改善案とTiny CLOSのISP構成を比較してみると、実際そのまま同じ構成でした。
旧プロトコルの問題としては、
slot-value-using-class とその “setf” にメソッドを定義するユーザ拡張機能方式は、standard-instance-accessのような直のアクセスに比べてパフォーマンスが著しく低かった—等があり、この辺りをcompute-getter-and-setterでslot-valueの下請けのセッターとゲッターをまとめて管理するようにすることで改善できた、としています。
コンセプトを説明するためのコードも記載されているので、試しに既存のCommon Lisp上で動くかを試してみましたが、ISPをまるごと差し替えるのは、それなりに面倒な様子です。
具体的には、クラスの再定義時のインスタンス情報の更新プロトコルも併せて修正する必要がありそうです。
Tiny CLOS系のMOPと、CLOS MOPで結構違うのがスロットのカスタマイズの作法ですが、Tiny CLOS方式の方が見通し良くコードも簡潔にカスタマイズできます。
パフォーマンスに関しては、Common Lisp処理系でもCLOS MOPの枠内での工夫があるので、そこまでの違いはなさそうな気はします。
AMOPがCommon LispのMOPの決定版の地位を確立したところまでは良かったのですが、それ以降は停滞してしまいました。
CLOS MOPはANSI規格で定義されているわけではないので、処理系ごとに色々できそうですが、AMOPという定番がある故にそこから逸脱することも難しく色々微妙なことになっています……。
(defpackage "899d6e7c-87b9-559a-8075-8452920d48fc"
(:use c2cl slotted-objects)
(:shadow slot-value class-slots))
(in-package "899d6e7c-87b9-559a-8075-8452920d48fc")
(defclass new-standard-class (standard-class)
((nfields :initform nil)
(getters-n-setters :initform '())
(slots :initform '() :accessor class-slots)))
(defmethod validate-superclass ((c new-standard-class) (s standard-class))
T)
(defmethod allocate-instance ((class new-standard-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-sequence 'vector (cl:slot-value class 'nfields)
:initial-element (make-unbound-marker))))
(defgeneric compute-getter-and-setter (class eslotd eslotds field-allocator))
(defmethod compute-getter-and-setter ((class standard-class)
(eslotd standard-effective-slot-definition)
eslotds
field-allocator)
(ecase (slot-definition-allocation eslotd)
(:instance (list eslotd
(funcall field-allocator)
(lambda (ignore-obj val)
(declare (ignore ignore-obj))
val)
(lambda (ignore-obj val new)
(declare (ignore val ignore-obj))
new)))
(:class (let ((cell (cons (make-unbound-marker) nil)))
(list eslotd
nil
(lambda (ignore-obj ignore-val)
(declare (ignore ignore-obj ignore-val))
(car cell))
(lambda (ignore-obj ignore-val new)
(declare (ignore ignore-obj ignore-val))
(setf (car cell) new)))))))
#+lispworks
(defun make-wrapper (class eslotds)
(let ((wrapper (clos::make-wrapper-standard (length eslotds))))
(clos::initialize-wrapper wrapper)
(setf (elt wrapper 1)
(mapcar #'slot-definition-name eslotds))
(setf (clos::wrapper-class wrapper)
class)
(setf (elt wrapper 4)
eslotds)
wrapper))
(defmethod finalize-inheritance ((class new-standard-class))
(setf (class-precedence-list class)
(compute-class-precedence-list class))
(setf (cl:slot-value class 'slots) (compute-slots class))
(let* ((eslotds (class-slots class))
(nfields 0)
(field-allocator (lambda ()
(prog1
nfields
(incf nfields)))))
(setf (cl:slot-value class 'getters-n-setters)
(mapcar (lambda (eslotd)
(compute-getter-and-setter class eslotd eslotds field-allocator))
eslotds))
(setf (cl:slot-value class 'nfields) nfields)
(setf (class-default-initargs class)
(compute-default-initargs class))
(setf (clos::class-wrapper class)
(make-wrapper class eslotds)))
nil)
(defgeneric get-field (object field))
(defmethod get-field ((object standard-object) field)
(elt (instance-slots object) field))
(defgeneric set-field (object field value))
(defmethod set-field ((object standard-object) field value)
(setf (elt (instance-slots object) field)
value))
(defun slot-value (object slot-name)
(let* ((class (class-of object))
(eslotd (find slot-name (class-slots class)
:key #'slot-definition-name)))
(destructuring-bind (field getter setter)
(cdr (assoc eslotd (cl:slot-value class 'getters-n-setters)))
(declare (ignore setter))
(funcall getter object (and field (get-field object field))))))
(defun (setf slot-value) (new object slot-name)
(let* ((class (class-of object))
(eslotd (find slot-name (class-slots class)
:key #'slot-definition-name)))
(destructuring-bind (field getter setter)
(cdr (assoc eslotd (cl:slot-value class 'getters-n-setters)))
(declare (ignore getter))
(if field
(set-field object
field
(funcall setter object (get-field object field) new))
(funcall setter object nil new)))))
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-04 18:27:55 GMT
allocate-instance Advent Calendar 2020 5日目の記事です。
allocate-instanceをいじくるネタを捻り出す毎日ですが、今回は履歴付きスロットを実現してみたいと思います。
今回も共通の処理は、slotted-objectsにまとめたものを利用します。
スロットの更新履歴を全部保存しておいて、後から参照できるようなスロットです。
実例はこれまで目にしたことはないもののMOPの文献等でたまに用例として出てきたりします。
履歴を保存するデータ構造は色々な方法で簡単に作成できると思うので、allocate-instanceがそのようなデータ構造を確保してしまう方が、allocate-instanceよりも上のレベルであれこれするより素直で直截的かと思うので、allocate-instanceのカスタマイズ向きな用例かもしれません。
今回は素朴な実装ですが、slot-historyという現在の値と履歴のハッシュテーブルを持つオブジェクトを定義して各スロットがそれを保持することにしてみました。
スロットに値をセットする時にタイムスタンプを押しますが、get-internal-real-timeを適当に使っています。
(defpackage "f9685263-15f6-55c9-a3bb-325737df58f2"
(:use :c2cl :slotted-objects))
(in-package "f9685263-15f6-55c9-a3bb-325737df58f2")
(defclass history-slots-class (slotted-class) ())
(defclass history-slots-object (slotted-object)
()
(:metaclass history-slots-class))
(defclass slot-history ()
((cur :initform (make-unbound-marker) :accessor slot-history-value)
(log :initform (make-hash-table) :accessor slot-history-log)))
(defmethod allocate-instance ((class history-slots-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(map 'vector
(lambda (x)
(declare (ignore x))
(make-instance 'slot-history))
(class-slots class))))
(defmethod slot-value-using-class ((class history-slots-class) instance (slotd slot-definition))
(slot-history-value (elt (instance-slots instance) (slot-definition-location slotd))))
(defmethod (setf slot-value-using-class)
(value (class history-slots-class) instance (slotd slot-definition))
(let ((slot (elt (instance-slots instance) (slot-definition-location slotd))))
(setf (gethash (get-internal-real-time) (slot-history-log slot))
value)
(setf (slot-history-value slot) value)))
(defclass foo (slotted-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass history-slots-class))
(defun replay-slots (instance)
(let* ((slots (instance-slots instance))
(timestamps (sort
(loop :for s :across slots
:append (loop :for ts :being :the :hash-keys :of (slot-value s 'log) :collect ts))
#'<)))
(dolist (ts timestamps)
(map nil
(lambda (slot name)
(let ((log (gethash ts (slot-value slot 'log))))
(when log
(format T "~&~S: ~S → ~S~%" ts name log))))
slots
(mapcar #'slot-definition-name (class-slots (class-of instance)))))))
(let ((o (make-instance 'foo)))
;; それぞれのスロットに値を10回セット
(dotimes (i 10)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'a) i)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'b) i)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'c) i))
;; スロット変更履歴再生
(replay-slots o))
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530907: a → 0
11530918: b → 0
11530928: c → 0
11530951: a → 1
11530964: b → 1
11530974: c → 1
11531224: a → 2
11531251: b → 2
11531270: c → 2
11531282: a → 3
11531300: b → 3
11531310: c → 3
11531343: a → 4
11531393: b → 4
11531405: c → 4
11531464: a → 5
11531475: b → 5
11531527: c → 5
11531564: a → 6
11531664: b → 6
11531674: c → 6
11531691: a → 7
11531703: b → 7
11531729: c → 7
11531872: a → 8
11531888: b → 8
11531904: c → 8
11531936: a → 9
11531961: b → 9
11531984: c → 9
アクセス時間的にシビアなもので使うには、きっちり実装したものでないと厳しそうですが、デバッグ時に値の変更履歴を確認したい時には、素朴な実装でも活用できそうな気がします。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-03 16:07:06 GMT
allocate-instance Advent Calendar 2020 4日目の記事です。
インスタンスのストレージをカスタマイズするといっても大抵はスロット付きオブジェクトの値を参照する/設定する、のが基本操作なので、大体の操作をまとめてGitHubに置いてみました。
On Lispや、Let Over Lambdaでは、Common Lispのオブジェクト指向システムは使わず、クロージャーとハッシュテーブルだったりマクロを組合せて「オブジェクト指向システムを越えた!」みたいなことをやっていますが、今回は、逆を行ってクロージャーをインスタンスの中身にしてみます。
ちなみに、Common Lispでは、オブジェクト指向システムは普通に使うので、On Lisp、Let Over Lambdaみたいな偏った本だけ読むのではなく、Quicklisp等で流通している皆のコードを読んでみましょう。普通に皆、defclassしています。
上記slotted-objectsとしてまとめたコードを使えば、スロット付きオブジェクトをインスタンスの中身に設定するには、文末のコードのようにallocate-instanceとslot-value-using-classあたりを定義すれば実現できます。
インスタンスの中身を関数にすると、リダイレクト等の動的な操作は幾らでも可能になりますが、それはオブジェクトのアロケート時にすることかといわれると微妙です。
(defpackage "72e97df3-26b8-5ff7-b134-8d9338d93e41"
(:use :c2cl :slotted-objects))
(in-package "72e97df3-26b8-5ff7-b134-8d9338d93e41")
(defclass closure-class (slotted-class) ())
(defclass closure-object (slotted-object)
()
(:metaclass closure-class))
(defmethod allocate-instance ((class closure-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(let* ((slotds (class-slots class))
(slot-names (mapcar #'slot-definition-name slotds)))
(eval
`(let (,@(mapcar (lambda (s)
`(,s (make-unbound-marker)))
slot-names))
(lambda (set/get slot val)
(ecase set/get
((:get)
(ecase slot
,@(mapcar (lambda (d n)
`((,d) ,n))
slotds
slot-names)))
((:set)
(ecase slot
,@(mapcar (lambda (d n)
`((,d) (setq ,n val)))
slotds
slot-names))))))))))
(defmethod slot-value-using-class ((class closure-class) instance (slotd slot-definition))
(funcall (instance-slots instance) :get slotd nil))
(defmethod (setf slot-value-using-class)
(value (class closure-class) instance (slotd slot-definition))
(funcall (instance-slots instance) :set slotd value))
(defclass foo (slotted-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass closure-class))(describe
(make-instance 'foo))
#<foo 4020386BEB> is a foo
a 0
b 1
c 2
(let ((o (make-instance 'foo)))
(let ((slot-a (find 'a (class-slots (find-class 'foo)) :key #'slot-definition-name)))
(funcall (instance-slots o) :set slot-a 100)
(describe o)))
#<foo 4020083683> is a foo
a 100
b 1
c 2
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-02 17:23:01 GMT
allocate-instance Advent Calendar 2020 3日目の記事です。
以前、MOPでSoAというのを試してみたのですが、今回はSoAの逆のAoSを試してみたいと思います。
AoSとは、構造体を並べた配列でArray of Structuresの略ですが、Common Lispにはdisplaced arrayという配列の一部を別の配列として利用する機能があるので、一本の巨大な配列を細切れにして分配してみます。
AoSを確保する部分とallocate-instaceが骨子ですが、その部分だけを抜き出すと下記のようになります。
(defparameter *aos*
(make-array (1- array-total-size-limit) :initial-element *slot-unbound*))
(defmethod allocate-instance ((class aos-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let* ((len (length (class-slots class)))
(obj (make-array len
:displaced-to *aos*
:displaced-index-offset (class-index class))))
(incf (class-index class) len)
obj)))
インスタンスを定義してから10回make-instanceして、ストレージの配列を観察してみます。
(defclass foo (aos-slots-object)
((a :initform 'a)
(b :initform 'b)
(c :initform 'c))
(:metaclass aos-slots-class))
(dotimes (i 10)
(make-instance 'foo))
(subseq *aos* 0 30)
→ #(a b c a b c a b c a b c a b c a b c a b c a b c a b c a b c)
ストレージの配列のを眺めてしまうと、アクセス時に間違って混ざったりちゃいそうに見えますが、displaced arrayのお蔭でインスタンスは個別の領域のみアクセスしています。
大体こんな感じになります。
インスタンスのストレージの中身の操作については、前回の定義を参照してください。
(defclass aos-slots-class (standard-class)
((index :initform 0 :accessor class-index)))
(defmethod shared-initialize :after ((class aos-slots-class) slots &rest initargs)
(setf (class-index class) 0))
(defclass aos-slots-object (standard-object)
()
(:metaclass aos-slots-class))
(defmethod validate-superclass ((class aos-slots-class) (super standard-class))
T)
(defparameter *aos*
(make-array (1- array-total-size-limit) :initial-element *slot-unbound*))
(defmethod allocate-instance ((class aos-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let* ((len (length (class-slots class)))
(obj (make-array len
:displaced-to *aos*
:displaced-index-offset (class-index class))))
(incf (class-index class) len)
obj)))
(defmethod slot-value-using-class
((class aos-slots-class) instance (slotd slot-definition))
(elt (instance-slots instance)
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class)
(val (class aos-slots-class) instance (slotd slot-definition))
(setf (elt (instance-slots instance)
(slot-definition-location slotd))
val))
(defgeneric initialize-slot-from-initarg (class instance slotd initargs))
(defmethod 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 (member initarg slot-initargs)
(setf (slot-value-using-class class instance slotd)
value)
(return T)))))
(defgeneric initialize-slot-from-initfunction (class instance slotd))
(defmethod initialize-slot-from-initfunction (class instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (slot-value-using-class class instance slotd)
(funcall initfun)))))
(defmethod shared-initialize
((instance aos-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)
似たようなものを色々定義していますが、スロットを有するオブジェクトについては一つslotted-class&slotted-objectにまとめられそうです。
Lispにおいてスロットを有すると考えられるオブジェクトは沢山ありますが、
—あたりは統一的な操作体系でまとめられるでしょう。
定義が長いのでそのうちGitHub等にでも置こうかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-02 13:03:55 GMT
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
Posted 2020-11-30 16:26:06 GMT
allocate-instance Advent Calendar 2020 1日目の記事です。
Lisp系のニッチなことをテーマにアドベントカレンダーを開催したりしなかったりしていますが、今年は、allocate-instanceをテーマにしてみることにしました。
allocate-instance とは所謂Common Lisp系のオブジェクトシステム(CLOS)のインスタンスを確保する部分ですが、AMOPでいうとInstance Structure Protocol(以降ISP)辺りの話題となります。
ISPアドベントカレンダーという名前でも良かったのですが、allocate-instanceの方がわかりやすいかなと思ってこっちの名前にしましたが、どっちにしろ参加者が集まりそうにないので五十歩百歩かもしれません。
それはさておき、AMOPのISPの説明を読むと判るように、どちらかといえばスロットのアクセスを基点として、インスタンスの物理的配置までカスタマイズするための構成が説明されています。
今回は、allocate-instanceを基点に考えてみたら面白いかもしれないというチャレンジですが、STKlosのVirtual Slots等は、スロットアクセスを基点に計算をしたりするので、ISP的にはallocate-instanceがなくても良かったりすることもあります。
ちなみにVirtual Slotsの応用は下記の記事等が参考になります。
他、複数オブジェクトをまとめて扱うような操作を実現するのもISPのカスタマイズの一種かなと思います。
allocate-instance の拡張についてスロットアクセスからデータの物理配置までの間のプロトコルをカスタマイズするのに、スロットアクセス側に重きをおく上記Virtual Slotのようなものもあれば、逆にデータ構造側に工夫をしてスロットアクセス側はそれほどカスタマイズしないという構成も考えられます。
古典的な書籍であるThe CLOS PerspectiveにもMOPの話が出てきますが、知識表現のように項目が非常に多いけれど、それぞれの利用頻度は非常に低かったりする場合は、スロットを配列にするのではなく、ハッシュテーブルのようなものの方がメモリ効率が良いだろうというアイデアの一つとして、allocate-instance のカスタマイズが示唆されたりしています。
しかし、この論文でも実際のカスタマイズの詳細については触れられておらず、類似の事例紹介でも大抵はallocate-instance内部で確保するデータ構造をカスタマイズするのではなく、フックを掛けて別のデータオブジェクトにリダイレクトするようなものが殆どのようです。
フックを掛けて別のデータオブジェクトにリダイレクトするようなものとしては文末のコードのような構成が考えられます。
この場合、allocate-instanceをカスタマイズしてはいますが、デフォルトで確保したものは捨てて、別途確保しているという点で無駄なところがあります。
また、類似のものに、オブジェクトのシリアライズやORマッパーの応用がありますが、これらも確保するデータ構造はノーマルなもので、確保時のフックが眼目になります。
今回のアドベントカレンダーは、このように迂回されることが多いallocate-instanceが確保するデータ構造について正面から向き合ってみようというのが大体の主旨です。
(defpackage "e79ba511-fd06-57f8-9038-132961fa529b" (:use :c2cl))(in-package "e79ba511-fd06-57f8-9038-132961fa529b")
(defvar *hash-slots* (make-hash-table))
(defclass hash-table-representation-class (standard-class)
())
(defmethod allocate-instance ((c hash-table-representation-class) &rest args)
(let ((inst (call-next-method)))
(setf (gethash inst *hash-slots*)
(make-hash-table))
inst))
(defmethod slot-value-using-class
((c hash-table-representation-class)
inst
(slot-name slot-definition))
(gethash slot-name
(gethash inst *hash-slots*)
(slot-definition-initform slot-name)))
(defmethod (setf slot-value-using-class)
(newvalue
(c hash-table-representation-class) inst
(slot-name slot-definition))
(setf (gethash slot-name
(gethash inst *hash-slots*)
(slot-definition-initform slot-name))
newvalue))
(defclass foo ()
((a :initform 0 :accessor foo-a)
(b :initform 0 :accessor foo-b)
(c :initform 0 :accessor foo-c))
(:metaclass hash-table-representation-class))
(defparameter *the-foo* (make-instance 'foo))
(list (foo-a *the-foo*)
(foo-b *the-foo*)
(foo-c *the-foo*))
→ (0 0 0)
(setf (foo-a *the-foo*) 42
(foo-b *the-foo*) 43)
;=> 43
(list (foo-a *the-foo*)
(foo-b *the-foo*)
(foo-c *the-foo*))
→ (42 43 0)
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-11-24 19:15:57 GMT
MACLISP系Lispではお馴染のキーワード引数ですが、最近だと名前付き引数等々様々な名前で色々な言語に採用されています。
そんなキーワード引数ですが、Lisp族に導入されたのは、いまから丁度40年前の秋の1980-10-05だったようです。
元々はWilliam A. Kornfeld(BAK)氏の発案のDEFUN-KEYEDからMACLISP系Lispに取り込まれCommon Lispでメジャーになった様子。
面白いのが(send foo ':x 42 ':y 30)のようなコロン付きのシンボルは既にFlavorsのメッセージ式で広く使われていたということです。
キーワード引数はどこが大元なのだろうかと思い、ちょっと調べましたが、同時期だとAda(1983)がありました(6.4.2. Default Parameters)
上述のFlavorsようにメッセージのキーワードをキーワード引数と考えれば、Smalltalkが元祖かもしれませんが、どうなのでしょう。
キーワードといえば、&rest、&optional等のlambda list keywordもありますが、これがISLISPのように:rest、:optionalとキーワードシンボルで統一されなかった理由ですが、1980年当時はキーワードシンボルというものは存在せず、:fooもuser:fooの略記(userパッケージのfooシンボル)だったため、:restだとシンボルがユーザープログラム中で不意にeqになってしまう懸念があったりしたようです。
その後Common Lispの仕様の議論でも二回程キーワードシンボルへの統一が話題にのぼりますが、タイミングが悪かったのかスルーされて今に至ります。まあ互換性を尊守したのかもしれませんが。
ちなみに、同時期に範囲コメントの#|...|#も登場していたようです。発案者はAlan Bawden氏でしたが、#|...|#は、最初はかなり評判が悪かった様子……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-11-22 21:55:02 GMT
MACLISP系のLispコードのコメント作法については、セミコロンの数の使い分けから丁寧に解説されていることが多いのですが、インラインコメントが複数行になった場合の字下げの習慣については何故か忘れられていることが多いようです。
具体的には下記のようなコードの場合、
;;;; Math Utilities
;;; FIB computes the the Fibonacci function in the traditional
;;; recursive way.
(defun fib (n)
(check-type n integer)
;; At this point we're sure we have an integer argument.
;; Now we can get down to some serious computation.
(cond ((< n 0)
;; Hey, this is just supposed to be a simple example.
;; Did you really expect me to handle the general case?
(error "FIB got ~D as an argument." n))
((< n 2) n) ;fib[0]=0 and fib[1]=1
;; The cheap cases didn't work.
;; Nothing more to do but recurse.
(t (+ (fib (- n 1)) ;The traditional formula
(fib (- n 2)))))) ; is fib[n-1]+fib[n-2].——のThe traditional formula is fib[n-1]+fib[n-2].というコメントが二行に渡っているので二行目以降が字下げされているのが分かるでしょうか。
ANSI CLの規格票(やHyperSpec)にも書いてあったりするのですが、何故忘れられてしまうことが多いのか。
ANSI CL規格で言及されているのは、セミコロン一つのインラインコメントの場合だけですが、MIT系のコードでは複数行に渡る場合はセミコロンの数に拘らず二行目以降は下げるというのが多いようです。
PDP-10のMIDASアセンブリのコードでも同様の作法がみられるので、由来はこの辺りかもしれません。
ちなみに、JonL氏にいたっては普段の文章も二行目以降を字下げするというスタイルで書いていたりします(さすがに全部ではありませんが……)
None of Glenn's problems are due to NIL stuff.
None of the new MacLISP development is particularly NIL stuff
(multiple-values have been on the LISPM for years).
Indeed, the "intermediate" MACLISP dump cost us more than 7K of
address space, and is being dropped. As soon as agreement is
reached about XLISP, then XCOMPLR will replace the currently
bloated complr.なんかこれ似たようなことを書いたことがあった気がするなーと思ったら9年前に書いてました。
当時はインラインコメントでの作法と思っていましたが、インラインに限定はされないようです。
■
HTML generated by 3bmd in LispWorks 7.0.0