Menu
▾
▴
[Sbcl-commits] master: Assign thread-local storage indices at load-time on x86-64
|
From: Douglas K. <sn...@us...> - 2014-04-03 05:52:56
|
The branch "master" has been updated in SBCL:
via 4e815e8a8ea12f266699f1e53a94e2303bd19ea8 (commit)
from 5d10937fdec74d6a0dac331940e5a01488391ce7 (commit)
- Log -----------------------------------------------------------------
commit 4e815e8a8ea12f266699f1e53a94e2303bd19ea8
Author: Douglas Katzman <do...@go...>
Date: Thu Apr 3 01:05:05 2014 -0400
Assign thread-local storage indices at load-time on x86-64
This also includes a disassembler enhancement.
---
package-data-list.lisp-expr | 6 ++-
src/code/fop.lisp | 10 +++
src/compiler/dump.lisp | 6 ++-
src/compiler/generic/core.lisp | 5 +-
src/compiler/generic/genesis.lisp | 66 +++++++++++++++++++++-
src/compiler/generic/objdef.lisp | 2 +
src/compiler/generic/parms.lisp | 4 +
src/compiler/generic/vm-fndb.lisp | 3 +
src/compiler/globaldb.lisp | 3 +
src/compiler/ir2tran.lisp | 11 +++-
src/compiler/x86-64/cell.lisp | 100 +++++++++++++++++++++++++++-----
src/compiler/x86-64/insts.lisp | 10 +++-
src/compiler/x86-64/subprim.lisp | 42 ++++++++++++++
src/compiler/x86-64/target-insts.lisp | 48 +++++++++++++++-
src/runtime/interrupt.h | 5 +-
src/runtime/thread.c | 9 ++-
16 files changed, 302 insertions(+), 28 deletions(-)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 741ee93..fdc56a2 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1512,7 +1512,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-SIGNIFICAND"
"FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE"
"EFFECTIVE-FIND-POSITION-TEST"
- "EFFECTIVE-FIND-POSITION-KEY" "ERROR-NUMBER-OR-LOSE"
+ "EFFECTIVE-FIND-POSITION-KEY"
+ "ENSURE-SYMBOL-TLS-INDEX"
+ "ERROR-NUMBER-OR-LOSE"
"EXTENDED-CHAR-P" "EXTERNAL-FORMAT-DESIGNATOR"
"FDEFINITION-OBJECT"
"FDOCUMENTATION" "FILENAME"
@@ -2817,6 +2819,7 @@ structure representations"
#!+long-float "LONG-STACK-SC-NUMBER"
"LOWTAG-LIMIT" "LOWTAG-MASK"
"LRA-SAVE-OFFSET"
+ "MAX-INTERRUPTS"
"MEMORY-USAGE"
"N-LOWTAG-BITS"
"N-FIXNUM-TAG-BITS"
@@ -2908,6 +2911,7 @@ structure representations"
"SYMBOL-HASH-SLOT" "SYMBOL-HEADER-WIDETAG" "SYMBOL-NAME-SLOT"
"SYMBOL-PACKAGE-SLOT" "SYMBOL-INFO-SLOT"
"SYMBOL-SIZE" "SYMBOL-VALUE-SLOT"
+ #!+sb-thread "SYMBOL-TLS-INDEX-SLOT" "SYMBOL-TLS-INDEX"
"*BINDING-STACK-START*"
"*CONTROL-STACK-START*" "*CONTROL-STACK-END*"
"CONTROL-STACK-POINTER-VALID-P"
diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 7da0b74..90fb645 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -648,6 +648,16 @@ a bug.~@:>")
(define-fop (fop-assembler-routine 145)
(error "cannot load assembler code except at cold load"))
+(define-fop (fop-symbol-tls-fixup 146)
+ (let* ((symbol (pop-stack))
+ (kind (pop-stack))
+ (code-object (pop-stack)))
+ (sb!vm:fixup-code-object code-object
+ (read-word-arg)
+ (ensure-symbol-tls-index symbol)
+ kind)
+ code-object))
+
(define-fop (fop-foreign-fixup 147)
(let* ((kind (pop-stack))
(code-object (pop-stack))
diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index e5ada83..18c0a42 100644
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -985,7 +985,11 @@
(dump-byte (char-code (schar name i)) fasl-output))))
(:code-object
(aver (null name))
- (dump-fop 'fop-code-object-fixup fasl-output)))
+ (dump-fop 'fop-code-object-fixup fasl-output))
+ (:symbol-tls-index
+ (aver (symbolp name))
+ (dump-non-immediate-object name fasl-output)
+ (dump-fop 'fop-symbol-tls-fixup fasl-output)))
;; No matter what the flavor, we'll always dump the position
(dump-word position fasl-output)))
(values))
diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp
index 8488eee..dae8c1d 100644
--- a/src/compiler/generic/core.lisp
+++ b/src/compiler/generic/core.lisp
@@ -67,7 +67,10 @@
#!+(or x86 x86-64)
(:code-object
(aver (null name))
- (values (get-lisp-obj-address code) t)))))
+ (values (get-lisp-obj-address code) t))
+ (:symbol-tls-index
+ (aver (symbolp name))
+ (ensure-symbol-tls-index name)))))
(sb!vm:fixup-code-object code position value kind))))
;;; Stick a reference to the function FUN in CODE-OBJECT at index I. If the
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 5e551e1..42a7dc0 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -825,6 +825,27 @@ core and return a descriptor to it."
;;;; symbol magic
+;; A table of special variable names mapped onto 'struct thread'.
+;; All symbols other than these will get their TLS indices assigned
+;; by the fasloader on demand.
+(defvar *thread-slots-as-specials*
+ (let ((ht (make-hash-table :test #'equal)))
+ (dolist (slot (sb!vm::primitive-object-slots
+ (find 'sb!vm::thread sb!vm:*primitive-objects*
+ :key #'sb!vm::primitive-object-name)) ht)
+ ;; It sure seems like *STEPPING* is supposed to be tied to a thread slot
+ ;; because x86-64 code goes to some trouble to use the thread slot instead
+ ;; of *STEPPING* whereas x86 uses *STEPPING* instead of the slot.
+ ;; Out of paranoia, I'm _not_ wiring *STEPPING*'s tls index,
+ ;; exactly like the code in 'thread.c' didn't do.
+ (let ((slot-name (sb!vm::slot-name slot)))
+ (unless (string= slot-name "STEPPING")
+ (let ((sym (if (string= slot-name "ALIEN-STACK-POINTER")
+ "*ALIEN-STACK*" ; FIXME: should be unexceptional
+ (concatenate 'string "*" (string slot-name) "*"))))
+ (setf (gethash sym ht)
+ (ash (sb!vm::slot-offset slot) sb!vm:word-shift))))))))
+
;;; Allocate (and initialize) a symbol.
(defun allocate-symbol (name &key (gspace *dynamic*))
(declare (simple-string name))
@@ -840,6 +861,10 @@ core and return a descriptor to it."
(write-wordindexed symbol sb!vm:symbol-name-slot
(base-string-to-core name *dynamic*))
(write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
+ #!+sb-thread
+ (awhen (gethash name *thread-slots-as-specials*)
+ (write-wordindexed symbol sb!vm:symbol-tls-index-slot
+ (make-random-descriptor it)))
symbol))
;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
@@ -1247,6 +1272,30 @@ core and return a descriptor to it."
(cold-push (cold-cons (cold-intern (car layout)) (cdr layout))
result))))
+;; Simulate *FREE-TLS-INDEX*. This is a count, not a displacement.
+;; In C, sizeof counts 1 word for the variable-length interrupt_contexts[]
+;; but primitive-object-size counts 0, so add 1, though in fact the C code
+;; implies that it might have overcounted by 1. Hmm. Also: we could make
+;; this agnostic of MAX-INTERRUPTS by moving the thread base register up
+;; by TLS-SIZE words and using negative offsets for all dynamically assigned
+;; indices. I didn't want to break too much at once though.
+(defvar *genesis-tls-counter*
+ (+ 1 sb!vm::max-interrupts
+ (sb!vm::primitive-object-size
+ (find 'sb!vm::thread sb!vm:*primitive-objects*
+ :key #'sb!vm::primitive-object-name))))
+
+#!+sb-thread
+;; Assign SYMBOL a tls-index and write it into the target core.
+(defun ensure-symbol-tls-index (symbol)
+ (let* ((cold-sym (cold-intern symbol))
+ (tls-index (read-wordindexed cold-sym sb!vm:symbol-tls-index-slot)))
+ (unless (plusp (descriptor-bits tls-index))
+ (let ((next (prog1 *genesis-tls-counter* (incf *genesis-tls-counter*))))
+ (setq tls-index (make-random-descriptor (ash next sb!vm:word-shift)))
+ (write-wordindexed cold-sym sb!vm:symbol-tls-index-slot tls-index)))
+ (descriptor-bits tls-index)))
+
;;; Establish initial values for magic symbols.
;;;
;;; Scan over all the symbols referenced in each package in
@@ -1276,6 +1325,13 @@ core and return a descriptor to it."
(cold-set '*!initial-layouts* (cold-list-all-layouts))
+ #!+sb-thread
+ (progn
+ (cold-set 'sb!vm::*free-tls-index*
+ (make-random-descriptor (ash *genesis-tls-counter*
+ sb!vm:word-shift)))
+ (cold-set 'sb!vm::*tls-index-lock* (make-fixnum-descriptor 0)))
+
(/show "dumping packages" (mapcar #'car *cold-package-symbols*))
(let ((initial-symbols *nil-descriptor*))
(dolist (cold-package-symbols-entry *cold-package-symbols*)
@@ -2587,6 +2643,14 @@ core and return a descriptor to it."
(write-wordindexed fn sb!vm::simple-fun-info-slot info)
fn))
+(define-cold-fop (fop-symbol-tls-fixup)
+ (let* ((symbol (pop-stack))
+ (kind (pop-stack))
+ (code-object (pop-stack)))
+ (do-cold-fixup code-object (read-word-arg) (ensure-symbol-tls-index symbol)
+ kind)
+ code-object))
+
(define-cold-fop (fop-foreign-fixup)
(let* ((kind (pop-stack))
(code-object (pop-stack))
@@ -2820,7 +2884,7 @@ core and return a descriptor to it."
(maybe-record-with-munged-name "-TRAP" "trap_" 3)
(maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
(maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
- (maybe-record-with-translated-name '("-SIZE") 6)
+ (maybe-record-with-translated-name '("-SIZE" "-INTERRUPTS") 6)
(maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES"
"-CARD-BYTES" "-GRANULARITY")
7 :large t)
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index 9b3a516..f9d584d 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -417,6 +417,8 @@
(control-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
(control-stack-end :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
(control-stack-guard-page-protected)
+ ;; TODO: Placing these adjacent to binding-stack would make them addressable
+ ;; with a 1-byte displacement on x86-64.
(alien-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
(alien-stack-pointer :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
#!+win32 (private-events :c-type "struct private_events" :length 2)
diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp
index 46761f2..0737fea 100644
--- a/src/compiler/generic/parms.lisp
+++ b/src/compiler/generic/parms.lisp
@@ -197,6 +197,10 @@
;;; Number of entries in the thread local storage. Limits the number
;;; of symbols with thread local bindings.
(def!constant tls-size 4096)
+;;; Refer to the lengthy comment in 'src/runtime/interrupt.h' about
+;;; the choice of this number. Rather than have to two copies
+;;; of the comment, please see that file before adjusting this.
+(def!constant max-interrupts 1024)
#!+gencgc
(progn
diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 0b123d7..4416b8b 100644
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -246,6 +246,9 @@
control-stack-pointer-sap) ()
system-area-pointer
(flushable))
+
+(defknown ensure-symbol-tls-index (symbol) fixnum)
+
;;;; debugger support
diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index 34006cf..a6e331e 100644
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -623,6 +623,9 @@
(define-info-type (:variable :documentation) :type-spec (or string null))
+;; See 'compiler/x86-64/cell' for explanation.
+(define-info-type (:variable :wired-tls-index) :type-spec boolean)
+
;;;; ":TYPE" subsection - Data pertaining to globally known types.
;;; the kind of type described. We return :INSTANCE for standard types
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 4665e89..927bc8b 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1543,8 +1543,15 @@
;;; implementation.
(defoptimizer (%special-bind ir2-convert) ((var value) node block)
(let ((name (leaf-source-name (lvar-value var))))
- (vop bind node block (lvar-tn node block value)
- (emit-constant name))))
+ #!-(and sb-thread x86-64)
+ (vop bind node block (lvar-tn node block value) (emit-constant name))
+ #!+(and sb-thread x86-64)
+ (progn
+ ;; GC must understand that the symbol is implicitly live even though
+ ;; binding makes no references to the object.
+ (emit-constant name)
+ (vop sb!vm::bind/let node block (lvar-tn node block value) name))))
+
(defoptimizer (%special-unbind ir2-convert) ((var) node block)
(vop unbind node block))
diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 5ea563d..4823a90 100644
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -311,22 +311,7 @@
(inst test tls-index tls-index)
(inst jmp :ne TLS-INDEX-VALID)
(inst mov tls-index symbol)
- (inst mov tmp
- (make-fixup (ecase (tn-offset tls-index)
- (#.rax-offset 'alloc-tls-index-in-rax)
- (#.rcx-offset 'alloc-tls-index-in-rcx)
- (#.rdx-offset 'alloc-tls-index-in-rdx)
- (#.rbx-offset 'alloc-tls-index-in-rbx)
- (#.rsi-offset 'alloc-tls-index-in-rsi)
- (#.rdi-offset 'alloc-tls-index-in-rdi)
- (#.r8-offset 'alloc-tls-index-in-r8)
- (#.r9-offset 'alloc-tls-index-in-r9)
- (#.r10-offset 'alloc-tls-index-in-r10)
- (#.r12-offset 'alloc-tls-index-in-r12)
- (#.r13-offset 'alloc-tls-index-in-r13)
- (#.r14-offset 'alloc-tls-index-in-r14)
- (#.r15-offset 'alloc-tls-index-in-r15))
- :assembly-routine))
+ (inst mov tmp (subprimitive-tls-allocator tls-index))
(inst call tmp)
TLS-INDEX-VALID
(inst mov tmp (make-ea :qword :base thread-base-tn :index tls-index))
@@ -334,6 +319,42 @@
(storew tls-index bsp (- binding-symbol-slot binding-size))
(inst mov (make-ea :qword :base thread-base-tn :index tls-index) val)))
+#!+sb-thread
+;; Nikodemus hypothetically terms the above VOP DYNBIND (in x86/cell.lisp)
+;; with this "new" one being BIND, but to re-purpose concepts in that way
+;; - though it be rational - is fraught with peril.
+;; So BIND/LET is for (LET ((*a-special* ...)))
+;;
+(define-vop (bind/let)
+ (:args (val :scs (any-reg descriptor-reg)))
+ (:temporary (:sc unsigned-reg) bsp tmp)
+ (:info symbol)
+ (:generator 10
+ (inst mov bsp (* binding-size n-word-bytes))
+ (inst xadd
+ (make-ea :qword :base thread-base-tn
+ :disp (ash thread-binding-stack-pointer-slot word-shift))
+ bsp)
+ (let* ((tls-index (make-fixup symbol :symbol-tls-index))
+ (tls-cell (make-ea :qword :base thread-base-tn :disp tls-index)))
+ ;; Too bad we can't use "XCHG [r12+disp], val" to write the new value
+ ;; and read the old value in one step. It will violate the constraints
+ ;; prescribed in the internal documentation on special binding.
+ (inst mov tmp tls-cell)
+ (storew tmp bsp binding-value-slot)
+ ;; Indices are small enough to be written as :DWORDs which avoids
+ ;; a REX prefix if 'bsp' happens to be any of the low 8 registers.
+ (inst mov (make-ea :dword :base bsp
+ :disp (ash binding-symbol-slot word-shift)) tls-index)
+ (inst mov tls-cell val))
+ ;; Emission of this VOP informs the compiler that later SYMBOL-VALUE calls
+ ;; might want to use a load-time fixup instead of reading from the symbol's
+ ;; tls-index, admitting a possible optimization (NOT DONE):
+ ;; MOV RES,[R12+N] ; CMP RES,NO_TLS_VALUE ; CMOV :NE RES,GLOBAL-VALUE
+ ;; In contrast, if the symbol is not known to ever have been thread-locally
+ ;; bound, reading it should not force the loader to assign a TLS index.
+ (setf (info :variable :wired-tls-index symbol) t)))
+
#!-sb-thread
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
@@ -929,3 +950,50 @@
(:info instance-length index)
(:generator 4
(inst movdqu (make-ea-for-raw-slot object instance-length :index index :adjustment -8) value)))
+
+#|
+For lack of a better location for these comments about the manipulation
+of static symbols, note that we now have unfortunately three ways of doing it.
+The following code rebinds *ALIEN-STACK* to itself then subtracts 16 bytes.
+
+* (disassemble '(lambda () (with-alien ((x (array char 16))) (print x))))
+
+1) Load the symbol into a register, load the tls-index from the symbol,
+ and access [thread_base+index]. This is an ordinary SYMBOL-VALUE call.
+
+; B80F0B1020 MOV EAX, 537922319
+; 488B5021 MOV RDX, [RAX+33]
+; 498B1414 MOV RDX, [R12+RDX]
+; 4883FA61 CMP RDX, 97
+; 7504 JNE L0
+; 488B50F9 MOV RDX, [RAX-7]
+; L0: 4883FA51 CMP RDX, 81
+; 0F84EC000000 JEQ L3
+
+2) Use a constant offset from the thread-base. This is the BIND/LET VOP.
+
+; 498B8C24A8000000 MOV RCX, [R12+168]
+; 488908 MOV [RAX], RCX
+; C74008A8000000 MOV DWORD PTR [RAX+8], 168
+; 49899424A8000000 MOV [R12+168], RDX
+
+3) Load the tls-index from its known fixed address in ALLOC-ALIEN-STACK-SPACE.
+
+; 488B0425300B1020 MOV RAX, [#x20100B30]
+; 49832C0410 SUB QWORD PTR [R12+RAX], 16
+; 488B0C25300B1020 MOV RCX, [#x20100B30]
+; 498B0C0C MOV RCX, [R12+RCX]
+; 488D5C24F0 LEA RBX, [RSP-16]
+; 4883EC18 SUB RSP, 24
+; 49896C2440 MOV [R12+64], RBP
+
+We could benefit from additional INFO for special variables:
+ - an indicator of whether to prefer that SYMBOL-VALUE use a known tls-index.
+ This would be the same load-time mechanism as for BIND/LET. It is bad
+ to force the loader to assign a tls-index for all reads of a symbol in
+ general. Many symbols are never dynamically bound, and the potential number
+ of globals (not DEFGLOBAL necessarily) in use by some applications
+ could quickly exhaust the TLS.
+ - an indicator of whether the symbol will definitely have a thread-local
+ binding whenever it is read, such as for *ALIEN-STACK*.
+|#
diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp
index 477160e..5ccbb2a 100644
--- a/src/compiler/x86-64/insts.lisp
+++ b/src/compiler/x86-64/insts.lisp
@@ -351,6 +351,12 @@
(defun print-imm/asm-routine (value stream dstate)
(sb!disassem:maybe-note-assembler-routine value nil dstate)
+ ;; also note a possible use of a static symbol.
+ ;; Do we want to push this logic into MAYBE-NOTE-ASSEMBLER-ROUTINE?
+ (dolist (symbol *static-symbols*)
+ (when (= (get-lisp-obj-address symbol) value)
+ (return (sb!disassem:note (lambda (s) (format s "possibly ~S" symbol))
+ dstate))))
(princ value stream))
) ; EVAL-WHEN
@@ -1837,8 +1843,8 @@
;; the runtime asm, since other foreign calls go through the
;; the linkage table) and for linkage table references, since
;; these should always end up in low memory.
- (aver (or (eq (fixup-flavor src) :foreign)
- (eq (fixup-flavor src) :foreign-dataref)
+ (aver (or (member (fixup-flavor src)
+ '(:foreign :foreign-dataref :symbol-tls-index))
(eq (ea-size dst) :dword)))
(maybe-emit-rex-for-ea segment dst nil)
(emit-byte segment #b11000111)
diff --git a/src/compiler/x86-64/subprim.lisp b/src/compiler/x86-64/subprim.lisp
index a779d13..1861c0f 100644
--- a/src/compiler/x86-64/subprim.lisp
+++ b/src/compiler/x86-64/subprim.lisp
@@ -80,3 +80,45 @@
(define-static-fun length (object) :translate length)
(define-static-fun %coerce-callable-to-fun (callable)
:translate %coerce-callable-to-fun)
+
+(defun subprimitive-tls-allocator (tn)
+ (make-fixup (ecase (tn-offset tn)
+ (#.rax-offset 'alloc-tls-index-in-rax)
+ (#.rcx-offset 'alloc-tls-index-in-rcx)
+ (#.rdx-offset 'alloc-tls-index-in-rdx)
+ (#.rbx-offset 'alloc-tls-index-in-rbx)
+ (#.rsi-offset 'alloc-tls-index-in-rsi)
+ (#.rdi-offset 'alloc-tls-index-in-rdi)
+ (#.r8-offset 'alloc-tls-index-in-r8)
+ (#.r9-offset 'alloc-tls-index-in-r9)
+ (#.r10-offset 'alloc-tls-index-in-r10)
+ (#.r12-offset 'alloc-tls-index-in-r12)
+ (#.r13-offset 'alloc-tls-index-in-r13)
+ (#.r14-offset 'alloc-tls-index-in-r14)
+ (#.r15-offset 'alloc-tls-index-in-r15))
+ :assembly-routine))
+
+;; Make sure that SYMBOL has a TLS-INDEX, and return that.
+;; It would be nice to have GC help recycle TLS indices.
+;; We can use the TLS area itself as a linked list of free cells, each
+;; storing the index of the next free cell. GC can push back into
+;; the so-represented list when it trashes a symbol.
+;; In addition to the GC complication, PROGV would need to be both
+;; cas-lock-protected and pseudo-atomic most likely.
+;;
+#!+sb-thread ; no SYMBOL-TLS-INDEX-SLOT without threads
+(define-vop (ensure-symbol-tls-index)
+ (:translate ensure-symbol-tls-index)
+ (:args (symbol :scs (descriptor-reg) :to (:result 1)))
+ (:results (tls-index :scs (descriptor-reg any-reg)))
+ (:temporary (:sc unsigned-reg) tmp)
+ (:policy :fast-safe)
+ (:generator 10
+ (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+ (inst test tls-index tls-index)
+ (inst jmp :ne TLS-INDEX-VALID)
+ (move tls-index symbol)
+ (inst mov tmp (subprimitive-tls-allocator tls-index))
+ (inst call tmp)
+ TLS-INDEX-VALID
+ (inst shl tls-index n-fixnum-tag-bits)))
diff --git a/src/compiler/x86-64/target-insts.lisp b/src/compiler/x86-64/target-insts.lisp
index 0a87959..e3c8e15 100644
--- a/src/compiler/x86-64/target-insts.lisp
+++ b/src/compiler/x86-64/target-insts.lisp
@@ -89,7 +89,53 @@
dstate))))
(t
(princ offset stream)))))))
- (write-char #\] stream))
+ (write-char #\] stream)
+ #!+sb-thread
+ (let ((disp (second value)))
+ (when (and (eql (first value) #.(ash (tn-offset thread-base-tn) -1))
+ (not (third value)) ; no index
+ (typep disp '(integer 0 *)) ; positive displacement
+ (sb!disassem::seg-code (sb!disassem:dstate-segment dstate)))
+ ;; Try to reverse-engineer which thread-local binding this is
+ (let* ((code (sb!disassem::seg-code (sb!disassem:dstate-segment dstate)))
+ (header-n-words
+ (ash (sap-ref-word (int-sap (get-lisp-obj-address code))
+ (- other-pointer-lowtag)) -8))
+ (tls-index (ash disp (- n-fixnum-tag-bits))))
+ (loop for word-num from code-constants-offset below header-n-words
+ for obj = (code-header-ref code word-num)
+ when (and (symbolp obj) (= (symbol-tls-index obj) tls-index))
+ do (return-from print-mem-ref
+ (sb!disassem:note
+ (lambda (stream) (format stream "tls: ~S" obj))
+ dstate))))
+ ;; Or maybe we're looking at the 'struct thread' itself
+ (when (< disp max-interrupts)
+ (let* ((thread-slots (primitive-object-slots
+ (find 'thread *primitive-objects*
+ :key #'primitive-object-name)))
+ (slot (find (ash disp (- word-shift)) thread-slots
+ :key #'slot-offset)))
+ (when slot
+ (return-from print-mem-ref
+ (sb!disassem:note
+ (lambda (stream)
+ (format stream "thread.~(~A~)" (slot-name slot)))
+ dstate))))))
+ ;; One last thing to try ...
+ ;; The TLS slot of static symbols is referenced in memory absolute mode.
+ ;; [FIXME: this is of course pointless! Genesis should pick/wire the indices
+ ;; of all static symbols]
+ (when (and (not (first value)) (not (third value)) ; no base, index
+ (typep disp '(integer 0 *)) ; positive displacement
+ (<= static-space-start disp static-space-end))
+ (dolist (symbol *static-symbols*)
+ (when (= (+ (get-lisp-obj-address symbol) (- other-pointer-lowtag)
+ (ash symbol-tls-index-slot word-shift))
+ disp)
+ (sb!disassem:note
+ (lambda (stream) (format stream "~A.tls-index" symbol))
+ dstate))))))
(in-package "SB!DISASSEM")
diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h
index 07b4a2d..a4c2771 100644
--- a/src/runtime/interrupt.h
+++ b/src/runtime/interrupt.h
@@ -97,7 +97,10 @@ extern void maybe_save_gc_mask_and_block_deferrables(sigset_t *sigset);
*
* -- NS 2007-01-29
*/
-#define MAX_INTERRUPTS 1024
+/* No longer defined here, but in 'compiler/generic/parms.lisp' due to
+ requirement that Lisp skip this many words when assigning thread-local
+ storage indices */
+// #define MAX_INTERRUPTS 1024
union interrupt_handler {
lispobj lisp;
diff --git a/src/runtime/thread.c b/src/runtime/thread.c
index 1889213..b59214c 100644
--- a/src/runtime/thread.c
+++ b/src/runtime/thread.c
@@ -629,13 +629,18 @@ create_thread_struct(lispobj initial_function) {
for(i = 0; i < (dynamic_values_bytes / sizeof(lispobj)); i++)
per_thread->dynamic_values[i] = NO_TLS_VALUE_MARKER_WIDETAG;
if (all_threads == 0) {
+ /* FIXME: Should nobody find it necessary to start a slightly older core
+ than expected by the C runtime (a core in which Lisp did not perform
+ these initializations) we can remove everything in this 'if' block */
if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG) {
SetSymbolValue(FREE_TLS_INDEX,tls_index_start << WORD_SHIFT,0);
SetSymbolValue(TLS_INDEX_LOCK,make_fixnum(0),0);
}
#define STATIC_TLS_INIT(sym,field) \
- ((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \
- (THREAD_SLOT_OFFSET_WORDS(field) << WORD_SHIFT)
+ if (SYMBOL(sym)->tls_index != (THREAD_SLOT_OFFSET_WORDS(field) << WORD_SHIFT)) { \
+ if (SYMBOL(sym)->tls_index == 0) \
+ SYMBOL(sym)->tls_index = (THREAD_SLOT_OFFSET_WORDS(field) << WORD_SHIFT); \
+ else lose(#sym " TLS index is wrong"); }
STATIC_TLS_INIT(BINDING_STACK_START,binding_stack_start);
#ifdef BINDING_STACK_POINTER
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|