#:g1

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

slot-valueを排除する試み(2)

Posted 2019-11-10 19:19:05 GMT

前回はとりあえず、インスタンスのアクセスにslot-valueを使わないようなメタクラスを定義してみたりしましたが、slot-value排除を推進してインスタンスの初期化にも細工してみたいと思います。
slot-value経由でのアクセスの廃止=カプセル化という応用で考えてみます。

encapsulated-class

本当はインスタンスの初期化からもslot-valueを排除したかったのですが、気付いたらslot-valueを自作していた感があったので、slot-valueは初期化メソッドの内部でしか利用させないという制限を付けることにしました。
制限の手段としては安直にクラスに class-encapsulated-pを定義して管理します。
slot-value...系はclass-slotsの情報を元に動作することになるので、大元のclass-slotsに制限を掛けてやることにします。
今回は、class-encapsulated-pTの時はclass-slotsがエラーを発するようにしてみました。

encapsulated-object

オブジェクトの初期化をカスタマイズするには、standard-objectを派生させる必要があるので、encapsulated-objectを定義し、これの初期化をカスタマイズします。

カプセル化と継承についての問題で、アクセス制限をどう継承するか、というものがあるようですが、今回は継承側の勝手に任せることにしました。

ということでこんな動きになりました。

;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (fdefinition 'a) #'make-instance))

(defconstant <zot> (defclass zot (encapsulated-object) ((a :initform 0 :accessor zot.a)) (:encapsulated-p T) (:metaclass encapsulated-class)))

(class-encapsulated-p <zot>) → T

(slot-value (a <zot>) 'a) !!! Illegal reflective access: #<encapsulated-class zot 4120259C13>.

(zot.a (a <zot>)) → 0

(defconstant <quux> (defclass quux (zot) ((x :initform 42) (y :initform 42) (z :initform 42)) (:encapsulated-p nil) (:metaclass encapsulated-class)))

(class-encapsulated-p <quux>) → nil

(with-slots (a x y z) (a <quux>) (list a x y z))(0 42 42 42)

定義

  • shared-initializeの定義はSBCLのものを参考にしました。

(cl:in-package cl-user)

(load "via-accessor-class")

(eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :closer-mop) (when (find-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35") (delete-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")))

(defpackage "a6acd6f5-46a2-51bf-83be-8596ac2d2f35" (:use :c2cl))

(in-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")

(defmacro in-syntax (name) `(progn (defvar ,(intern name) (copy-readtable nil)) (setq *readtable* ,(intern name))))

(defmacro local-prefix-setup () `(set-macro-character #\~ (lambda (srm chr) (declare (ignore chr)) (intern (concatenate 'string (string 'encapsulated-) (string (read srm)))))))

(in-syntax "a6acd6f5-46a2-51bf-83be-8596ac2d2f35") (local-prefix-setup)

(define-condition illegal-reflective-access (simple-error) () (:report (lambda (condition stream) (format stream "Illegal reflective access: ~{~S~}." (simple-condition-format-arguments condition)))))

(defclass ~class (|3d0ecf39-dd6c-53f5-9672-58d5f5408cc6|:via-accessor-class) ((~p :initform T :initarg :encapsulated-p :accessor class-encapsulated-p)))

(defmethod ensure-class-using-class :around ((class ~class) name &rest initargs &key (~p T ~p-sup?)) (if (and ~p-sup? (consp ~p)) (apply #'call-next-method class name :encapsulated-p (car ~p) initargs) (call-next-method)))

(defmethod validate-superclass ((class ~class) (super standard-class)) T)

(defmethod class-slots :around ((class ~class)) (if (class-encapsulated-p class) (error 'illegal-reflective-access :format-arguments (list class)) (call-next-method)))

(defclass ~object (standard-object) ())

(defmethod shared-initialize ((instance ~object) slot-names &rest initargs) (flet ((initialize-slot-from-initarg (class instance slotd) (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))))) (initialize-slot-from-initfunction (class instance slotd) (let ((initfun (slot-definition-initfunction slotd))) (unless (or (not initfun) (slot-boundp-using-class class instance slotd)) (setf (slot-value-using-class class instance slotd) (funcall initfun)))))) (let* ((class (class-of instance)) (encapsulated-p (class-encapsulated-p class))) (unwind-protect (progn (setf (class-encapsulated-p class) nil) (loop :for slotd :in (class-slots class) :unless (initialize-slot-from-initarg class instance slotd) :do (when (or (eq t slot-names) (member (slot-definition-name slotd) slot-names)) (initialize-slot-from-initfunction class instance slotd)))) (setf (class-encapsulated-p class) encapsulated-p))) instance))

(defmethod finalize-inheritance :around ((class ~class)) (let ((encapsulated-p (class-encapsulated-p class))) (unwind-protect (progn (setf (class-encapsulated-p class) nil) (call-next-method)) (setf (class-encapsulated-p class) encapsulated-p))))

まとめ

slot-value排除の応用としてカプセル化も考えつつも、初期化でのslot-valueの扱いは日和るという中途半端な考察で、slot-valueを排除するのはなかなか面倒ということが分かっただけでした。

今回は、アクセス制限については、class-slotsでの制御としましたが、スロットをカスタマイズする方法もありそうです。

ちなみに、カプセル化の方法として、自由(uninterened)シンボルを使うというのがあるらしいですが、秘匿効果としては微妙な気がしています。
Pythonの命名規約の__foo__みたいなものでしょうか。

;;; importすれば簡単にシンボルは捕捉できる
(defclass foo ()
  (#:a #:b #:c))

(class-slots (find-class 'foo))(#<standard-effective-slot-definition #:a 40201BF60B> #<standard-effective-slot-definition #:b 40201BF673> #<standard-effective-slot-definition #:c 40201BF6DB>)

(mapc (lambda (s) (shadowing-import (slot-definition-name s))) (class-slots (find-class 'foo)))(#<standard-effective-slot-definition a 417024825B> #<standard-effective-slot-definition b 4170248753> #<standard-effective-slot-definition c 4170248C63>)

(setf (slot-value (make-instance 'foo) 'a) 42) → 42


HTML generated by 3bmd in LispWorks 7.1.2

slot-valueを排除する試み(1)

Posted 2019-11-06 19:47:19 GMT

オブジェクトへのアクセスは、slot-valueを使わず、アクセサ経由でを心掛けようとは良くいわれますが、今回は、MOPでslot-valueを回避できないかを探る試みです。

MOPには、standard-instance-accessのようなものがあるので、アクセスはstandard-instance-accessを直接使ってしまえば良かろうと思って下記のようなものを書いてみました。

アクセサがstandard-instance-accessでアクセスするインデックスを保持できれば良いだけなのですが、class-slots実行以降でしかインデックスは確定しないので、アクセサが別途インデックスを保持するように拡張し、インデックス確定後にアクセサに値を格納することにしました。

(in-package cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :closer-mop) (when (find-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6") (delete-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")))

(defpackage "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6" (:use :c2cl))

(in-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")

(eval-when (:compile-toplevel :load-toplevel :execute) (macrolet ((in-syntax (name) `(progn (defvar ,(intern name) (copy-readtable nil)) (setq *readtable* ,(intern name)))) (via-accessor-prefix-setup () `(set-macro-character #\~ (lambda (srm chr) (declare (ignore chr)) (intern (concatenate 'string (string 'via-accessor-) (string (read srm)))))))) (in-syntax "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6") (via-accessor-prefix-setup)))

;; 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))) #+lispworks (editor:setup-indent "<defclass>" 2 2 10) 'eval-when)

(defclass ~class (standard-class) ())

(defmethod validate-superclass ((class ~class) (super standard-class)) T)

(defclass ~accessor-method (standard-accessor-method) ((slot-location :initarg :slot-location :accessor ~accessor-method-location)))

(defclass ~reader-method (~accessor-method standard-reader-method) ())

(defclass ~writer-method (~accessor-method standard-writer-method) ())

(defun ~reader-method-function-maker (method) #+(or lispworks ccl) (lambda (arg &rest next-methods) (declare (ignore next-methods)) (funcall (lambda (instance) (standard-instance-access instance (~accessor-method-location method))) arg)) #+(or sbcl) (lambda (args next-methods) (declare (ignore next-methods)) (apply (lambda (instance) (standard-instance-access instance (~accessor-method-location method))) args)))

(defmethod initialize-instance ((method ~reader-method) &rest initargs) (apply #'call-next-method method :function (~reader-method-function-maker method) initargs))

(defun ~writer-method-function-maker (method) #+(or lispworks ccl) (lambda (val arg &rest next-methods) (declare (ignore next-methods)) (funcall (lambda (val instance) (setf (standard-instance-access instance (~accessor-method-location method)) val)) val arg)) #+(or sbcl) (lambda (args next-methods) (declare (ignore next-methods)) (apply (lambda (val instance) (setf (standard-instance-access instance (~accessor-method-location method)) val)) args)))

(defmethod initialize-instance ((method ~writer-method) &rest initargs) (apply #'call-next-method method :function (~writer-method-function-maker method) initargs))

(defmethod reader-method-class ((class ~class) direct-slot &rest args) (declare (ignore args direct-slot)) (find-class '~reader-method))

(defmethod writer-method-class ((class ~class) direct-slot &rest args) (declare (ignore args direct-slot)) (find-class '~writer-method))

(defmethod finalize-inheritance :after ((class ~class)) (let ((esds (class-slots class))) (dolist (dsd (class-direct-slots class)) (dolist (reader (slot-definition-readers dsd)) (let ((meth (find-method (ensure-generic-function reader :lambda-list '(x)) nil (list class) nil))) (when meth (setf (~accessor-method-location meth) (slot-definition-location (find (slot-definition-name dsd) esds :key #'slot-definition-name)))))) (dolist (writer (slot-definition-writers dsd)) (let ((meth (find-method (ensure-generic-function writer :lambda-list '(val x)) nil (list (find-class T) class) nil))) (when meth (setf (~accessor-method-location meth) (slot-definition-location (find (slot-definition-name dsd) esds :key #'slot-definition-name)))))))))

(defmethod shared-initialize :after ((class ~class) slot-names &rest initargs) (declare (ignore slot-names initargs)) (finalize-inheritance class))

おまけに速くなるのだろうか……

理屈では間接参照のslot-valueと違って直接参照のstandard-instance-accessの方が速くなる筈ですがどうでしょう。
さすがに処理系もslot-valueでのアクセスの最適化はしていると思いますが……。

(<defclass> foo ()
  ((a :initform 0 :accessor .a)
   (b :initform 1)
   (c :initform 2 :accessor .c))
  (:metaclass ~class))

(<defclass> bar (foo) ((d :initform 3 :accessor .d)) (:metaclass ~class))

読み出し速度

LispWorksだと今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等だと余計なことをするよりslot-valueの方が速いようです……。

(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (slot-value obj 'a))))

User time = 1.240 System time = 0.000 Elapsed time = 1.242 Allocation = 1296014992 bytes 0 Page faults Calls to %EVAL 18000041

(time (let ((obj (a <foo>))) (dotimes (i (expt 10 6)) (.a obj))))

User time = 1.100 System time = 0.000 Elapsed time = 1.095 Allocation = 1296011632 bytes 0 Page faults Calls to %EVAL 17000041

書き込み速度

LispWorksだと読み出し同様、今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等でも若干速くなるかも。

(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (setf (slot-value obj 'a) 42))))

User time = 7.260 System time = 0.000 Elapsed time = 7.259 Allocation = 3126471872 bytes 0 Page faults Calls to %EVAL 20000041

(time (let ((obj (a <foo>))) (dotimes (i (expt 10 6)) (setf (.a obj) 42))))

User time = 6.020 System time = 0.060 Elapsed time = 6.074 Allocation = 3118472872 bytes 0 Page faults Calls to %EVAL 22000041

今回のまとめ

明示的にstandard-instance-accessを使うようにしても、slot-value経由より遅くなることもあるようなので、もう少し詰めて対策しないと御利益はなさそうです。
標準のオブジェクトへのアクセスは処理系が結構最適化しているのですが、ユーザー定義のメタクラス等の派生物は標準から外れるので処理系が用意している最適化の適用外になってしまうことも多いようです。

なお今回は、アクセス方法でslot-valueを外す試みでしたが、インスタンス初期化まわりでもslot-valueは使われています。
どうもslot-valueを排除するのは簡単な話ではなさそう。

〜インスタンス生成篇へつづく〜


HTML generated by 3bmd in LispWorks 7.1.2

;|#

Posted 2019-11-02 19:13:57 GMT

;|# はかしこい

どうもiterateのバグを踏んでしまったようなのでソースを眺めていましたが、コード中の ;|# を目にしてこれは賢いなと以前から思っていたことを思い出しました。

#|
;; Optionally set up Slime so that C-c C-c works with #L
#+#.(cl:when (cl:find-package "SWANK") '(:and))
(unless (assoc "ITERATE" swank:*readtable-alist* :test #'string=)
  (bind ((*readtable* (copy-readtable *readtable*)))
    (enable-sharpL-reader)
    (push (cons "ITERATE" *readtable*) swank:*readtable-alist*)))
;|#

賢いというのは、#|;でコメントアウトしさえすれば、後ろの|#のメンテナンス(つまり消す)はしなくても良いというところ。

#|
(list 0 1 2)
;|#

(list 0 1 2)を復活したくなった →

;#|
(list 0 1 2)
;|#

Quicklisp中にどれくらい含まれているか検索してみましたが、iterateの他は、clazy、teepeedee2、で使われているくらいのようです。
案外少ないかも?

このブログはteepeedee2で運用されていますが、;|#は、teepeedee2のソースで最初に目にした気がします。


HTML generated by 3bmd in LispWorks 7.1.2

||パッケージの謎

Posted 2019-10-20 14:41:47 GMT

Common Lispのパッケージは名前を持ち、その名前は文字列となっています。
さて、それでは長さ0の文字列の場合、どのような挙動になるでしょうか。

ざっと調べてみました。

処理系 ""パッケージの扱い
LispWorks 7.1.2 ""パッケージ
Allegro CL 10.1 keywordパッケージ
Lucid CL 4.1 keywordパッケージ
CCL 1.11.5 ""パッケージ
CMUCL 21d ""パッケージ
CMUCL 17f ""パッケージ
SBCL 1.5.7 ""パッケージ
AKCL 1.619 ""パッケージ
GCL ""パッケージ
ECL ""パッケージ
MkCL ""パッケージ

Allegro CLと、Lucid CLは、(find-package "")でkeywordパッケージを返してきます。
パッケージ名の部分が空であればkeywordパッケージとする、という解釈もそれはそれで整合性がありそうではあります。

リーダーの読み取りの挙動が違っているのかと思いましたが、ちょっと調べてみたら、Allegro CLもLucid CLもニックネームに""が指定されているだけでした。

(package-nicknames :keyword)("")

ANSI CL規格を確認してみると、keywordパッケージのニックネームはnoneとなっていて拡張の余地がありそうな記述もないので、処理系の独自拡張ということになりそうです。

まとめ

なかなか面白い処理系拡張です。

(intern "X" "KEYWORD")
→ :x 
   :external 

よりも、

(intern "X" "")
→ :x 
   :external 

の方が直感的な気がしなくもありません。

(rename-package :keyword :keyword '(""))

によってお手軽に実現できますが、""パッケージが使えなくなるので注意しましょう(そんなパッケージ名使われないか)


HTML generated by 3bmd in LispWorks 7.1.2

Allegro CLのfixed-indexスロットアクセスを真似してみる

Posted 2019-10-14 19:51:18 GMT

先日、RedditでAllegro CLのstandard-objectのスロットのアクセスを高速化するオプションについての投稿があり、記事を読んでみたのですが、

第一感としては、何故standard-instance-accessを使わないのだろうか、というところでした。

それとは別にfixed-indexを新機能として紹介していますが、どうも以前にみたことあるなと思ったので、古いAllegro CL 4.3(1996)を確認してみましたが、やはり存在しました。 (パッケージは、closexclで移動した模様)
昔からの隠し機能が公になった、というところなのかもしれません。

;;; Allegro CL 4.3
(defclass foo ()
  ((a :initarg :a clos::fixed-index 2 :accessor foo-a)
   (b :initarg :b clos::fixed-index 3 :accessor foo-b)
   (c :initarg :c :accessor foo-c)))

(defvar *foo-inst* (make-instance 'foo :a 1 :b 2 :c 3))

(defvar *vec* (clos::std-instance-slots *foo-inst*))

USER(13): *vec* #(3 CLOS::..SLOT-UNBOUND.. 1 2) ...

fixed-index系 と standard-instance-access 系は何が違うのか

fixed-index指定は、オブジェクトのスロットの値を保持しているベクタの位置を直に指定するもので、それに加えて、指定されたfixed-indexの最大値とスロットの総数で大きい方をバックエンドのベクタのサイズにするようです。
指定されていない空き地は#<unbound-marker>のようなもので埋まります。

Allegro CLでもAMOPのstandard-instance-accessslot-definition-locationはサポートしており、fixed-indexの値とも連動しています。
fixed-indexが簡単に実装できないか、standard-instance-access & slot-definition-location 系の処理系を眺めてみましたが、大抵はスロット数のサイズのベクタを隙間なく並べ、先頭から番号を振るようです。

fixed-indexを真似してみる

スロットの値を保持するベクタの確保の方法が難という感じですが、とりあえずLispWorks等で真似できるか試してみます。

(ql:quickload :closer-mop))

(defpackage "4fef36ee-23f6-5dff-beb9-070053d5dbbb" (:use :c2cl))

(in-package "4fef36ee-23f6-5dff-beb9-070053d5dbbb")

;; 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) ())

(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs) (declare (ignore initargs)) <fixed-index-direct-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>) (setf (slot-definition-location effective-slotd) (slot-definition-fixed-index slotd)) (return))) effective-slotd))

(defmethod compute-slots ((class fixed-index-slot-class)) (let* ((slots (call-next-method))) (loop :for idx :from 0 :repeat (length slots) :do (let* ((s (find idx slots :key #'slot-definition-location))) (unless s (let ((s (find-if (lambda (x) (null (slot-definition-location x))) slots))) (when s (setf (slot-definition-location s) idx)))))) (sort (copy-list slots) #'< :key #'slot-definition-location)))

ちなみに、 effective-slot-definition-class周りを定義していませんが、スロットの順番を指定するだけなので、effective-slotfixed-indexの値を持たせていません。
(アロケーション〜初期化周りを実装するにあたって必要になりそうではあります。)

再現しようとした結果: 飛び飛びに値を保持するベクタをバックエンドにする方法が分からない

→ 方法が分かったので別記事を書きました: Allegro CLのfixed-indexスロット再現リベンジ

上記では、fixed-indexでスロット群の並び順を指定することはできたのですが、LispWorksではアロケーションされたベクタをAllegro CLのfixed-indexの要件を満すように読み書きする方法が分からず仕舞でした。
SBCLはソースが読めるので、そのうち確認してみたいところ。

とりあえず、Allegro CLのfixed-index記事の御題目としては高速化が目的のようなので、速度を計測してみます。

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

;; test
(defparameter *foo-inst* (a <foo> :a 1 :b 2 :c 3))

(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))

(declaim (simple-vector std-instance-slots)) (defparameter *vec* (std-instance-slots *foo-inst*))

(locally (declare (optimize (safety 1) (space 1) (speed 3) (debug 0) (compilation-speed 0))) (defun p1 () (dotimes (i 10000000) (signum (foo-a *foo-inst*)))) (defun p2 () (dotimes (i 10000000) (signum (slot-value *foo-inst* 'a)))) (defun p3 () (dotimes (i 10000000) (signum (svref *vec* 1)))) (defun p4 () (dotimes (i 10000000) (signum (svref (std-instance-slots *foo-inst*) 1)))) (defun p5 () (dotimes (i 10000000) (signum (standard-instance-access *foo-inst* 1)))) )

(progn (time (p1)) (time (p2)) (time (p3)) (time (p4)) (time (p5)) )

LispWorksの場合

LispWorksではバックエンドのベクタをアクセスする方法がstandard-instance-accessなので、Allegro CLの記事のようにバックエンドをベクタを直接取り出してアクセスしたのとほぼ同一な結果になります。
standard-instance-accessがアクセサの60倍強となりAllegro CLの記事の御題目と似たものとなりました。

Timing the evaluation of (p1)

User time = 1.870 System time = 0.000 Elapsed time = 1.868 Allocation = 10816 bytes 0 Page faults ; (top-level-form 15) Timing the evaluation of (p2)

User time = 1.630 System time = 0.000 Elapsed time = 1.619 Allocation = 17584 bytes 0 Page faults ; (top-level-form 15) Timing the evaluation of (p3)

User time = 0.030 System time = 0.000 Elapsed time = 0.033 Allocation = 13184 bytes 0 Page faults ; (top-level-form 15) Timing the evaluation of (p4)

User time = 0.040 System time = 0.000 Elapsed time = 0.035 Allocation = 0 bytes 0 Page faults ; (top-level-form 15) Timing the evaluation of (p5)

User time = 0.040 System time = 0.000 Elapsed time = 0.039 Allocation = 0 bytes 0 Page faults

SBCLの場合

SBCLでは、アクセサもslot-valuestandard-instance-accessでのアクセスと同等まで最適化されるので、どれも速いという結果になりました。
良く考えればこれが理想では?

Evaluation took: (p1)
  0.050 seconds of real time
  0.050000 seconds of total run time (0.050000 user, 0.000000 system)
  100.00% CPU
  163,816,326 processor cycles
  0 bytes consed

Evaluation took: (p2) 0.044 seconds of real time 0.050000 seconds of total run time (0.050000 user, 0.000000 system) 113.64% CPU 145,140,144 processor cycles 0 bytes consed

Evaluation took: (p3) 0.020 seconds of real time 0.020000 seconds of total run time (0.020000 user, 0.000000 system) 100.00% CPU 68,159,274 processor cycles 1,712 bytes consed

Evaluation took: (p4) 0.022 seconds of real time 0.020000 seconds of total run time (0.020000 user, 0.000000 system) 90.91% CPU 71,779,470 processor cycles 0 bytes consed

Evaluation took: (p5) 0.021 seconds of real time 0.020000 seconds of total run time (0.020000 user, 0.000000 system) 95.24% CPU 69,904,809 processor cycles 0 bytes consed

まとめ

Allegro CLのfixed-index機能は面白いとは思うのですが、高速化ということに限っては、SBCLのように何も指定しなくても、 standard-instance-access を使ったのと同等の所まで最適化してくれる方が望ましいでしょう。
fixed-indexでは、特定の位置に特定のデータを配置したものをクラスを跨いで同一のアクセス方法で処理できたりしそうなので、もっと他の使い方があるのでは……、などと思ったり……。


HTML generated by 3bmd in LispWorks 7.0.0

eval-whenのおさらい

Posted 2019-10-07 21:08:30 GMT

Common Lispでは、実行時、コンパイル時、リード時、その他色々なタイミングでの評価を活用しますが、その制御に専ら使われるのが、eval-whenです。

といっても、大抵eval-whenを使わないか、(:compile-toplevel :execute :load-toplevel)を全部付けるかです。

実際の所は全部盛りを知っていれば問題ないのですが、入れ子になった場合や、全部盛り以外の組み合わせの挙動を確認してみようかなと思います。

指定の組み合わせを眺めてみる

こんな感じのコードで、適当なファイルに組み合わせを書き出します。

(setf (logical-pathname-translations "tem")
      '(("**;*.*.*" "/tmp/**/*.*")))

(with-open-file (*standard-output* "tem:ew.lisp" :direction :output :if-does-not-exist :create :if-exists :supersede) (pprint (cons 'progn (loop :for w :in '((progn) (eval-when (:execute)) (eval-when (:compile-toplevel)) (eval-when (:load-toplevel))) :collect `(,@w (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 ',w) (terpri)) ,@(loop :for i :from 0 :for x :in '(nil (:compile-toplevel) (:compile-toplevel :load-toplevel) (:load-toplevel) (:compile-toplevel :execute) (:compile-toplevel :execute :load-toplevel) (:execute) (:execute :load-toplevel)) :collect `(eval-when ,x (prin1 '(,i ,x)) (terpri))))))))

書き出した内容

(progn
  (progn
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(progn)) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:execute)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:execute))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:compile-toplevel)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:compile-toplevel))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:load-toplevel)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:load-toplevel))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri))))

書き出したコードを実際にコンパイルしたりロードしたりで実行してみます。

(progn
  (format T "~2&================ :execute~%")
  (load "tem:ew.lisp" :verbose nil)
  (format T "~2&================ :compile-toplevel~%")
  (compile-file "tem:ew.lisp" :verbose nil :print nil)
  (format T "~2&================ :load-toplevel~%")
  (load "tem:ew" :verbose nil :print nil))

結果の確認

上記の結果を評価タイミングごとに眺めていきます。
なお、-toplevelと付いていることからも想像できるように、:compile-load-はトップレベルに置かれないと評価されません。
また、eval-whenの中はトップレベルなので、入れ子にしてもトップレベル扱いです。

:execute

executeは、実行時の評価です。
式をevalしたり、コンパイルしていないソースファイルをloadした場合のフェイズといえるでしょう。

================ :execute
(progn)
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(6 (:execute))
(7 (:execute :load-toplevel))

(eval-when (:execute)) (4 (:compile-toplevel :execute)) (5 (:compile-toplevel :execute :load-toplevel)) (6 (:execute)) (7 (:execute :load-toplevel))

トップレベルの式、もしくは :executeが含まれたeval-whenの中だけ評価されているのが分かります。

:compile-toplevel

:compile-toplevelは、コンパイル時です。eval-whenの直下のフォームと入れ子になった:executeが評価されます。
ややこしいのが、コンパイル時には、eval-when:load-toplevel指定の中身も見る(=コンパイルする)ことですが、中身は見ますが、内側に:compile-toplevelを指定しないとコンパイル時には評価されません。

================ :compile-toplevel
(progn)
(1 (:compile-toplevel))
(2 (:compile-toplevel :load-toplevel))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))

(eval-when (:compile-toplevel)) (4 (:compile-toplevel :execute)) (5 (:compile-toplevel :execute :load-toplevel)) (6 (:execute)) (7 (:execute :load-toplevel))

(eval-when (:load-toplevel)) (1 (:compile-toplevel)) (2 (:compile-toplevel :load-toplevel)) (4 (:compile-toplevel :execute)) (5 (:compile-toplevel :execute :load-toplevel))

:load-toplevel

:load-toplevelは、コンパイル済みのファイルであるfaslをロードした場合の評価フェイズです。
ロードというと色々ややこしいので、以降、fasloadと呼びます。
fasloadの場合は、:load-toplevelを入れ子にすれば、:load-toplevelの中は評価しますが、:executeの中身はみません。
上述のように:compile-toplevelは入れ子にしても機能しますが、それはコンパイル時に評価されるものなのでfasload時には評価されません。

================ :load-toplevel
(progn)
(2 (:compile-toplevel :load-toplevel))
(3 (:load-toplevel))
(5 (:compile-toplevel :execute :load-toplevel))
(7 (:execute :load-toplevel))

(eval-when (:load-toplevel)) (2 (:compile-toplevel :load-toplevel)) (3 (:load-toplevel)) (5 (:compile-toplevel :execute :load-toplevel)) (7 (:execute :load-toplevel))

応用の考察

マクロ展開時限定で何かを評価するには

マクロはコンパイル時に展開されますが、実行時でも展開される可能性はある(インタプリタ動作の場合)ので下記のようになるでしょうか。
fasloadではコンパイル済みの筈なので、マクロ展開が起きることはありません。

(eval-when (:compile-toplevel :execute)
  ....)

マクロ展開時限定で何かしたいことがあれば……ですが。

defpackageのシンボル汚染問題を解消する

defpackage展開用のパッケージを作成して、コンパイル時のみの評価とすれば、fasload時には展開用のパッケージは存在しなくても良いことになります。

;;; tem:zzz.lisp ファイル
(in-package :cl-user)

(eval-when (:compile-toplevel) (defpackage "bfa90b48-5531-5245-9256-8dfb8d9119f3" (:use :cl)) (in-package "bfa90b48-5531-5245-9256-8dfb8d9119f3"))

(defpackage foo (:use cl) (:intern a b c))

(compile-file "tem:zzz")
(delete-package "bfa90b48-5531-5245-9256-8dfb8d9119f3")
(load "tem:zzz")

(list (find-symbol "A" :cl-user) (find-symbol "B" :cl-user) (find-symbol "C" :cl-user) (find-symbol "A" :foo))(nil nil nil foo::a)

良く考えれば、コンパイル時にdefpackageによって使われたシンボルも、別のイメージにfasloadした時には居なくても良いので、cl-userで書いたのと大した違いはないですね。
そう考えると、defpackageのシンボル汚染問題もコンパイル時のイメージ限定なのかなと。

まとめ

はまり所としては、

  • :load-toplevelの中の:compile-toplevelがコンパイル時に評価されるというのがややこしい
  • loadという関数名と、:load-toplevelという名前が誤解を招く

    • loadlispファイルを読み込めば:execute
    • loadfaslファイルを読み込めば:load-toplevel

位でしょうか。

昔のLispでは、faslを読むのにはfasloadという専用関数が使われ、コンパイルしていないファイルにはloadを使ったりしていたようですが、Common Lispでloadに一本化されたようですね。

以上、eval-whenの考察でした。


HTML generated by 3bmd in LispWorks 7.0.0

Older entries (2312 remaining)