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