#:g1

CLでSRFI 175

Posted 2020-02-16 14:16:07 GMT

九年ほど前からSchemeのSRFIをCommon Lispに移植する遊びをしていますが、久々にコピペ移植してみました。
前回SRFI 118を移植したのは、2005-01-02のようなので、実に五年ぶり。

今回移植したのは、SRFI 175: ASCII character libraryで、ASCIIを扱うライブラリのようで、現時点でファイナルになっているものでは一番番号が大きいものです。

導入

Ultralispに登録してみたので、

(ql-dist:install-dist "http://dist.ultralisp.org/")

してあれば、

(ql:quickload :srfi-175)

でインストール可能です。

動作

ASCIIに関して操作したいことは大体網羅されているので、必要な時には便利に使えるのではないでしょうか。

(ascii-downcase #\G)
→ #\g 

(ascii-alphabetic? #\1) → nil

(remove-if #'ascii-whitespace? "foo bar baz") → "foobarbaz"

まとめ

SRFIの移植については、Scheme→Common Lispなコンパチレイヤーがあると楽なのでボチボチ作ってみたりしていますが、このあたりも作り込むとコピペが捗りそうです。

このrnrs-compatでは関数とマクロで変換していますが、トランスレータでの一括変換も試してみたいところ。


HTML generated by 3bmd in LispWorks 7.0.0

Ultralisp使ってみた

Posted 2020-02-11 19:14:11 GMT

今年は移植したSRFIでもQuicklispに登録してみようかなと思って、Quicklispに三つ四つ登録してみましたが、「登録するは良いけどユーザーいるの?(大意)」という質問がありました。
SRFIのCommon Lispへの移植は90近くあるのですが、いうまでもなくどれも誰得なものなので、まあそうだよなーなど思ったりしていましたが、こういう誰得なものにはUltralispが合っていると思うと教えてもらったので、Ultralispに登録してみることにしました。

Ultralispは、Quicklispの仕組みを利用していて、“dist”の一つという位置付けです。

(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)

で利用できるようになりますが、登録後には“dist”が増えていることが確認できます。

(ql-dist:all-dists)(#<ql-dist:dist quicklisp 2019-12-27> #<ql-dist:dist ultralisp 20200126195012>)

Ultralispの売りは、“dist”を五分毎に更新するので、登録から利用までが非常に早いのと、GitHubのリポジトリを管理画面からポチポチ登録すれば、登録は完了という手軽さのようです。

ちなみに別段Quicklisp本家が俺んちルールでやっているということではなく、各distには管理者がいて、Quicklispのデフォルトの“quicklisp” distにも管理者のポリシーがある、ということで適宜棲み分けするのが宜しかろうというところでしょうか。

暗黙のポリシーも含めてリストにするとこんな感じでしょうか。

“quicklisp” dist “ultralisp” dist
dist更新 約一ヶ月毎 五分毎
登録基準 SBCLでビルドできるか 特になし
除外基準 SBCLでビルドできなくなったら 特になし

現状、Common Lisp界はSBCL一強になりつつありますが、SBCLでビルドできなければ、“quicklisp” distには載らないんだよなーというのは、まあまあ耳にする話だったので、そういう点も“ultralisp”と“quicklisp”の棲み分けの基準になるかもしれません。

また、Ultralispの登録の手軽さを活かして、とりあえずUltralispに登録して暫く運用し、手応えがあったらQuicklispに申請するというのも良さそうです。

Ultralisp使用感とまとめ

特に“quicklisp” distと変わらないですが、手軽に早く登録できるので、複数環境で自作ライブラリを利用するのはかなり手軽になります。
その代わりといってはなんですが、登録レポジトリのコードを壊しちゃたりした場合でも、素早くそのまま流れていくので注意が必要かなと思います。
(素早く修正すれば良いとはいえ)

こんなUltralispなので登録ライブラリはQuicklispのデフォルトより多いんだろうと思いきや現在1253ということでquicklispの約1800より少ないようです。
“quicklisp” distから“ultralisp” distへの取り込みも進んでいるようなのでそのうち包含するのかもしれません。

ちなみにそもそものきっかけになったSRFIのCommon Lisp移植版ですが、ボチボチUltralispに登録しています。
srfi-2やsrfi-19等便利なものも案外あるので折角なのでUltralisp経由で活用していきたいと思います。


HTML generated by 3bmd in LispWorks 7.1.2

2019年振り返り

Posted 2019-12-31 15:13:25 GMT

毎年振り返りのまとめを書いているので、今回も書きます。

Lisp的進捗

今年は何故か自分の中ではMOPブームが到来し、後半は特にMOP的な拡張をして遊んでいました。
ECLOSを始めとして、1990年代にはMOPの拡張が色々と試行錯誤されていたようなので、これを暫く追試して行こうかなと思います。
どうもMOPは学習の取っ掛かりがないという印象があり、どう学んでいったら良いのか良く分からない状況が自分も長く続きましたが、結局のところ沢山書けば色々憶えてくるようです。
とりあえず役に立つ応用を考えたりするのは後回しで量を書いていれば段々見通しが付いてくるように思えました。
思えばマクロもナンセンスなものを沢山書いていましたし、自分はとりあえず量を書かないことには身に付かない質かもしれません。
Common LispのMOPも中途半端だったり発展途中(で四半世紀進歩がない)だったりするので、その辺りの状況もまとめてみたいと考えています。

ブログ

今年書いた記事は38記事でした。
年々記事の量が減っていますが、ネタがない訳ではなく記事にするのが面倒というところです。
世間的にもLispの記事を目にすることは大分少なくなりました。大分ブログというツールも廃れた感がありますが、2020年はもうちょっと書いていきたいと思います。

LispWorks

LispWorksを購入してから早四年半。
それまでSBCL+SLIMEをメインに使っていましたが、購入を機にLispWorksのIDEメインとしました。 しかし、いまだにSLIMEで便利だった機能を越えられていないところがあります。
LispWorksの方が便利なところも多いのですが、2020年は両者の良いとこ取りな環境を構築していきたいところです。

LispWorksでの職場の社内ツール作りもあいかわらず継続していて、利用者もアプリの種類も増えました。
折角なのでLispWorksのCommmon SQLやKnowledgeWorksの機能も使ってみていますが、デザインは古いもののそこそこ便利に使えています。
DBや推論機能はメタクラスが定義されており、これらをmixinして連携させるのが楽しいといえば楽しいです。

ウェブ屋さんが沢山在籍する職場では何かGUIのツールを作成するとなれば、ウェブアプリになると思いますが、そうでなければ、LispWorksみたいなアプリ作成機能もそこそこ有用かなと思います。
特に社内でしか使わないとなれば、ウェブアプリのメンテもそこそこ面倒なので。

2020年やってみたいこと

2019年の計画では、コンディションシステムアドベントカレンダーを開催したいと思っていましたが、ちょっと試しにQiitaを退会してみたら、記事がごっそり消えてしまったので、アドベントカレンダーを開催するのがめんどうになってしまい2019年はスキップしてしまいました。
コンディションシステムやMOPは今後も深追いしていきたい所存です。

また、1980年代のエキスパートシステムブームとLispについて大体見通しが付いてきたので、2020年は、第二次AIブームでのLispの活躍とは何だったのか等々まとめてみたいと考えています。

過去のまとめ


HTML generated by 3bmd in LispWorks 7.0.0

痕跡を残さない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

Older entries (2321 remaining)