簡易スレッド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)))))
|#