ビットリバース

割合汎用的な、整数のビットを前後反転する関数を作成してみた。
2の乗数サイズの任意の整数型のビット反転が可能。

// 反転例
bit_reverse(0x0000FFFF) => 0xFFFF0000
// 実装

// バイト単位での変換表
const unsigned char REV_BYTE[]={
  0,128,64,192,32,160,96,224,16,144, 80,208,48,176,112,240,8,136,72,200,
  40,168,104,232,24,152,88,216,56,184,120,248,4,132,68,196,36,164,100,228,
  20,148,84,212,52,180,116,244,12,140,76,204,44,172,108,236,28,156,92,220,
  60,188,124,252,2,130,66,194,34,162,98,226,18,146,82,210,50,178,114,242,
  10,138,74,202,42,170,106,234,26,154,90,218,58,186,122,250,6,134,70,198,
  38,166,102,230,22,150,86,214,54,182,118,246,14,142,78,206,46,174,110,238,
  30,158,94,222,62,190,126,254,1,129,65,193,33,161,97,225,17,145,81,209,
  49,177,113,241,9,137,73,201,41,169,105,233,25,153,89,217,57,185,121,249,
  5,133,69,197,37,165,101,229,21,149,85,213,53,181,117,245,13,141,77,205,
  45,173,109,237,29,157,93,221,61,189,125,253,3,131,67,195,35,163,99,227,
  19,147,83,211,51,179,115,243,11,139,75,203,43,171,107,235,27,155,91,219,
  59,187,123,251,7,135,71,199,39,167,103,231,23,151,87,215,55,183,119,247,
  15,143,79,207,47,175,111,239,31,159,95,223,63,191,127,255};

// リバースクラス
template <int BYTE_SIZE> 
struct bit_rev {
  static const int HALF_SIZE = BYTE_SIZE/2;
  static const int HALF_BITS = HALF_SIZE*8;
  
  // BYTE_SIZEが1以外なら、上位ビットと下位ビットに再帰的に処理を適用した後に、二つを入れ替える
  template <typename T>
  static T reverse(T n) {
    return 
      (bit_rev<HALF_SIZE>::reverse(n) << HALF_BITS) | 
      (bit_rev<HALF_SIZE>::reverse(n>>HALF_BITS));
  }  
};

// BYTE_SIZEが1ならテーブルを参照して、バイトを変換する
template <> struct bit_rev<1> {
  template <typename T>
  static T reverse(T n) {
    return REV_BYTE[n&0xFF];
  }
};

// インターフェース関数
template <typename T>
T bit_reverse(T n) {
  return bit_rev<sizeof(T)>::reverse(n);
}

サンプルコマンド:

/**
 * ファイル名: rev.cc
 * コンパイル: g++ -o rev rev.cc
 */
#include <iostream>

/*
 bit_reverse関数定義
 */

int main() {
  unsigned char n08 = 0x0F;
  unsigned short n16 = 0x009F;
  unsigned int n32 = 0x0000699F;
  unsigned long long n64 = 0x00000000666699FF;
  
  std::cout.setf(std::ios::hex, std::ios::basefield);
  std::cout.setf( std::ios::showbase );

  std::cout << "n08: " << (long long)n08 << " => " << (long long)bit_reverse(n08) << std::endl;
  std::cout << "n16: " << (long long)n16 << " => " << (long long)bit_reverse(n16) << std::endl;
  std::cout << "n32: " << (long long)n32 << " => " << (long long)bit_reverse(n32) << std::endl;
  std::cout << "n64: " << (long long)n64 << " => " << (long long)bit_reverse(n64) << std::endl;
  return 0;
}

実行結果:

$ ./rev
n08: 0xf => 0xf0
n16: 0x9f => 0xf900
n32: 0x699f => 0xf9960000
n64: 0x666699ff => 0xff99666600000000

自分の環境で軽く試した感じでは、ビット演算のみを使用して手書きで最適化したものと同等以上の速度が出ていた。

フィールドのポインタから、オブジェクト全体のポインタを取得するためのマクロ

構造体やクラスのインスタンスの特定のフィールドのアドレス(ポインタ)だけ分かっている場合に、そこからオブジェクト全体のポインタを取得したい場合に使うマクロ。
やっていることは単にフィールドのアドレスから、そのフィールドの(クラスor構造体の)先頭からのオフセットを引いているだけ。

// type.fieldが、typeの先頭の何バイト目に配置されているかを求める
#define field_offset(type, field) \
  ((char*)&(((type*)NULL)->field) - (char*)NULL)

// type.filedのアドレス(field_ptr)から、fieldのオフセット分マイナスし、typeのアドレスを求める
#define obj_ptr(type, field, field_ptr) \
  ((type*)((char*)field_ptr - field_offset(type, field)))

メモリアロケータを自作する際に、割当メモリ領域にタグ付けするのに利用できそうだと思い作成。

/* main.cc */
#include <iostream>

// タグ付きメモリチャンク
struct chunk {
  struct {            // タグ情報:
    const char* type; // - 型名
    int size;         // - サイズ
  } tag;
  void* buf;
};

// メモリ割り当て
inline void* mem_allocate(const char* type, int size) {
  chunk* c = (chunk*)new char[sizeof(chunk::tag)+size];

  // タグ情報を保存する
  c->tag.type = type;
  c->tag.size = size;

  std::cout << "[" << c->tag.type << "] allocate: " << c->tag.size << " bytes" << std::endl;

  // 割り当てアドレスを返す
  return &c->buf;
}

// メモリ解放
void mem_free(void* p) {
  // 解放するアドレス(chunk::buf)から、タグ情報(chunk)を取得する
  chunk* c = obj_ptr(chunk, buf, p);
  std::cout << "[" << c->tag.type << "] free: " << c->tag.size << " bytes" << std::endl;
  delete c;
}

struct abc {
  int a;
  char b;
  long c;
};

// main関数
int main() {
  void* ptrs[3];

  std::cout << "# allocate:" << std::endl;
  ptrs[0] = new (mem_allocate("int", sizeof(int))) int;
  ptrs[1] = new (mem_allocate("pointer", sizeof(void*))) void*;
  ptrs[2] = new (mem_allocate("struct", sizeof(abc))) abc;
  
  std::cout << std::endl;
  std::cout << "# free:" << std::endl;
  for(int i=2; i >=0; i--)
    mem_free(ptrs[i]);

  return 0;
}
$ g++ -o main main.cc
$ ./main
# allocate:
[int] allocate: 4 bytes
[pointer] allocate: 8 bytes
[struct] allocate: 16 bytes

# free:
[struct] free: 16 bytes
[pointer] free: 8 bytes
[int] free: 4 bytes

Cの定数値や型のサイズを取得するための関数

sb-alienパッケージとかを使ってネイティブライブラリを使用していると、ちょくちょくCの定数の値や型の定義(型のサイズ)を知りたくなることがある。
毎回ヘッダファイルを調べるのも面倒なので、lisp上から取得出来るように関数を用意してみた。

(defun c-inspect (&key include type value)       
  (flet ((gen-source ()
           (with-output-to-string (out)
             (format out "~&#include <iostream>~%")
             (dolist (inc include)
               (format out "~&#include <~a>~%" inc))

             (format out "~%int main() {~%")
             (dolist (ty type)
               (format out "  std::cout << \"sizeof(~a) = \" << sizeof(~a) << std::endl;~%" ty ty))

             (dolist (val value)
               (format out "  std::cout << \"~a = \" << ~a << std::endl;~%" val val))
             
             (format out "}~%"))))
    ;; 定数や型の情報を出力するためのC++ソースを生成
    (with-input-from-string (in (gen-source))
      ;; 生成したソースをコンパイル 
      (let ((ret (sb-ext:run-program "g++" `("-x" "c++" "-" "-o" "/tmp/c.inspect.tmp")
                                     :search t :input in :output t)))
        ;; コンパイルに成功しているなら、コマンドを実行
        (when (zerop (sb-ext:process-exit-code ret))
          (sb-ext:run-program "/tmp/c.inspect.tmp" '() :output t)))))
  (values))

使用例。

> (c-inspect :type '("int" "unsigned long" "void *") :value '("NULL"))
sizeof(int) = 4
sizeof(unsigned long) = 8
sizeof(void *) = 8
NULL = 0

> (c-inspect :include '("sys/socket.h") :value '("PF_UNIX" "SO_ACCEPTCONN" "SO_ERROR"))
PF_UNIX = 1
SO_ACCEPTCONN = 30
SO_ERROR = 4

;; エラー
> (c-inspect :type '("undefined_type"))
<stdin>: In function ‘int main()’:
<stdin>:4: error: ‘undefined_type’ was not declared in this scope

ユニコード文字列をバイトストリームとして扱うためのパッケージ

タイトル通りのパッケージ。
実装の前に使用例。

;;;; sbcl-1.0.49
;; 例で使用する文字列(および対応するバイト列)
(sb-ext:string-to-octets "下書き")
--> #(228 184 139 230 155 184 227 129 141)

;; 作成
(defparameter *in* (octet-stream:make "下書き"))
--> *in*

;; 一バイト先読みする
(octet-stream:peek *in*)
--> 228

;; 一バイト読み込む
(octet-stream:read *in*)
--> 228

(octet-stream:read *in*)
--> 184

(octet-stream:peek *in*)
--> 139

;; 一バイト読み捨てる
(octet-stream:eat *in*)
--> #S(OCTET-STREAM::OCTET-STREAM
        :SRC "下書き" :POS 1
        :END 3 :CODE 26360
        :OCTET-POS 3 :OCTET-LEN 3)

(octet-stream:peek *in*)
--> 230

;; 終端判定
(octet-stream:eos? *in*)
--> NIL

実装:

(defpackage octet-stream
  (:use :common-lisp)
  (:shadow :common-lisp read peek position)
  (:export make
           read
           peek
           eos?
           eat
           position))
(in-package :octet-stream)

;;;;;;;;;;;;;;;;
;;; declaration
(declaim (inline make-octet-stream make eos? octet-length peek read eat position))

;;;;;;;;;;;;;;;;;;;
;;; type definition
(deftype array-index () `(mod ,array-dimension-limit))
(deftype simple-characters () '(simple-array character))
(deftype unicode () `(mod ,char-code-limit))

;;;;;;;;;;;;;;;;
;;; octet-stream
(defstruct octet-stream
  (src      "" :type simple-characters)
  (pos       0 :type array-index)
  (end       0 :type array-index)
  (code      0 :type unicode)
  (octet-pos 0 :type (mod 5))
  (octet-len 0 :type (mod 5)))

;;;;;;;;;;;;;;;;;;;;;;
;;; auxiliary function
(defun octet-length (code)
  (declare (unicode code))
  (cond ((< code #x80)    1)
        ((< code #x800)   2)
        ((< code #x10000) 3)
        (t                4)))

;;;;;;;;;;;;;;;;;;;;;
;;; external function
(defun position (in)  ; 現在位置 (バイト単位ではなく文字単位)
  (octet-stream-pos in))

(defun make (string &key (start 0) (end (length string)))
  (declare (simple-characters string)
           (array-index start end))
  (let* ((code (if (= start (length string)) 
                  0
                (char-code (char string start))))
         (len (octet-length code)))
    (make-octet-stream :src string :pos start :end end
                       :code code :octet-pos len :octet-len len)))

(defun eos? (in)
  (with-slots (pos end) (the octet-stream in)
    (= pos end)))

;; 一バイト分先読みする。(eos? in)が真の時に呼び出された場合、返す値は未定義。
(defun peek (in)
  (with-slots (code octet-pos octet-len) (the octet-stream in)
    (if (= octet-pos octet-len)
        (case octet-len
            (1 code)
            (2 (+ #b11000000 (ldb (byte 5  6) code)))
            (3 (+ #b11100000 (ldb (byte 4 12) code)))
            (t (+ #b11110000 (ldb (byte 3 18) code))))
      (+ #b10000000 (ldb (byte 6 (* (the (mod 4) (1- octet-pos)) 6)) code)))))

(defun eat (in)
  (with-slots (src pos code octet-pos octet-len) (the octet-stream in)
    (decf octet-pos)
    (when (zerop octet-pos)
      (incf pos)
      (unless (eos? in)
        (setf code (char-code (char src pos))
              octet-len (octet-length code)
              octet-pos octet-len))))
  in)

(defun read (in)
  (prog1 (peek in)
    (eat in)))

簡易的なカウントダウンラッチ

後々使いたいので、簡単なカウントダウンラッチを作成してみた。
ウェイトは単純なスピンで実装しているのであまり実用的ではないけど、お試し用途であれば十分(だと思う)

(defpackage countdown-latch 
  (:use :common-lisp)
  (:export make
           countdown-and-await))
(in-package :countdown-latch)

(defstruct latch 
  (count 0 :type fixnum))

;; 作成
(defun make (count)
  (make-latch :count (max 0 count)))

(defmacro barrier (exp)
  `(sb-thread:barrier (:data-dependency) ,exp))

(defun atomic-decriment-if-plus (latch)
  (let* ((old (latch-count latch))
         (new (1- old)))
    (when (plusp old)
      (unless (eq old (sb-ext:compare-and-swap (latch-count latch) old new))
        (atomic-decriment-if-plus latch)))))

;; 一つカウントダウンした後、カウントが0になるまで待機する
(defun countdown-and-await (latch)
  (atomic-decriment-if-plus latch)
  (loop UNTIL (barrier (zerop (latch-count latch)))))  ; spin wait

使用例:

;;; sbcl-1.0.49(x86_64)
;;; 関数準備

;; メッセージ出力用関数
;; 複数スレッドの出力の混在を防ぐためにミューテックス内でformat関数を呼び出す
(let ((io-mutex (sb-thread:make-mutex)))
  (defun message (fmt &rest args)
    (sb-thread:with-mutex (io-mutex)
      (apply #'format t fmt args))))

;; 各スレッド用の関数
;; 各ラッチ通過毎にメッセージを出力する
(defun do-process (id latches)
  (message "~&; <~a> START~%" id)
  (loop FOR latch IN latches
        FOR i FROM 0
    DO
    (sleep (random 1.0))                          ; 処理時間にばらつきを持たせるために、適当な時間スリープさせる
    (countdown-latch:countdown-and-await latch)   ; カウントダウン & 待機
    (message "~&; <~a> PASSED: latch~d~%" id i))) ; 通過

;; スレッド数とラッチ数を指定してdo-process関数を実行する
(defun test (thread-num latch-num)
  (let ((latches (loop REPEAT latch-num COLLECT (countdown-latch:make thread-num))))
    (loop FOR thread-id FROM 0 BELOW thread-num
          COLLECT
          (sb-thread:make-thread (lambda () (do-process thread-id latches)))
          INTO threads
          FINALLY
          (mapc #'sb-thread:join-thread threads) ; 全スレッドの終了を待機
          (return 'done))))
;;; 実行: スレッド数=5, ラッチ数=3
> (test 5 3)
; <0> START
; <1> START
; <2> START
; <3> START
; <4> START
; <2> PASSED: latch0
; <1> PASSED: latch0
; <3> PASSED: latch0
; <4> PASSED: latch0
; <0> PASSED: latch0 ; 全スレッドがラッチ0を通過
; <4> PASSED: latch1
; <2> PASSED: latch1
; <3> PASSED: latch1
; <1> PASSED: latch1
; <0> PASSED: latch1 ; 全スレッドがラッチ1を通過
; <0> PASSED: latch2
; <4> PASSED: latch2
; <3> PASSED: latch2
; <1> PASSED: latch2
; <2> PASSED: latch2 ; 全スレッドがラッチ2を通過
DONE

簡易スレッドID取得関数(+SBCLでのTLS)

実行中のスレッドがN個あるとして、そのそれぞれに0からN-1のID値を割り振る関数を作成した。

(defpackage thread-id
  (:use :common-lisp)
  (:shadow :common-lisp get)
  (:export get))
(in-package :thread-id)

(define-symbol-macro *id* (tls:symbol-value '*id*))

(defun get ()
  (values (or *id* 
              (setf *id* (calc-id)))))

(defun calc-id ()
  ;; スレッドID == 全スレッドのリスト内での位置
  (position sb-thread:*current-thread*
            (reverse (sb-thread:list-all-threads))
            :test #'eq))

TLS(Thread Local Storage)の使用以外は、特に変わった点はない。
tlsパッケージについては後述

> (thread-id:get)
--> 0

> (loop REPEAT 10
        DO
        (sb-thread:make-thread
         (lambda ()
           (format t "; ~a: id=~a~%" sb-thread:*current-thread* (thread-id:get))
           (force-output)
           (sleep 1))))
; #<THREAD RUNNING {100318FDA1}>: id=1
; #<THREAD RUNNING {100318FF11}>: id=2
; #<THREAD RUNNING {1003198091}>: id=3
; #<THREAD RUNNING {1003198201}>: id=4
; #<THREAD RUNNING {1003198371}>: id=5
; #<THREAD RUNNING {10031984E1}>: id=6
; #<THREAD RUNNING {1003198651}>: id=7
; #<THREAD RUNNING {10031987C1}>: id=8
; #<THREAD RUNNING {1003198931}>: id=9
; #<THREAD RUNNING {1003198AA1}>: id=10
--> NIL

tlsパッケージの定義は以下の通り。
基本的にhttp://paste.lisp.org/display/63257に掲載されているコードを、ほぼそのまま借用させてもらっている。

(defpackage tls
  (:use :common-lisp :sb-vm :sb-sys :sb-kernel)
  (:shadow :common-lisp symbol-value)
  (:export global-binding-p
           symbol-value))
(in-package :sb-vm)

;; see cell.lisp:symbol-value
(define-vop (tls::tls-ref)
  (:args (index :scs (descriptor-reg)))
  (:results (value :scs (descriptor-reg)))
  #+x86-64
  (:generator 5
    (inst mov value (make-ea :qword
                             :base thread-base-tn
                             :index index :scale 1)))
  #+x86
  (:generator 5
    (inst fs-segment-prefix)
    (inst mov value (make-ea :dword :base index))))

(define-vop (tls::tls-set)
  (:args (value :scs (descriptor-reg))
         (index :scs (descriptor-reg)))
  (:results)
  #+x86-64
  (:generator 5
    (inst mov (make-ea :qword
                       :base thread-base-tn
                       :index index :scale 1)
          value))
  #+x86
  (:generator 5
    (inst fs-segment-prefix)
    (inst mov (make-ea :dword :base index) value)))

(define-vop (tls::%set-symbol-global-value)
  (:args (value  :scs (descriptor-reg))
         (symbol :scs (descriptor-reg)))
  (:results)
  #+(or x86-64 x86)
  (:generator 5
     (storew value symbol symbol-value-slot other-pointer-lowtag)))
(in-package :tls)

(defun global-binding-p (symbol)
  "Simply check that the symbol has no tls index,
   or that the tls slot is empty."
  (declare (type symbol symbol))
  (let ((index (sb-vm::symbol-tls-index symbol)))
    (or (zerop index)
        (eq (%primitive tls-ref index)
            (%make-lisp-obj no-tls-value-marker-widetag)))))

(defun ensure-tls-index (symbol)
  (declare (type symbol symbol))
  (let ((index (sb-vm::symbol-tls-index symbol)))
    (unless (zerop index)
      (return-from ensure-tls-index index)))
  ;; HACK make sure an index gets allocated.
  (progv (list symbol) (list nil)
    (sb-vm::symbol-tls-index symbol)))

(defun symbol-value (symbol)
  (declare (type symbol symbol))
  (let ((value (%primitive tls-ref (ensure-tls-index symbol))))
    (if (eq value (%make-lisp-obj no-tls-value-marker-widetag))
        (values nil nil)
        (values value t))))

(defun (setf symbol-value) (value symbol)
  (prog1 value
    (%primitive tls-set value (ensure-tls-index symbol))))

#|
(defmacro define-thread-local-value (name value)
  `(define-symbol-macro ,name 
     (values (or (tls:symbol-value ',name)
                 (setf (tls:symbol-value ',name) ,value)))))
|#

ネイティブバイトオーダー取得ユーティリティファイル

マシンのネイティブのバイトオーダーを自動的に判定できるユーティリティ関数があると便利かと思ったので作成してみた。

;# <- バイトオーダー判定用文字列
;; ファイル名: byte-order.lisp
(defun guess-byte-order (sample-file)
  (with-open-file (1byte sample-file :element-type '(unsigned-byte 8))
    (with-open-file (2byte sample-file :element-type '(unsigned-byte 16))
      (if (= (read-byte 2byte)
             (+ (ash (read-byte 1byte) 8) (read-byte 1byte)))
          :big-endian
        :little-endian))))

(defparameter *native-byte-order* (guess-byte-order *LOAD-PATHNAME*))

上のファイルをロードすると、その環境のバイトオーダーを保持する*native-byte-order*変数が自動的に定義される。

(load "byte-order.lisp")
--> T

*native-byte-order*
--> :LITTLE-ENDIAN


ちなみにsbcl(1.0.44)の場合はsb-c:*backend-byte-order*という変数が同様の情報を保持していた。

sb-c:*backend-byte-order*
--> :LITTLE-ENDIAN