#:g1: コンパクトなスロットの紹介

allocate-instance Advent Calendar 2020 10日目の記事です。

毎度ネタ切れになると、先人の活用事例を参考にしたりライブラリ紹介をしたりしていますが、allocate-instanceに限っては、ほとんど事例がない様子。

メソッドコンビネーションでさえそこそこ事例はあったのに……。

とはいえ、とりあえず一つは見付けたので、そちらの紹介をしてみます。
しかし、どうも実験的なものらしく、プロジェクトのゴミ箱フォルダに入っています。

compact-class

今回紹介するのは、いつも妙なものを作っているhu.dwimの皆さんのhu.dwim.utilの中のcompact-classです。

• hu.dwim.util: compact-class

スロット内容をコンパクトな表現に変換するようですが、とりあえず動作を説明すると、

(defclass foo ()
  ((a :initform nil :allocation :compact :type boolean)
   (b :initform nil :allocation :compact :type boolean)
   (c :initform nil :allocation :compact :type boolean)
   (d :initform nil :allocation :compact :type boolean))
  (:metaclass compact-class))
(let ((obj (make-instance 'foo)))
  (setf (slot-value obj 'a) T)
  (setf (slot-value obj 'b) T)
  (with-slots (a b c d) obj
    (list a b c d
          (instance-slots obj))))
→ (t t nil nil #(3)) 

—のように:allocation :compactを指定するとboolean型のスロット群の(t t nil nil)のコンパクトな表現として、#(3)が格納されます。

(t t nil nil) 反転→ (nil nil t t) → #b0011 → 3

という具合になります。

対応している型と圧縮/解凍の手順ですが、スロットのリーダー/ライターの関数を生成する部分に書いてあります。
ちなみに、SBCLに特化した記述になっていますが、現在のSBCLでは動かないようです。

(def function make-compact-slot-reader (slot)
  (bind ((compact-word-offset (compact-word-offset-of slot))
         (compact-bits-offset (compact-bits-offset-of slot))
         (compact-bit-size (compact-bit-size-of slot))
         (type (slot-definition-type slot)))
    (declare (type (integer 0 #.(integer-length most-positive-fixnum)) compact-bit-size compact-bits-offset)
             (type fixnum compact-word-offset))
    (flet ((%slot-value (instance)
             (declare #.(optimize-declaration))
             (the fixnum (ldb (byte compact-bit-size compact-bits-offset)
                              (the fixnum (standard-instance-access instance compact-word-offset))))))
      (declare (inline %slot-value))
      (cond ((subtypep type 'boolean)
             (lambda (instance)
               (declare #.(optimize-declaration))
               (= (%slot-value instance) 1)))
            ((subtypep type 'integer)
             (lambda (instance)
               (declare #.(optimize-declaration))
               (%slot-value instance)))
            ((subtypep type 'base-char)
             (lambda (instance)
               (declare #.(optimize-declaration))
               (code-char (%slot-value instance))))
            ((subtypep type 'single-float)
             (lambda (instance)
               (declare #.(optimize-declaration))
               #+sbcl (sb-vm::make-single-float (%slot-value instance))))
            ((and (subtypep type 'simple-base-string)
                  (consp type))
             (lambda (instance)
               (declare #.(optimize-declaration))
               (iter (with value = (%slot-value instance))
                     (with string = (make-string (second type)))
                     (for index :from 0 :below (the fixnum (second type)))
                     (for position :initially 0 :then (+ 7 position))
                     (declare (type fixnum index position))
                     (setf (aref string index) (code-char (ldb (byte 7 position) value)))
                     (finally (return string)))))
            (t
             (aif (type-instance-count-upper-bound type)
                  (bind ((instance-list (type-instance-list type)))
                    (lambda (instance)
                      (elt instance-list (%slot-value instance))))
                  (error "Unknown compact type ~A" type)))))))

まとめ

今回は、hu.dwim.utilのcompact-classを紹介してみました。
結構アグレッシブで面白いと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0