mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
x86-64: add :TLS-load-indirect feature
Reduces SYMBOL-VALUE to exactly 2 instructions for most specials that aren't compile-time known to be either always thread-local or global. Our application got a .5% reduction in code size and about a 1% speedup. Refer to the comment above EMIT-SYMEVAL in src/compiler/x86-64/tls for details. When eager TLS assignment is also enabled, this optimization pertains to every special var except when the symbol itself is not known. I'm not sure how to expose the extra benefit that comes from eager TLS assignment because even if recycling indices were done, there would certainly be users who DEFVAR thousands of interned symbols without LET-binding a single one of them. So they need lazy TLS assignment.
This commit is contained in:
Douglas Katzman
parent
18592f8702
commit
db187b0e29
|
|
@ -175,15 +175,23 @@
|
|||
;; then it is definitely in the map.
|
||||
(inst push rbx-tn)
|
||||
(inst mov rbx-tn (static-symbol-value-ea '*tls-symbol-map*))
|
||||
(inst btc rbx-tn 63) ; fudge the array base address to "subtract out" bit 63 of scratch-reg
|
||||
(inst mov (ea rbx-tn scratch-reg) symbol)
|
||||
#+tls-load-indirect
|
||||
(progn (inst shr :dword scratch-reg 1)
|
||||
(inst mov (ea -4 rbx-tn scratch-reg) symbol)
|
||||
(inst shl :dword scratch-reg 1))
|
||||
#-tls-load-indirect
|
||||
(progn
|
||||
;; fudge the array base address to "subtract out" bit 63 of scratch-reg
|
||||
(inst btc rbx-tn 63)
|
||||
(inst mov (ea rbx-tn scratch-reg) symbol))
|
||||
(inst pop rbx-tn)
|
||||
;; scratch-reg goes into symbol's TLS and into the arg/result reg.
|
||||
(inst mov :dword (tls-index-of symbol) scratch-reg)
|
||||
(inst mov :dword result scratch-reg)
|
||||
;; Load scratch-reg with a constant that clears the lock bit
|
||||
;; and bumps the free index in one go.
|
||||
(inst mov scratch-reg (+ (- (ash 1 lock-bit)) n-word-bytes))
|
||||
(let ((increment (* (or #+tls-load-indirect 2 1) n-word-bytes)))
|
||||
(inst mov scratch-reg (+ (- (ash 1 lock-bit)) increment)))
|
||||
(inst add :qword :lock free-tls-index-ea scratch-reg)
|
||||
(inst pop scratch-reg)
|
||||
DONE) ; end PSEUDO-ATOMIC
|
||||
|
|
|
|||
|
|
@ -328,9 +328,14 @@
|
|||
(def!struct (compiled-debug-info
|
||||
(:include debug-info)
|
||||
(:constructor !make-compiled-debug-info
|
||||
(name package fun-map contexts rest))
|
||||
(name eh-locs package fun-map contexts rest))
|
||||
(:copier nil)
|
||||
(:pure t))
|
||||
;; PC offsets at which the C runtime must be able to handle a SIGSEGV
|
||||
;; not generated by an explicit trapping instruction. Conceptually
|
||||
;; similar to a JVM's optimistic null-pointer-exception handling,
|
||||
;; we assume the code will almost never trap, but occasionally may.
|
||||
(eh-locs) ; exception handling loc, sorted array of (unsigned-byte 32)
|
||||
;; The package that DEBUG-FUN-VARS were dumped relative
|
||||
;; to. Locations that aren't packaged are in this package.
|
||||
(package (missing-arg) :type package :read-only t)
|
||||
|
|
|
|||
|
|
@ -395,6 +395,13 @@ created and old ones may exit at any time."
|
|||
(setf *initial-thread* thread)
|
||||
(setf *joinable-threads* nil)
|
||||
(setq *session* (new-session thread))
|
||||
#+(and sb-thread tls-load-indirect)
|
||||
(let ((sap (int-sap (ash sb-vm::*tls-symbol-map* sb-vm:n-fixnum-tag-bits))))
|
||||
;; Elements of the tls-symbol-map are meaningless below the tls index of
|
||||
;; *PACKAGE* because there are more symbols than there are cells to hold them.
|
||||
;; Wiping out the nonsense cell range is better than keeping fictitious data.
|
||||
(dotimes (i (ash (symbol-tls-index '*package*) (- (1+ sb-vm:word-shift))))
|
||||
(setf (sap-ref-word sap (ash i sb-vm:word-shift)) sb-vm:no-tls-value-marker)))
|
||||
(setq *all-threads*
|
||||
(avl-insert nil
|
||||
(sb-thread::thread-primitive-thread sb-thread:*current-thread*)
|
||||
|
|
@ -2478,6 +2485,10 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD."
|
|||
(values nil :no-tls-value))
|
||||
(t
|
||||
(setf (sap-ref-lispobj (int-sap c-thread) offset) value)
|
||||
#+tls-load-indirect
|
||||
(when (>= offset (sb-kernel:symbol-tls-index '*package*))
|
||||
(setf (sap-ref-sap (int-sap c-thread) (- offset sb-vm:n-word-bytes))
|
||||
(sap+ (int-sap c-thread) (1- offset))))
|
||||
(values value :ok))))
|
||||
(values nil :thread-dead))))
|
||||
|
||||
|
|
@ -2501,7 +2512,10 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD."
|
|||
list)
|
||||
;; NO-TLS-VALUE-MARKER may or may not satisfy IS-LISP-POINTER,
|
||||
;; so be sure to exclude it in case it does.
|
||||
(unless (eql (sap-ref-word sap index) sb-vm:no-tls-value-marker)
|
||||
(when (and #+tls-load-indirect
|
||||
(and (oddp (ash index (- sb-vm:word-shift)))
|
||||
(>= index (symbol-tls-index '*package*)))
|
||||
(/= (sap-ref-word sap index) sb-vm:no-tls-value-marker))
|
||||
(let ((obj (sap-ref-lispobj sap index)))
|
||||
(when (and obj ; don't bother returning NIL
|
||||
(sb-vm:is-lisp-pointer (get-lisp-obj-address obj))
|
||||
|
|
@ -2572,6 +2586,7 @@ mechanism for inter-thread communication."
|
|||
(slots (sb-vm::primitive-object-slots primobj))
|
||||
(sap (current-thread-sap))
|
||||
(thread-obj-len (sb-vm::primitive-object-length primobj))
|
||||
(tls-end (sap+ sap (extern-alien "dynamic_values_bytes" (unsigned 32))))
|
||||
(names (make-array thread-obj-len :initial-element "")))
|
||||
(loop for slot across slots
|
||||
do
|
||||
|
|
@ -2580,6 +2595,15 @@ mechanism for inter-thread communication."
|
|||
(cond ((eql bits sb-vm:no-tls-value-marker) :no-tls-value)
|
||||
((eql (logand bits sb-vm:widetag-mask) sb-vm:unbound-marker-widetag) :unbound)
|
||||
(t (sap-ref-lispobj sap offset))))
|
||||
(indirection-cell-p (tlsindex)
|
||||
(let ((word (sap-ref-word sap tlsindex)))
|
||||
(cond ((and (= (logand word sb-vm:lowtag-mask) sb-vm:list-pointer-lowtag)
|
||||
(>= word (sap-int sap))
|
||||
(< word (sap-int tls-end)))
|
||||
:tls)
|
||||
((and (= (logand word sb-vm:lowtag-mask) sb-vm:other-pointer-lowtag)
|
||||
(/= word sb-ext:most-positive-word))
|
||||
:global))))
|
||||
(show (sym val)
|
||||
(let ((*print-right-margin* 128)
|
||||
(*print-lines* 4))
|
||||
|
|
@ -2595,15 +2619,21 @@ mechanism for inter-thread communication."
|
|||
#-sb-thread (ash thread-obj-len sb-vm:word-shift)
|
||||
by sb-vm:n-word-bytes
|
||||
do
|
||||
(let ((thread-slot-name
|
||||
(if (< tlsindex (ash thread-obj-len sb-vm:word-shift))
|
||||
(aref names (ash tlsindex (- sb-vm:word-shift))))))
|
||||
(if (and thread-slot-name (neq thread-slot-name 'sb-vm::lisp-thread))
|
||||
(format t " ~3d ~30a : #x~x~%" (ash tlsindex (- sb-vm:word-shift))
|
||||
thread-slot-name (sap-ref-word sap tlsindex))
|
||||
(let* ((n (ash tlsindex (- sb-vm:word-shift)))
|
||||
(thread-slot-name
|
||||
(if (< tlsindex (ash thread-obj-len sb-vm:word-shift))
|
||||
(aref names n))))
|
||||
(acond ((and thread-slot-name (neq thread-slot-name 'sb-vm::lisp-thread))
|
||||
(format t " ~3d ~30a : #x~x~%" n
|
||||
thread-slot-name (sap-ref-word sap tlsindex)))
|
||||
((and (evenp (ash tlsindex (- sb-vm:word-shift)))
|
||||
(>= (ash tlsindex (- sb-vm:word-shift)) 75) ; HACK HACK HACK
|
||||
(indirection-cell-p tlsindex))
|
||||
(format t " ~3d indirect -> ~S ~x~%" n it (sap-ref-word sap tlsindex)))
|
||||
(t
|
||||
(let ((val (safely-read sap tlsindex)))
|
||||
(unless (eq val :no-tls-value)
|
||||
(show tlsindex val))))))
|
||||
(show tlsindex val)))))))
|
||||
(let ((from (descriptor-sap sb-vm:*binding-stack-start*))
|
||||
(to (binding-stack-pointer-sap)))
|
||||
(format t "~%Binding stack: (depth ~d)~%"
|
||||
|
|
|
|||
|
|
@ -322,6 +322,9 @@
|
|||
(pushnew :immobile-code sb-xc:*features*))
|
||||
(when (target-featurep '(:and :sb-thread (:or (:and :darwin (:not (:or :ppc :x86))) :openbsd)))
|
||||
(push :os-thread-stack sb-xc:*features*))
|
||||
(when (target-featurep '(:and :sb-thread :x86-64 (:or :darwin :linux)
|
||||
(:not :mark-region-gc)))
|
||||
(push :tls-load-indirect sb-xc:*features*))
|
||||
(when (target-featurep '(:and :x86 :int4-breakpoints))
|
||||
;; 0xCE is a perfectly good 32-bit instruction,
|
||||
;; unlike on x86-64 where it is illegal. It's therefore
|
||||
|
|
|
|||
|
|
@ -322,6 +322,8 @@
|
|||
;; for deterministic allocation profiler (or possibly other tooling)
|
||||
;; that wants to monkey patch the instructions at runtime.
|
||||
(alloc-points)
|
||||
;; Exception-handling locations (which can be handled in the C runtime)
|
||||
(eh-locs)
|
||||
;; for shrinking the size of the code fixups, we can choose to emit at most one call
|
||||
;; from a dynamic space code component to a given assembly routine. The call goes
|
||||
;; through an extra indirection in the component.
|
||||
|
|
@ -1573,6 +1575,7 @@
|
|||
(label-position end-text) fun-offsets
|
||||
(asmstream-elsewhere-label asmstream)
|
||||
(segment-fixup-notes segment)
|
||||
(sort (mapcar 'label-posn (asmstream-eh-locs asmstream)) #'<)
|
||||
(get-allocation-points asmstream))))
|
||||
|
||||
;;; Most backends do not convert register TNs into a different type of
|
||||
|
|
@ -1658,7 +1661,8 @@
|
|||
"Emit LABEL at this location in the current section."
|
||||
(let ((s *current-destination*))
|
||||
(trace-inst s :label label)
|
||||
(emit s label)))
|
||||
(emit s label))
|
||||
label)
|
||||
|
||||
(defun emit-postit (function)
|
||||
(let ((s *current-destination*))
|
||||
|
|
|
|||
|
|
@ -20,10 +20,10 @@
|
|||
(:conc-name "ASM-")
|
||||
(:constructor make-assembly
|
||||
(segment bytes text-length fun-table elsewhere-label
|
||||
fixup-notes alloc-sites))
|
||||
fixup-notes eh-locs alloc-sites))
|
||||
(:copier nil))
|
||||
segment bytes text-length fun-table elsewhere-label
|
||||
fixup-notes alloc-sites)
|
||||
fixup-notes eh-locs alloc-sites)
|
||||
|
||||
;;; KLUDGE: the assembler can not emit backpatches comprising jump tables without
|
||||
;;; knowing the boxed code header length. But there is no compiler IR2 metaobject,
|
||||
|
|
|
|||
|
|
@ -1072,9 +1072,12 @@
|
|||
(compute-1-debug-fun lambda var-locs (asm-elsewhere-label assembly)))
|
||||
dfuns)))
|
||||
(let ((map (compute-packed-debug-funs (nreverse dfuns)))
|
||||
(eh-locs (awhen (asm-eh-locs assembly)
|
||||
(logically-readonlyize
|
||||
(sb-xc:coerce it '(simple-array (unsigned-byte 32) 1)))))
|
||||
(contexts (compact-vector *contexts*)))
|
||||
#+sb-xc-host
|
||||
(!make-compiled-debug-info name *package* map contexts simple-fun-headers)
|
||||
(!make-compiled-debug-info name eh-locs *package* map contexts simple-fun-headers)
|
||||
#-sb-xc-host
|
||||
(let ((di (%make-instance (+ (1- (sb-kernel::type-dd-length compiled-debug-info))
|
||||
(length simple-fun-headers)))))
|
||||
|
|
@ -1082,6 +1085,7 @@
|
|||
;; The fixed slots except for SOURCE are declared readonly
|
||||
(%instance-ref di (get-dsd-index compiled-debug-info name)) name
|
||||
(%instance-ref di (get-dsd-index compiled-debug-info source)) nil
|
||||
(%instance-ref di (get-dsd-index compiled-debug-info eh-locs)) eh-locs
|
||||
(%instance-ref di (get-dsd-index compiled-debug-info package)) *package*
|
||||
(%instance-ref di (get-dsd-index compiled-debug-info fun-map)) map
|
||||
(%instance-ref di (get-dsd-index compiled-debug-info contexts)) contexts)
|
||||
|
|
|
|||
|
|
@ -1157,6 +1157,10 @@ core and return a descriptor to it."
|
|||
(defvar *tls-index-to-symbol*)
|
||||
#+sb-thread
|
||||
(progn
|
||||
;; This can be 1 or 2 depending on how the TLS is utilized.
|
||||
;; Double-indirect TLS uses 2 words per entry but the initial
|
||||
;; portion of the TLS is never double-indirect.
|
||||
(defvar *tls-increment* 1)
|
||||
;; Simulate *FREE-TLS-INDEX*. This is a word count, not a displacement.
|
||||
(defvar *genesis-tls-counter* sb-vm::primitive-thread-object-length)
|
||||
;; Assign SYMBOL the tls-index INDEX. SYMBOL must be a descriptor.
|
||||
|
|
@ -1180,7 +1184,8 @@ core and return a descriptor to it."
|
|||
(defun ensure-symbol-tls-index (symbol)
|
||||
(let ((tls-index (get-symbol-tls-index symbol)))
|
||||
(unless (plusp tls-index)
|
||||
(let ((next (prog1 *genesis-tls-counter* (incf *genesis-tls-counter*))))
|
||||
(let ((next (prog1 *genesis-tls-counter*
|
||||
(incf *genesis-tls-counter* *tls-increment*))))
|
||||
(setq tls-index (ash next sb-vm:word-shift))
|
||||
(cold-assign-tls-index (cold-intern symbol) tls-index)))
|
||||
tls-index)))
|
||||
|
|
@ -1963,7 +1968,12 @@ core and return a descriptor to it."
|
|||
;; Assign other known TLS indices
|
||||
(dolist (pair tls-init)
|
||||
(destructuring-bind (tls-index . symbol) pair
|
||||
(aver (= tls-index (ensure-symbol-tls-index symbol))))))
|
||||
(aver (= tls-index (ensure-symbol-tls-index symbol)))))
|
||||
#+(and x86-64 tls-load-indirect)
|
||||
(let ((index *genesis-tls-counter*))
|
||||
;; From here on we can only write to odd-numbered slots
|
||||
(setq *genesis-tls-counter* (+ index (if (oddp index) 2 1))
|
||||
*tls-increment* 2)))
|
||||
|
||||
;; Establish the value of T.
|
||||
#-x86-64
|
||||
|
|
|
|||
|
|
@ -372,8 +372,20 @@
|
|||
#-sb-thread (progn (emit-gengc-barrier symbol nil value) ; VALUE is the card-mark temp
|
||||
(loadw value bsp binding-value-slot)
|
||||
(storew value symbol symbol-value-slot other-pointer-lowtag))
|
||||
#+sb-thread (progn (loadw value bsp binding-value-slot)
|
||||
(inst mov (thread-tls-ea symbol) value))
|
||||
#+sb-thread
|
||||
(progn
|
||||
(loadw value bsp binding-value-slot)
|
||||
(inst mov (thread-tls-ea symbol) value)
|
||||
#+tls-load-indirect (progn
|
||||
;; Storing NO-TLS-VALUE sets the indirection cell to point at the symbol.
|
||||
(inst cmp value NO-TLS-VALUE-MARKER)
|
||||
(inst jmp :ne SKIP)
|
||||
(inst mov value (static-symbol-value-ea '*tls-symbol-map*))
|
||||
(inst shr :dword symbol 1) ; symbol-map is half the size of TLS
|
||||
;; Load the symbol. The -4 is because this conceptually should
|
||||
;; have rounded down to an even address before dividing by 2.
|
||||
(inst mov value (ea -4 value symbol))
|
||||
(inst mov (ea -8 thread-tn symbol 2) value)))
|
||||
SKIP
|
||||
(inst movapd (ea bsp) zero)
|
||||
|
||||
|
|
|
|||
|
|
@ -629,15 +629,19 @@
|
|||
(note (lambda (stream) (format stream "thread.~(~A~)" symbol))
|
||||
dstate))))
|
||||
#+sb-thread
|
||||
(let ((symbol (or (guess-symbol
|
||||
(lambda (s) (= (symbol-tls-index s) disp)))
|
||||
;; static symbols aren't in the code header
|
||||
(find disp +static-symbols+
|
||||
:key #'symbol-tls-index))))
|
||||
(let* ((indirect)
|
||||
(symbol (or (guess-symbol
|
||||
(lambda (s &aux (i (symbol-tls-index s)))
|
||||
(cond ((= disp (- i 8)) (setq indirect t))
|
||||
((= disp i)))))
|
||||
;; static symbols aren't in the code header
|
||||
(find disp +static-symbols+
|
||||
:key #'symbol-tls-index))))
|
||||
(when symbol
|
||||
(return-from print-mem-ref
|
||||
;; "tls:" refers to the current value of the symbol in TLS
|
||||
(note (lambda (stream) (format stream "tls: ~S" symbol))
|
||||
(note (lambda (stream)
|
||||
(format stream "~A: ~S" (if indirect "&var" "tls") symbol))
|
||||
dstate)))))))))
|
||||
|
||||
(defun lea-compute-label (value dstate)
|
||||
|
|
|
|||
|
|
@ -28,10 +28,10 @@
|
|||
(ea (make-fixup (tn-value symbol) :immobile-symbol (- 4 other-pointer-lowtag))))
|
||||
|
||||
;; Return the DISP field to use in an EA relative to thread-base
|
||||
(defun load-time-tls-offset (symbol)
|
||||
(defun load-time-tls-offset (symbol &optional (disp 0))
|
||||
(let ((where (info :variable :wired-tls symbol)))
|
||||
(cond ((integerp where) where)
|
||||
(t (make-fixup symbol :symbol-tls-index)))))
|
||||
(t (make-fixup symbol :symbol-tls-index disp)))))
|
||||
|
||||
(deftransform %compare-and-swap-symbol-value ((symbol old new)
|
||||
((constant-arg symbol) t t))
|
||||
|
|
@ -99,6 +99,39 @@
|
|||
CAS
|
||||
(emit-cas (ea cell) symbol old new rax result vop))))
|
||||
|
||||
;;; The :tls-load-indirect feature is, in most situations, an improvement over "direct"
|
||||
;;; access (contrary to what indirection implies, but I couldn't settle on a better name).
|
||||
;;; Profiling of some typical code making use of special vars produced a distribution
|
||||
;;; of operations showing SYMBOL-VALUE being 9x to 10x more frequent than BIND or SET:
|
||||
;;; 90% SYMBOL-VALUE
|
||||
;;; 8% BIND
|
||||
;;; 1.75% SET
|
||||
;;; .25% COMPARE-AND-SWAP
|
||||
;;; Therefore reducing the cost of [FAST-]SYMBOL-VALUE at the expense of more
|
||||
;;; instructions in BIND should be a worthwhile trade-off.
|
||||
;;; The idea is simple: rather than a CMOV or conditional branch to choose either the
|
||||
;;; global or TLS value at each read, extra work can instead be done in BIND/UNBIND
|
||||
;;; to maintain a pointer to the current address of the value. Then SYMBOL-VALUE becomes
|
||||
;;; merely a double deref, which modern memory systems are well-equipped to deal with.
|
||||
;;; In fact the indirect word and value are adjacent, and brought into L1 cache together.
|
||||
|
||||
;;; One tricky piece is that a null-pointer exception may need to be handled, at most
|
||||
;;; once per thread per symbol that lacks a thread-local value. When the indirection
|
||||
;;; contains NO-TLS-VALUE-MARKER, then the second deref reads an invalid address.
|
||||
;;; This is caught in an architecture-specific routine which recognizes that the
|
||||
;;; indirection word should point to SYMBOL-GLOBAL-VALUE. Attempting to resolve this
|
||||
;;; at thread startup would avoid some sigsegvs, but not all of them, since new
|
||||
;;; special variables can be created at any time in any thread and read in any thread.
|
||||
|
||||
;;; Whether the net effect is a performance boost depends on at least two factors
|
||||
;;; which are unpredictable:
|
||||
;;; - if the distribution of operations is skewed toward BIND being more common
|
||||
;;; than symbol-value, then load-indirect can make the wrong trade-off.
|
||||
;;; - certain CPUs may do worse with the double-indirect load.
|
||||
;;; As an example of the former issue, the STAK-AUX function in cl-bench performs
|
||||
;;; symbol-value only about twice as often as BIND, which is not enough to outform
|
||||
;;; a comparision and conditional move. But I suspect this situation is rare.
|
||||
|
||||
;; This code is tested by 'codegen.impure.lisp'
|
||||
(defun emit-symeval (value symbol symbol-ref symbol-reg check-boundp vop)
|
||||
(let ((known-symbol (and (constant-tn-p symbol) (tn-value symbol))))
|
||||
|
|
@ -106,6 +139,11 @@
|
|||
((symbol-always-has-tls-value-p symbol-ref (sb-c::vop-node vop))
|
||||
(setq symbol-reg nil)
|
||||
(inst mov value (access-wired-tls-val known-symbol)))
|
||||
#+tls-load-indirect
|
||||
((symbol-always-has-tls-index-p known-symbol)
|
||||
(inst mov value (thread-tls-ea (load-time-tls-offset known-symbol -8)))
|
||||
(push (emit-label (gen-label)) (sb-assem::asmstream-eh-locs sb-assem:*asmstream*))
|
||||
(inst mov value (ea 1 value)))
|
||||
(t
|
||||
;; Step 1: load the TLS index and then then the slot of the thread
|
||||
(cond
|
||||
|
|
@ -311,6 +349,7 @@
|
|||
;;; symbol.
|
||||
;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
|
||||
|
||||
#-tls-load-indirect (progn
|
||||
(define-vop (dynbind) ; bind a symbol in a PROGV form
|
||||
(:args (val :scs (any-reg descriptor-reg))
|
||||
(symbol :scs (descriptor-reg)))
|
||||
|
|
@ -376,6 +415,93 @@
|
|||
(symbol-slot-ea symbol symbol-value-slot)
|
||||
(symbol-value-slot-ea symbol-reg)))
|
||||
(inst mov tls-cell tls-value)))))
|
||||
)
|
||||
|
||||
#+tls-load-indirect (progn
|
||||
(defun binding-stack-push (node symbol index-temp bsp val-temp
|
||||
&optional (newval nil newvalp)
|
||||
&aux (value-ea (ea 1 index-temp)))
|
||||
(inst mov val-temp (ea index-temp thread-tn))
|
||||
(inst mov bsp (* binding-size n-word-bytes))
|
||||
(inst xadd (thread-slot-ea thread-binding-stack-pointer-slot) bsp)
|
||||
(inst mov (ea (ash binding-value-slot word-shift) bsp) val-temp)
|
||||
(inst mov :dword (ea (ash binding-symbol-slot word-shift) bsp) index-temp)
|
||||
;; (usually) update the indirect pointer
|
||||
(cond ((not symbol) ; compile-time-unknown if indirection word exists
|
||||
(assemble ()
|
||||
;; *PACKAGE* has the lowest TLS index in the range of specials which
|
||||
;; have indirection cells. Comparing to the TLS index of *PACKAGE* is
|
||||
;; surely a hack. However, it is correct, and verified by a test
|
||||
;; in x86-64-codegen.
|
||||
(inst cmp index-temp (make-fixup '*package* :symbol-tls-index))
|
||||
(inst lea index-temp (ea -1 index-temp thread-tn))
|
||||
(inst jmp :l NO-INDIRECT-CELL)
|
||||
(inst mov (ea -7 index-temp) index-temp)
|
||||
NO-INDIRECT-CELL))
|
||||
((symbol-always-has-tls-value-p symbol node)
|
||||
;; if always-tls-value, then either there is no reason to affect
|
||||
;; the indirection word, or there is no indirection word.
|
||||
(setq value-ea (ea index-temp thread-tn)))
|
||||
(t
|
||||
(inst lea index-temp (ea -1 index-temp thread-tn))
|
||||
(inst mov (ea -7 index-temp) index-temp)))
|
||||
(unless newvalp (return-from binding-stack-push))
|
||||
(let ((repr (encode-value-if-immediate newval)))
|
||||
(cond ((or (gpr-tn-p repr) (fixup-p repr)
|
||||
(plausible-signed-imm32-operand-p repr))
|
||||
(setq newval repr))
|
||||
((nil-relative-p repr)
|
||||
(move-immediate (setq newval val-temp) repr))
|
||||
(t
|
||||
(aver (sc-is newval constant control-stack))
|
||||
(move val-temp newval)
|
||||
(setq newval val-temp))))
|
||||
(inst mov :qword value-ea newval))
|
||||
|
||||
(define-vop (bind) ; bind a known symbol
|
||||
(:args (val :scs (any-reg descriptor-reg control-stack constant immediate)))
|
||||
(:temporary (:sc unsigned-reg) index bsp tmp)
|
||||
(:info symbol)
|
||||
(:node-var node)
|
||||
(:generator 10
|
||||
(inst mov :dword index (load-time-tls-offset symbol))
|
||||
(binding-stack-push node symbol index bsp tmp val)))
|
||||
|
||||
(define-vop (rebind)
|
||||
(:temporary (:sc unsigned-reg) index bsp val)
|
||||
(:info symbol)
|
||||
(:node-var node)
|
||||
(:generator 10
|
||||
(inst mov :dword index (load-time-tls-offset symbol))
|
||||
(binding-stack-push node symbol index bsp val)
|
||||
(unless (symbol-always-has-tls-value-p symbol node)
|
||||
(inst cmp val NO-TLS-VALUE-MARKER)
|
||||
(inst jmp :ne DONE)
|
||||
;; load symbol-global-value
|
||||
(cond ((immediate-constant-sc symbol)
|
||||
(inst mov val (symbol-slot-ea symbol symbol-value-slot)))
|
||||
(t
|
||||
(inst mov val (emit-constant symbol))
|
||||
(inst mov val (symbol-value-slot-ea val))))
|
||||
(inst mov :qword (ea 1 index) val))
|
||||
DONE))
|
||||
|
||||
(define-vop (dynbind) ; bind a symbol in a PROGV form
|
||||
(:args (val :scs (any-reg descriptor-reg))
|
||||
(symbol :scs (descriptor-reg)))
|
||||
(:temporary (:sc unsigned-reg :offset rax-offset) tls-index)
|
||||
(:temporary (:sc unsigned-reg) bsp tmp)
|
||||
(:vop-var vop)
|
||||
(:node-var node)
|
||||
(:generator 10
|
||||
(inst mov :dword tls-index (tls-index-of symbol))
|
||||
(inst test :dword tls-index tls-index)
|
||||
(inst jmp :ne TLS-INDEX-VALID)
|
||||
(inst mov tls-index symbol)
|
||||
(invoke-asm-routine 'call 'alloc-tls-index vop)
|
||||
TLS-INDEX-VALID
|
||||
(binding-stack-push node nil tls-index bsp tmp val)))
|
||||
) ; end #+tls-load-indirect
|
||||
|
||||
(define-vop (unbind-n)
|
||||
(:temporary (:sc unsigned-reg) temp bsp)
|
||||
|
|
@ -385,27 +511,41 @@
|
|||
(:generator 0
|
||||
(load-binding-stack-pointer bsp)
|
||||
(inst xorpd zero zero)
|
||||
(loop for symbol in symbols
|
||||
for tls-index = (load-time-tls-offset symbol)
|
||||
for tls-cell = (thread-tls-ea tls-index)
|
||||
do
|
||||
#+ultrafutex
|
||||
(when (eq symbol '*current-mutex*)
|
||||
(let ((uncontested (gen-label)))
|
||||
(inst mov temp tls-cell) ; load the current value
|
||||
(inst mov :qword (mutex-slot temp %owner) 0)
|
||||
(inst dec :lock :byte (mutex-slot temp state))
|
||||
(inst jmp :z uncontested) ; if ZF then previous value was 1, no waiters
|
||||
(invoke-asm-routine 'call 'mutex-wake-waiter vop)
|
||||
(emit-label uncontested)))
|
||||
(dolist (symbol symbols)
|
||||
(let* ((tls-index (load-time-tls-offset symbol))
|
||||
(tls-cell (thread-tls-ea tls-index)))
|
||||
#+ultrafutex
|
||||
(when (eq symbol '*current-mutex*)
|
||||
(let ((uncontested (gen-label)))
|
||||
(inst mov temp tls-cell) ; load the current value
|
||||
(inst mov :qword (mutex-slot temp %owner) 0)
|
||||
(inst dec :lock :byte (mutex-slot temp state))
|
||||
(inst jmp :z uncontested) ; if ZF then previous value was 1, no waiters
|
||||
(invoke-asm-routine 'call 'mutex-wake-waiter vop)
|
||||
(emit-label uncontested)))
|
||||
|
||||
(inst sub bsp (* binding-size n-word-bytes))
|
||||
(inst sub bsp (* binding-size n-word-bytes))
|
||||
|
||||
;; Load VALUE from stack, then restore it to the TLS area.
|
||||
(loadw temp bsp binding-value-slot)
|
||||
(inst mov tls-cell temp)
|
||||
;; Zero out the stack.
|
||||
(inst movapd (ea bsp) zero))
|
||||
;; Load VALUE from stack, then restore it to the TLS area.
|
||||
(loadw temp bsp binding-value-slot)
|
||||
(inst mov tls-cell temp)
|
||||
#+tls-load-indirect
|
||||
(unless (symbol-always-has-tls-value-p symbol nil)
|
||||
(assemble ()
|
||||
(inst cmp temp NO-TLS-VALUE-MARKER)
|
||||
(inst jmp :ne SKIP)
|
||||
;; Write the symbol into the indirection cell
|
||||
(let ((const (emit-constant symbol))
|
||||
(cell (thread-tls-ea (load-time-tls-offset symbol -8))))
|
||||
(cond ((sc-is const immediate)
|
||||
(inst mov :qword cell (immediate-tn-repr const)))
|
||||
(t
|
||||
(move temp const)
|
||||
(inst mov cell temp))))
|
||||
SKIP))
|
||||
|
||||
;; Zero out the stack.
|
||||
(inst movapd (ea bsp) zero)))
|
||||
(store-binding-stack-pointer bsp)))
|
||||
|
||||
(define-vop (atomic-inc-symbol-global-value cell-xadd)
|
||||
|
|
|
|||
|
|
@ -304,6 +304,10 @@ memory_fault_handler(int signal, siginfo_t *siginfo, os_context_t *context)
|
|||
if (gencgc_handle_wp_violation(context, fault_addr)) return;
|
||||
#endif
|
||||
|
||||
#ifdef LISP_FEATURE_TLS_LOAD_INDIRECT
|
||||
if (handle_tls_deref_trap(context, fault_addr)) return;
|
||||
#endif
|
||||
|
||||
if (!handle_guard_page_triggered(context,fault_addr))
|
||||
lisp_memory_fault_error(context, fault_addr);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1388,16 +1388,21 @@ init_coreparse_spaces(int n, struct coreparse_space* input)
|
|||
lispobj* tlsindex_to_symbol_map;
|
||||
static void construct_tls_map()
|
||||
{
|
||||
int map_nbytes = dynamic_values_bytes;
|
||||
int map_nbytes = N_WORD_BYTES * (dynamic_values_bytes / bytes_per_tls_symbol);
|
||||
tlsindex_to_symbol_map = checked_malloc(map_nbytes);
|
||||
memset(tlsindex_to_symbol_map, 0xff, map_nbytes);
|
||||
// A static Lisp symbol is slightly easier to access than a C symbol from Lisp
|
||||
SYMBOL(TLS_SYMBOL_MAP)->value = (uword_t)tlsindex_to_symbol_map;
|
||||
|
||||
#ifdef LISP_FEATURE_TLS_LOAD_INDIRECT
|
||||
const int shift = 1+WORD_SHIFT;
|
||||
#else
|
||||
const int shift = WORD_SHIFT;
|
||||
#endif
|
||||
int offset;
|
||||
#define EXAMINE_OBJECT() if (widetag_of(where) == SYMBOL_WIDETAG && \
|
||||
(offset = tls_index_of((struct symbol*)where)) != 0) \
|
||||
tlsindex_to_symbol_map[offset>>WORD_SHIFT] = make_lispobj(where, OTHER_POINTER_LOWTAG)
|
||||
tlsindex_to_symbol_map[offset>>shift] = make_lispobj(where, OTHER_POINTER_LOWTAG)
|
||||
#ifdef LISP_FEATURE_MARK_REGION_GC
|
||||
# define SYMBOL_PAGE_TYPE PAGE_TYPE_MIXED
|
||||
#else
|
||||
|
|
|
|||
|
|
@ -121,4 +121,4 @@ __thread struct thread *current_thread;
|
|||
pthread_key_t current_thread = 0;
|
||||
#endif
|
||||
struct thread *all_threads;
|
||||
int dynamic_values_bytes = 4096 * sizeof(lispobj); // same for all threads
|
||||
int dynamic_values_bytes = 4096 * bytes_per_tls_symbol; // same for all threads
|
||||
|
|
|
|||
|
|
@ -298,6 +298,10 @@ sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
|
|||
if (handle_foreign_call_trigger(context, addr)) return;
|
||||
#endif
|
||||
|
||||
#ifdef LISP_FEATURE_TLS_LOAD_INDIRECT
|
||||
if (handle_tls_deref_trap(context, addr)) return;
|
||||
#endif
|
||||
|
||||
extern int diagnose_arena_fault(os_context_t*,char*);
|
||||
#ifdef LISP_FEATURE_SYSTEM_TLABS
|
||||
if (diagnose_arena_fault(context, addr)) return;
|
||||
|
|
|
|||
|
|
@ -402,7 +402,7 @@ static int is_memsize_arg(char *argv[], int argi, int argc, int *merge_core_page
|
|||
// this is not named "tls-size" because "size" is not the
|
||||
// best measurement for how many symbols to allow
|
||||
if ((argi+1) >= argc) lose("missing argument for --tls-limit");
|
||||
dynamic_values_bytes = N_WORD_BYTES * atoi(argv[argi+1]);
|
||||
dynamic_values_bytes = bytes_per_tls_symbol * atoi(argv[argi+1]);
|
||||
return 2;
|
||||
}
|
||||
if (!strcmp(arg, "--merge-core-pages")) {
|
||||
|
|
|
|||
|
|
@ -358,6 +358,11 @@ extern void scrub_thread_control_stack(struct thread *);
|
|||
extern void scavenge_control_stack(struct thread *th);
|
||||
extern void gc_close_thread_regions(struct thread*, int);
|
||||
|
||||
extern int handle_tls_deref_trap(os_context_t*, os_vm_address_t);
|
||||
#ifdef LISP_FEATURE_TLS_LOAD_INDIRECT
|
||||
static const int bytes_per_tls_symbol = N_WORD_BYTES*2;
|
||||
#else
|
||||
static const int bytes_per_tls_symbol = N_WORD_BYTES;
|
||||
#endif
|
||||
|
||||
#endif /* _INCLUDE_THREAD_H_ */
|
||||
|
|
|
|||
|
|
@ -32,6 +32,9 @@
|
|||
|
||||
#include "genesis/static-symbols.h"
|
||||
#include "genesis/symbol.h"
|
||||
#include "genesis/compiled-debug-info.h"
|
||||
#include "genesis/vector.h"
|
||||
#include "code.h"
|
||||
#include "core.h"
|
||||
#include "gc.h"
|
||||
|
||||
|
|
@ -646,7 +649,6 @@ lispobj entrypoint_taggedptr(uword_t entrypoint) {
|
|||
}
|
||||
|
||||
#ifdef LISP_FEATURE_SB_THREAD
|
||||
#include "genesis/vector.h"
|
||||
#define LOCK_PREFIX 0xF0
|
||||
#undef SHOW_PC_RECORDING
|
||||
|
||||
|
|
@ -922,4 +924,42 @@ int futex_wait_allowing_gc(int *lock_word, int oldval)
|
|||
}
|
||||
#endif
|
||||
|
||||
int handle_tls_deref_trap(os_context_t* context, os_vm_address_t addr)
|
||||
{
|
||||
unsigned char* pc = (void*)os_context_pc(context);
|
||||
if (!(addr == 0 && gc_managed_heap_space_p((lispobj)pc))) return 0;
|
||||
struct code* code = (void*)component_ptr_from_pc((char*)pc);
|
||||
if (!code) return 0;
|
||||
struct compiled_debug_info* cdi = (void*)native_pointer(code->debug_info);
|
||||
if (cdi->eh_locs == NIL) return 0;
|
||||
|
||||
// Check that the faulting instruction is MOV Rd,[Rn+1]
|
||||
if ((pc[0] == 0x48 || pc[0] == 0x4D) && pc[1] == 0x8B &&
|
||||
(pc[2] & 0300) == 0100 && pc[3] == 1) {
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
struct vector* eh_locs = VECTOR(cdi->eh_locs);
|
||||
uint32_t* data = (void*)eh_locs->data;
|
||||
uint32_t pc_offset = (char*)pc - code_text_start(code);
|
||||
int i = bsearch_greatereql_uint32(pc_offset, data, vector_len(eh_locs));
|
||||
if (i<0 || data[i] != pc_offset) return 0;
|
||||
|
||||
pc -= 7;
|
||||
int32_t disp = UNALIGNED_LOAD32(pc+3);
|
||||
int logical_index = disp >> (1+WORD_SHIFT);
|
||||
lispobj symbol = tlsindex_to_symbol_map[logical_index];
|
||||
gc_assert(symbol != NO_TLS_VALUE_MARKER);
|
||||
//fprintf(stderr, "TLS trap handled: %s\n", (char*)VECTOR(SYMBOL(symbol)->name)->data);
|
||||
struct thread* th = get_sb_vm_thread();
|
||||
lispobj* pcell = (lispobj*)(disp + (char*)th);
|
||||
lispobj value = pcell[1];
|
||||
if (value != NO_TLS_VALUE_MARKER)
|
||||
lose("TLS should not trap on thread-locally bound symbol");
|
||||
*pcell = symbol;
|
||||
// Restart the 2-instruction sequence
|
||||
OS_CONTEXT_PC(context) = (os_context_register_t)pc;
|
||||
return 1;
|
||||
}
|
||||
|
||||
#include "x86-arch-shared.inc"
|
||||
|
|
|
|||
|
|
@ -61,9 +61,12 @@ echo "::: Running :DYNAMIC-SPACE-SIZE-ARG"
|
|||
run_sbcl_with_core "$tmpcore" --noinform --control-stack-size 640KB \
|
||||
--tls-limit 5000 \
|
||||
--dynamic-space-size 260MB --no-userinit --no-sysinit --noprint <<EOF
|
||||
(defconstant tls-element-size
|
||||
(* (if (find :tls-load-indirect sb-impl:+internal-features+) 2 1)
|
||||
sb-vm:n-word-bytes))
|
||||
(assert (eql (extern-alien "thread_control_stack_size" unsigned) (* 640 1024)))
|
||||
(assert (eql (extern-alien "dynamic_values_bytes" (unsigned 32))
|
||||
(* 5000 sb-vm:n-word-bytes)))
|
||||
(* 5000 tls-element-size)))
|
||||
; allow slight shrinkage if heap relocation has to adjust for alignment
|
||||
(defun dynamic-space-size-good-p ()
|
||||
(<= 0 (- (* 260 1048576) (dynamic-space-size)) 65536))
|
||||
|
|
@ -73,9 +76,12 @@ EOF
|
|||
chmod u+x "${tmpcore}2"
|
||||
echo "::: INFO: prepared test core"
|
||||
./"${tmpcore}2" --no-userinit --no-sysinit --noprint <<EOF
|
||||
(defconstant tls-element-size
|
||||
(* (if (find :tls-load-indirect sb-impl:+internal-features+) 2 1)
|
||||
sb-vm:n-word-bytes))
|
||||
(when (and (eql (extern-alien "thread_control_stack_size" unsigned) (* 640 1024))
|
||||
(eql (extern-alien "dynamic_values_bytes" (unsigned 32))
|
||||
(* 5000 sb-vm:n-word-bytes))
|
||||
(* 5000 tls-element-size))
|
||||
(dynamic-space-size-good-p))
|
||||
(exit :code 42))
|
||||
EOF
|
||||
|
|
|
|||
|
|
@ -314,7 +314,10 @@
|
|||
(sleep 3))
|
||||
(mapc #'terminate-thread threads))))
|
||||
|
||||
(with-test (:name :test-%thread-local-references)
|
||||
(with-test (:name :test-%thread-local-references
|
||||
;; test is doing something very suspicious
|
||||
;; and needs to be rewritten to not do that
|
||||
:skipped-on :tls-load-indirect)
|
||||
(let ((mysym (gensym))
|
||||
(fool1 (cons 1 2))
|
||||
(fool2 (cons 2 3)))
|
||||
|
|
|
|||
|
|
@ -115,9 +115,11 @@
|
|||
;; 480F44142538F94B20 CMOVEQ RDX, [#x204BF938] ; *PRINT-BASE*
|
||||
;; (TODO: could use "CMOVEQ RDX, [RIP-n]" in immobile code)
|
||||
(let ((text (disasm-load 0 '*print-base*)))
|
||||
#+tls-load-indirect (assert (= (length text) 2)) ; number of lines
|
||||
#-tls-load-indirect (progn
|
||||
(assert (= (length text) 3)) ; number of lines
|
||||
;; two lines should be annotated with *PRINT-BASE*
|
||||
(assert (= (loop for line in text count (search "*PRINT-BASE*" line)) 2)))
|
||||
(assert (= (loop for line in text count (search "*PRINT-BASE*" line)) 2))))
|
||||
|
||||
;; When symbol SC is CONSTANT:
|
||||
;; 498B9578290000 MOV RDX, [R13+disp] ; tls: FOO
|
||||
|
|
@ -125,9 +127,11 @@
|
|||
;; 83FA61 CMP EDX, 97
|
||||
;; 480F4450F9 CMOVEQ RDX, [RAX-7]
|
||||
(let ((text (disasm-load 0 'foo)))
|
||||
#+tls-load-indirect (assert (= (length text) 2)) ; number of lines
|
||||
#-tls-load-indirect (progn
|
||||
(assert (= (length text) 4))
|
||||
;; two lines should be annotated with FOO
|
||||
(assert (= (loop for line in text count (search "FOO" line)) 2))))
|
||||
(assert (= (loop for line in text count (search "FOO" line)) 2)))))
|
||||
|
||||
(defvar *blub*) ; immobile space
|
||||
(defvar blub) ; dynamic space
|
||||
|
|
@ -1430,11 +1434,29 @@
|
|||
|
||||
#+sb-thread
|
||||
(with-test (:name :tls-symbol-map)
|
||||
(let ((sap (sb-sys:int-sap (ash (symbol-value 'sb-vm::*tls-symbol-map*)
|
||||
sb-vm:n-fixnum-tag-bits)))
|
||||
(let ((sap (sb-sys:int-sap (ash sb-vm::*tls-symbol-map* sb-vm:n-fixnum-tag-bits)))
|
||||
(limit (ash (ash sb-vm::*free-tls-index* sb-vm:n-fixnum-tag-bits)
|
||||
(- sb-vm:word-shift))))
|
||||
(dotimes (i limit)
|
||||
(unless (= (sb-sys:sap-ref-word sap (ash i sb-vm:word-shift)) sb-vm:no-tls-value-marker)
|
||||
(let ((sym (sb-sys:sap-ref-lispobj sap (ash i sb-vm:word-shift))))
|
||||
(assert (= (sb-kernel:symbol-tls-index sym) (ash i sb-vm:word-shift))))))))
|
||||
(- sb-vm:word-shift)))
|
||||
(divisor (or #+tls-load-indirect 16 8)))
|
||||
(loop for i from (or #+tls-load-indirect (ash (sb-kernel:symbol-tls-index '*package*)
|
||||
(- (1+ sb-vm:word-shift)))
|
||||
1)
|
||||
below limit
|
||||
unless (= (sb-sys:sap-ref-word sap (ash i sb-vm:word-shift)) sb-vm:no-tls-value-marker)
|
||||
do (let ((sym (sb-sys:sap-ref-lispobj sap (ash i sb-vm:word-shift))))
|
||||
(assert (= (floor (sb-kernel:symbol-tls-index sym) divisor) i))))))
|
||||
|
||||
#+sb-thread
|
||||
(with-test (:name :tls-index-validity :skipped-on (:not :tls-load-indirect))
|
||||
(let ((index-of-package (ash (sb-kernel:symbol-tls-index '*package*)
|
||||
(- sb-vm:word-shift))))
|
||||
(do-all-symbols (sym)
|
||||
(let ((index (ash (sb-kernel:symbol-tls-index sym) (- sb-vm:word-shift))))
|
||||
(when (plusp index)
|
||||
;; Every TLS slot below *PACKAGE* corresponds to an always-thread-local special.
|
||||
(if (< index index-of-package)
|
||||
(assert (typep (sb-int:info :variable :wired-tls sym)
|
||||
'(or (eql :always-thread-local) integer)))
|
||||
(assert (oddp index)))
|
||||
;; No always-thread-local special clashes with *PACKAGE*'s indirection cell
|
||||
(assert (/= index (1- index-of-package))))))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue