common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

x86-64: fix code bloat with #+gs-seg

Browse source 
(formerly known as #+gs-segment-thread)
THREAD-TN is no longer a global symbol macro if #+gs-seg.
Instead we move GS: into a GPR inside most of the allocation vops,
which solves the performance degradation and coincidentally
seems to help with lp#1946009.
This commit is contained in:
Douglas Katzman 2021-10-20 11:17:41 -04:00
parent 4e2a336312
commit 215c0adcb3
20 changed files with 167 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
src/assembly/x86-64/alloc.lisp
View file

@ -23,13 +23,13 @@
,@(cond
((eq reg 'r12) ; problematic case for INSTRUMENT-ALLOC
'((inst push rax-tn)
(alloc-other bignum-widetag (+ bignum-digits-offset 1) rax-tn nil nil)
(alloc-other bignum-widetag (+ bignum-digits-offset 1) rax-tn nil nil nil)
(storew number rax-tn bignum-digits-offset other-pointer-lowtag)
(inst mov number rax-tn)
(inst pop rax-tn)))
(t
'((inst push number)
(alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil)
(alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil nil)
(popw number bignum-digits-offset other-pointer-lowtag))))))
(unsigned (reg)
`(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg))
@ -41,13 +41,13 @@
'((inst push rax-tn)
(inst jmp :ns one-word-bignum)
;; Two word bignum
(alloc-other bignum-widetag (+ bignum-digits-offset 2) rax-tn nil nil)
(alloc-other bignum-widetag (+ bignum-digits-offset 2) rax-tn nil nil nil)
(storew number rax-tn bignum-digits-offset other-pointer-lowtag)
(inst mov number rax-tn)
(inst pop rax-tn)
(inst ret)
ONE-WORD-BIGNUM
(alloc-other bignum-widetag (+ bignum-digits-offset 1) rax-tn nil nil)
(alloc-other bignum-widetag (+ bignum-digits-offset 1) rax-tn nil nil nil)
(storew number rax-tn bignum-digits-offset other-pointer-lowtag)
(inst mov number rax-tn)
(inst pop rax-tn)))
@ -55,18 +55,18 @@
'((inst push number)
(inst jmp :ns one-word-bignum)
;; Two word bignum
(alloc-other bignum-widetag (+ bignum-digits-offset 2) number nil nil)
(alloc-other bignum-widetag (+ bignum-digits-offset 2) number nil nil nil)
(popw number bignum-digits-offset other-pointer-lowtag)
(inst ret)
ONE-WORD-BIGNUM
(alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil)
(alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil nil)
(popw number bignum-digits-offset other-pointer-lowtag))))))
(define (op)
;; R13 is usually the thread register, but might not be
`(progn
,@(loop for reg in '(rax rcx rdx rbx rsi rdi
r8 r9 r10 r11 r12
#+gs-segment-thread r13
#+gs-seg r13
r14 r15)
collect `(,op ,reg)))))
(define signed)

4
src/assembly/x86-64/arith.lisp
View file

@ -54,7 +54,7 @@
(nbytes #+bignum-assertions 32 #-bignum-assertions 16))
(instrument-alloc bignum-widetag nbytes nil alloc-tn)
(pseudo-atomic ()
(allocation bignum-widetag nbytes 0 alloc-tn nil nil)
(allocation bignum-widetag nbytes 0 alloc-tn nil nil nil)
(storew* header alloc-tn 0 0 t)
(storew source alloc-tn bignum-digits-offset 0)
(if (eq dest alloc-tn)
@ -133,7 +133,7 @@
(inst cmp x rcx)
(inst jmp :e SINGLE-WORD-BIGNUM)
(alloc-other bignum-widetag (+ bignum-digits-offset 2) res nil nil)
(alloc-other bignum-widetag (+ bignum-digits-offset 2) res nil nil nil)
(storew rax res bignum-digits-offset other-pointer-lowtag)
(storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag)
(inst clc) (inst ret)

2
src/cold/build-order.lisp-expr
View file

@ -712,7 +712,7 @@
"src/code/describe-policy"
"src/code/inspect"
"src/code/profile"
#+(and x86-64 sb-thread (not gs-segment-thread)) "src/code/aprof" ; precise allocation profiler
#+(and x86-64 sb-thread (not gs-seg)) "src/code/aprof" ; precise allocation profiler
"src/code/step"
"src/code/warm-lib"
"src/code/alien-callback"

87
src/compiler/x86-64/alloc.lisp
View file

@ -86,14 +86,19 @@
;;; always requires a SIB byte, which doesn't fit in the reserved bytes
;;; of the instruction stream where hot patching occurs.
(defun instrument-alloc (type size node scratch-registers
&optional thread-temp
&aux (temp
(if (listp scratch-registers)
(dolist (reg scratch-registers
(first scratch-registers))
(unless (location= reg r12-tn) (return reg)))
scratch-registers)))
(declare (ignorable type))
(declare (ignorable type thread-temp))
(aver (not (location= temp r12-tn)))
;; Each allocation sequence has to call INSTRUMENT-ALLOC,
;; so we may as well take advantage of this fact to load the temp reg
;; here, if provided, rather than spewing more #+gs-seg tests around.
#+gs-seg (when thread-temp (inst rdgsbase thread-temp))
#+allocator-metrics
(let ((use-size-temp (not (typep size '(or (signed-byte 32) tn))))
(tally (gen-label))
@ -145,7 +150,7 @@
(let ((data temp)
(patch-loc (gen-label))
(skip-instrumentation (gen-label)))
(inst mov data (thread-slot-ea thread-profile-data-slot))
(inst mov data (thread-slot-ea thread-profile-data-slot thread-temp))
(inst test data data)
;; This instruction is modified to "JMP :z" when profiling is
;; partially enabled. After the buffer is assigned, it becomes
@ -187,8 +192,9 @@
;;; A mnemonic device for the argument pattern here:
;;; 1. what to allocate: type, size, lowtag describe the object
;;; 2. where to put the result
;;; 3. node (for determining immobile-space-p) and a scratch register
(defun allocation (type size lowtag alloc-tn node temp)
;;; 3. node (for determining immobile-space-p) and a scratch register or two
(defun allocation (type size lowtag alloc-tn node temp thread-temp)
(declare (ignorable thread-temp))
(flet ((fallback (size)
;; Call an allocator trampoline and get the result in the proper register.
;; There are 2 choices of trampoline to invoke alloc() or alloc_list()
@ -210,15 +216,15 @@
(inst pop alloc-tn)))
(let* ((NOT-INLINE (gen-label))
(DONE (gen-label))
(free-pointer #+sb-thread (thread-slot-ea thread-boxed-tlab-slot)
(free-pointer #+sb-thread (thread-slot-ea thread-boxed-tlab-slot #+gs-seg thread-temp)
#-sb-thread (ea boxed-region))
(end-addr (ea thread-segment-reg
(end-addr (ea (sb-x86-64-asm::ea-segment free-pointer)
(+ n-word-bytes (ea-disp free-pointer))
(ea-base free-pointer))))
(cond ((typep size `(integer ,large-object-size))
;; large objects will never be made in a per-thread region
(fallback size)
(unless (= lowtag 0) (inst or :byte alloc-tn lowtag)))
(when (/= lowtag 0) (inst or :byte alloc-tn lowtag)))
((and (tn-p size) (location= size alloc-tn))
(aver (and temp (not (location= temp size))))
(inst mov temp free-pointer)
@ -228,7 +234,7 @@
(inst jmp :a NOT-INLINE)
(inst mov free-pointer temp)
(emit-label DONE)
(unless (= lowtag 0) (inst or :byte alloc-tn lowtag))
(when (/= lowtag 0) (inst or :byte alloc-tn lowtag))
(assemble (:elsewhere)
(emit-label NOT-INLINE)
(inst sub temp alloc-tn) ; new-free-ptr - old-free-ptr = size
@ -272,8 +278,9 @@
;;; Allocate an other-pointer object of fixed NWORDS with a single-word
;;; header having the specified WIDETAG value. The result is placed in
;;; RESULT-TN. NWORDS counts the header word.
(defun alloc-other (widetag nwords result-tn node alloc-temp
(defun alloc-other (widetag nwords result-tn node alloc-temp thread-temp
&aux (bytes (pad-data-block nwords)))
(declare (ignorable thread-temp))
(let ((header (compute-object-header nwords widetag)))
#+bignum-assertions
(when (= widetag bignum-widetag) (setq bytes (* bytes 2))) ; use 2x the space
@ -282,20 +289,20 @@
;; Therefore, allocate into RAX but save it in RESULT-TN
;; and then switch them back.
(inst mov result-tn rax-tn)
(instrument-alloc widetag bytes node rax-tn)
(pseudo-atomic ()
(allocation nil bytes other-pointer-lowtag rax-tn node nil)
(instrument-alloc widetag bytes node rax-tn thread-temp)
(pseudo-atomic (:thread-tn thread-temp)
(allocation nil bytes other-pointer-lowtag rax-tn node nil thread-temp)
(storew* header rax-tn 0 other-pointer-lowtag t))
(inst xchg rax-tn result-tn))
(t
(instrument-alloc widetag bytes node result-tn)
(instrument-alloc widetag bytes node result-tn thread-temp)
(pseudo-atomic ()
(cond (alloc-temp
(allocation nil bytes 0 result-tn node alloc-temp)
(allocation nil bytes 0 result-tn node alloc-temp thread-temp)
(storew* header result-tn 0 0 t)
(inst or :byte result-tn other-pointer-lowtag))
(t
(allocation nil bytes other-pointer-lowtag result-tn node nil)
(allocation nil bytes other-pointer-lowtag result-tn node nil thread-temp)
(storew* header result-tn 0 other-pointer-lowtag t))))))))
;;;; CONS, LIST and LIST*
@ -303,6 +310,7 @@
(:args (things :more t :scs (descriptor-reg constant immediate)))
(:temporary (:sc unsigned-reg) ptr temp)
(:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:info star cons-cells)
(:results (result :scs (descriptor-reg)))
(:node-var node)
@ -323,11 +331,11 @@
(size (* (pad-data-block cons-size) cons-cells))
(lowtag (if (<= cons-cells 2) 0 list-pointer-lowtag)))
(unless stack-allocate-p
(instrument-alloc 'list size node (list ptr temp)))
(pseudo-atomic (:elide-if stack-allocate-p)
(instrument-alloc 'list size node (list ptr temp) thread-tn))
(pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn)
(if stack-allocate-p
(stack-allocation size lowtag res)
(allocation 'list size lowtag res node temp))
(allocation 'list size lowtag res node temp thread-tn))
(multiple-value-bind (last-base-reg lowtag car cdr)
(case cons-cells
(1
@ -486,6 +494,7 @@
(:arg-types #+ubsan (:constant t)
positive-fixnum positive-fixnum positive-fixnum)
(:temporary (:sc unsigned-reg) temp)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:policy :fast-safe)
(:node-var node)
(:generator 100
@ -502,7 +511,7 @@
(let ((nbytes (calc-shadow-bits-size result)))
(pseudo-atomic ()
;; Allocate the bits into RESULT
(allocation nil nbytes 0 result node temp)
(allocation nil nbytes 0 result node temp nil)
(inst mov :byte (ea result) simple-bit-vector-widetag)
(inst mov :dword (vector-len-ea result 0)
(if (sc-is length immediate) (fixnumize (tn-value length)) length))
@ -538,9 +547,9 @@
(#.simple-vector-widetag 'simple-vector)
(t 'unboxed-array))
type)
size-tn node instrumentation-temp)
(pseudo-atomic ()
(allocation nil size-tn 0 result node alloc-temp)
size-tn node instrumentation-temp thread-tn)
(pseudo-atomic (:thread-tn thread-tn)
(allocation nil size-tn 0 result node alloc-temp thread-tn)
(put-header result 0 type length t alloc-temp)
(inst or :byte result other-pointer-lowtag)))
#+ubsan
@ -692,15 +701,16 @@
(:policy :fast-safe)
(:node-var node)
(:temporary (:sc descriptor-reg) tail next limit)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:generator 20
(let ((size (calc-size-in-bytes length tail))
(entry (gen-label))
(loop (gen-label))
(no-init
(and (sc-is element immediate) (eql (tn-value element) 0))))
(instrument-alloc 'list size node (list next limit))
(pseudo-atomic ()
(allocation 'list size list-pointer-lowtag result node limit)
(instrument-alloc 'list size node (list next limit) thread-tn)
(pseudo-atomic (:thread-tn thread-tn)
(allocation 'list size list-pointer-lowtag result node limit thread-tn)
(compute-end)
(inst mov next result)
(inst jmp entry)
@ -722,9 +732,10 @@
(:translate make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:results (result :scs (descriptor-reg) :from :argument))
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread)
(:node-var node)
(:generator 37
(alloc-other fdefn-widetag fdefn-size result node nil)
(alloc-other fdefn-widetag fdefn-size result node nil thread)
(storew name result fdefn-name-slot other-pointer-lowtag)
(storew nil-value result fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup 'undefined-tramp :assembly-routine)
@ -734,6 +745,7 @@
; (:args (function :to :save :scs (descriptor-reg)))
(:info label length stack-allocate-p)
(:temporary (:sc any-reg) temp)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 10
@ -741,11 +753,11 @@
(bytes (pad-data-block words))
(header (logior (ash (1- words) n-widetag-bits) closure-widetag)))
(unless stack-allocate-p
(instrument-alloc closure-widetag bytes node (list result temp)))
(pseudo-atomic (:elide-if stack-allocate-p)
(instrument-alloc closure-widetag bytes node (list result temp) thread-tn))
(pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn)
(if stack-allocate-p
(stack-allocation bytes fun-pointer-lowtag result)
(allocation nil bytes fun-pointer-lowtag result node temp))
(allocation nil bytes fun-pointer-lowtag result node temp thread-tn))
(storew* #-immobile-space header ; write the widetag and size
#+immobile-space ; ... plus the layout pointer
(progn (inst mov temp header)
@ -767,6 +779,7 @@
(define-vop (make-value-cell)
(:args (value :scs (descriptor-reg any-reg) :to :result))
(:results (result :scs (descriptor-reg) :from :eval))
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:info stack-allocate-p)
(:node-var node)
(:generator 10
@ -775,7 +788,7 @@
(let ((header (compute-object-header value-cell-size value-cell-widetag)))
(storew header result 0 other-pointer-lowtag)))
(t
(alloc-other value-cell-widetag value-cell-size result node nil)))
(alloc-other value-cell-widetag value-cell-size result node nil thread-tn)))
(storew value result value-cell-value-slot other-pointer-lowtag)))
;;;; automatic allocators for primitive objects
@ -795,6 +808,7 @@
(:info name words type lowtag stack-allocate-p)
(:results (result :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) alloc-temp)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
(:generator 50
(let* ((instancep (typep type 'wrapper)) ; is this an instance type?
@ -803,13 +817,13 @@
(when (eq type bignum-widetag) (setq bytes (* bytes 2))) ; use 2x the space
(progn name) ; possibly not used
(unless stack-allocate-p
(instrument-alloc type bytes node (list result alloc-temp)))
(pseudo-atomic (:elide-if stack-allocate-p)
(instrument-alloc type bytes node (list result alloc-temp) thread-tn))
(pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn)
;; If storing a header word, defer ORing in the lowtag until after
;; the header is written so that displacement can be 0.
(if stack-allocate-p
(stack-allocation bytes (if type 0 lowtag) result)
(allocation nil bytes (if type 0 lowtag) result node alloc-temp))
(allocation nil bytes (if type 0 lowtag) result node alloc-temp thread-tn))
(when type
(let* ((widetag (if instancep instance-widetag type))
(header (compute-object-header words widetag)))
@ -844,6 +858,7 @@
(:temporary (:sc unsigned-reg :from :eval :to :result) header)
;; KLUDGE: wire to RAX so that it doesn't get R12
(:temporary (:sc unsigned-reg :offset 0) alloc-temp)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
(:generator 50
;; With the exception of bignums, these objects have effectively
@ -866,9 +881,9 @@
;; can't pass RESULT as a possible choice of scratch register
;; because it might be in the same physical reg as BYTES.
;; Yup, the lifetime specs in this vop are pretty confusing.
(instrument-alloc type bytes node alloc-temp)
(pseudo-atomic ()
(allocation nil bytes lowtag result node alloc-temp)
(instrument-alloc type bytes node alloc-temp thread-tn)
(pseudo-atomic (:thread-tn thread-tn)
(allocation nil bytes lowtag result node alloc-temp thread-tn)
(storew header result 0 lowtag))))))
(macrolet ((c-call (name)

7
src/compiler/x86-64/array.lisp
View file

@ -70,6 +70,7 @@
(:temporary (:sc any-reg :to :eval) bytes)
(:temporary (:sc any-reg :to :result) header)
(:temporary (:sc unsigned-reg) temp)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:results (result :scs (descriptor-reg) :from :eval))
(:node-var node)
(:generator 13
@ -83,9 +84,9 @@
(inst shl :dword header array-rank-byte-pos)
(inst or :dword header type)
(inst shr :dword header n-fixnum-tag-bits)
(instrument-alloc nil bytes node temp)
(pseudo-atomic ()
(allocation nil bytes 0 result node temp)
(instrument-alloc nil bytes node temp thread-tn)
(pseudo-atomic (:thread-tn thread-tn)
(allocation nil bytes 0 result node temp thread-tn)
(storew header result 0 0)
(inst or :byte result other-pointer-lowtag))))

7
src/compiler/x86-64/call.lisp
View file

@ -1298,6 +1298,7 @@
(:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
;; Note that DST conflicts with RESULT because we use both as temps
(:temporary (:sc unsigned-reg) value dst)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 20
@ -1313,12 +1314,12 @@
(inst mov result nil-value)
(inst jrcxz DONE)
(unless stack-allocate-p
(instrument-alloc 'list rcx node (list value dst)))
(pseudo-atomic (:elide-if stack-allocate-p)
(instrument-alloc 'list rcx node (list value dst) thread-tn))
(pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn)
;; Produce an untagged pointer into DST
(if stack-allocate-p
(stack-allocation rcx 0 dst)
(allocation 'list rcx 0 dst node value))
(allocation 'list rcx 0 dst node value thread-tn))
;; Recalculate DST as a tagged pointer to the last cons
(inst lea dst (ea (- list-pointer-lowtag (* cons-size n-word-bytes)) dst rcx))
(inst shr :dword rcx (1+ word-shift)) ; convert bytes to number of cells

10
src/compiler/x86-64/cell.lisp
View file

@ -131,11 +131,11 @@
(compute-virtual-symbol ()
`(progn
(inst mov :dword cell (tls-index-of symbol))
#+gs-segment-thread (inst rdgsbase thread-temp)
#+gs-seg (inst rdgsbase thread-temp)
(inst lea cell
(ea (- other-pointer-lowtag (ash symbol-value-slot word-shift))
#+gs-segment-thread thread-temp
#-gs-segment-thread thread-tn
#+gs-seg thread-temp
#-gs-seg thread-tn
cell))
(inst cmp :dword (symbol-value-slot-ea cell) ; TLS reference
no-tls-value-marker-widetag)
@ -155,7 +155,7 @@
:from (:argument 1) :to (:result 0)) rax)
#+sb-thread
(:temporary (:sc descriptor-reg :to (:result 0)) cell)
#+gs-segment-thread (:temporary (:sc unsigned-reg) thread-temp)
#+gs-seg (:temporary (:sc unsigned-reg) thread-temp)
(:results (result :scs (descriptor-reg any-reg)))
(:policy :fast-safe)
(:vop-var vop)
@ -206,7 +206,7 @@
(value :scs (descriptor-reg any-reg immediate)))
(:temporary (:sc descriptor-reg) cell)
(:temporary (:sc unsigned-reg) val-temp)
#+gs-segment-thread (:temporary (:sc unsigned-reg) thread-temp)
#+gs-seg (:temporary (:sc unsigned-reg) thread-temp)
(:generator 4
;; Compute the address into which to store. CMOV can only move into
;; a register, so we can't conditionally move into the TLS and

9
src/compiler/x86-64/float.lisp
View file

@ -173,8 +173,9 @@
(:results (y :scs (descriptor-reg)))
(:node-var node)
(:note "float to pointer coercion")
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:generator 13
(alloc-other double-float-widetag double-float-size y node nil)
(alloc-other double-float-widetag double-float-size y node nil thread-tn)
(inst movsd (ea-for-df-desc y) x)))
(define-move-vop move-from-double :move
(double-reg) (descriptor-reg))
@ -225,10 +226,11 @@
(define-vop (move-from-complex-single)
(:args (x :scs (complex-single-reg) :to :save))
(:results (y :scs (descriptor-reg)))
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
(:note "complex float to pointer coercion")
(:generator 13
(alloc-other complex-single-float-widetag complex-single-float-size y node nil)
(alloc-other complex-single-float-widetag complex-single-float-size y node nil thread-tn)
(inst movlps (ea-for-csf-data-desc y) x)))
(define-move-vop move-from-complex-single :move
(complex-single-reg) (descriptor-reg))
@ -236,10 +238,11 @@
(define-vop (move-from-complex-double)
(:args (x :scs (complex-double-reg) :to :save))
(:results (y :scs (descriptor-reg)))
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
(:note "complex float to pointer coercion")
(:generator 13
(alloc-other complex-double-float-widetag complex-double-float-size y node nil)
(alloc-other complex-double-float-widetag complex-double-float-size y node nil thread-tn)
(inst movapd (ea-for-cdf-data-desc y) x)))
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))

9
src/compiler/x86-64/insts.lisp
View file

@ -891,7 +891,7 @@
;;;; the effective-address (ea) structure
(defstruct (ea (:constructor %ea (segment disp base index scale))
(:copier nil))
(segment nil :type (member nil :gs) :read-only t)
(segment nil :type (member :cs :gs) :read-only t)
(base nil :type (or tn null) :read-only t)
(index nil :type (or tn null) :read-only t)
(scale 1 :type (member 1 2 4 8) :read-only t)
@ -946,12 +946,9 @@
;;;
(defun ea (&rest args) ; seg displacement base index scale
(declare (dynamic-extent args))
(let (seg disp)
(let ((seg :cs) disp)
(let ((first (car args)))
(case first
;; Let's say that if you put :CS, it's as if you had put nothing,
;; which makes the positional syntax consistent and unambiguous
;; (becase I can't use NIL for that, which implies no base register)
(:gs (setq seg first) (pop args))
(:cs (pop args))))
(let ((first (car args)))
@ -972,7 +969,7 @@
(%ea seg 0 base index scale)))))
(defun rip-relative-ea (label &optional addend)
(%ea nil (if addend (make-label+addend label addend) label) rip-tn nil 1))
(%ea :cs (if addend (make-label+addend label addend) label) rip-tn nil 1))
(defun emit-byte-displacement-backpatch (segment target)
(emit-back-patch segment 1

26
src/compiler/x86-64/macros.lisp
View file

@ -93,8 +93,7 @@
(- other-pointer-lowtag))))
(defun thread-tls-ea (index)
#+gs-segment-thread (ea :gs index) ; INDEX is either a DISP or a BASE of the EA
#-gs-segment-thread
#+gs-seg (ea :gs index) ; INDEX is either a DISP or a BASE of the EA
;; Whether index is an an integer or a register, the EA constructor
;; call is the same.
;; Due to an encoding peculiarity, using thread-base-reg as the index register
@ -103,7 +102,7 @@
;; RIP-relative addressing. (And attempting to encode an index is illegal)
;; So the 'mod' bits must be nonzero, which mandates encoding of an
;; explicit displacement of 0. Using INDEX as base avoids the extra byte.
(ea index thread-tn))
#-gs-seg (ea index thread-tn))
;;; assert that alloc-region->free_pointer and ->end_addr can be accessed
;;; using a single byte displacement from thread-tn
@ -111,8 +110,15 @@
(aver (<= (1+ thread-boxed-tlab-slot) 15))
(aver (<= (1+ thread-unboxed-tlab-slot) 15)))
(defun thread-slot-ea (slot-index)
(ea thread-segment-reg (ash slot-index word-shift) thread-tn))
;;; Access a thread slot at a fixed index. If GPR-TN is provided,
;;; then it points to 'struct thread', which is relevant only if
;;; #+gs-seg.
(defun thread-slot-ea (slot-index &optional gpr-tn)
(if gpr-tn
(ea (ash slot-index word-shift) gpr-tn)
;; Otherwise do something depending on #[-+]gs-seg
(let (#+gs-seg (thread-tn nil))
(ea thread-segment-reg (ash slot-index word-shift) thread-tn))))
#+sb-thread
(progn
@ -197,14 +203,20 @@
;; (Ideally we'd only do 1 pointer bump, but that's a separate issue)
(inst test :byte rax-tn (ea (- static-space-start gc-safepoint-trap-offset))))
(defmacro pseudo-atomic ((&key elide-if) &rest forms)
;;; This macro is purposely unhygienic with respect to THREAD-TN,
;;; which is either a global symbol macro, or a LET-bound variable,
;;; depending on #+gs-seg.
(defmacro pseudo-atomic ((&key ((:thread-tn thread)) elide-if) &rest forms)
(declare (ignorable thread))
#+sb-safepoint
`(progn ,@forms (unless ,elide-if (emit-safepoint)))
#-sb-safepoint
(with-unique-names (label pa-bits-ea)
`(let ((,label (gen-label))
(,pa-bits-ea
#+sb-thread (thread-slot-ea thread-pseudo-atomic-bits-slot)
#+sb-thread (thread-slot-ea
thread-pseudo-atomic-bits-slot
#+gs-seg ,@(if thread (list thread)))
#-sb-thread (static-symbol-value-ea '*pseudo-atomic-bits*)))
(unless ,elide-if
(inst mov ,pa-bits-ea rbp-tn))

1
src/compiler/x86-64/pred.lisp
View file

@ -309,6 +309,7 @@
(:generator 3
(let* ((x (tn-value x-tn))
(y (tn-value y-tn))
#+gs-seg (thread-tn nil)
(hint (computable-from-flags-p res x y flags))
(flag (car flags)))
(ecase hint

3
src/compiler/x86-64/sap.lisp
View file

@ -27,10 +27,11 @@
(define-vop (move-from-sap)
(:args (sap :scs (sap-reg) :to :result))
(:results (res :scs (descriptor-reg) :from :argument))
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:note "SAP to pointer coercion")
(:node-var node)
(:generator 20
(alloc-other sap-widetag sap-size res node nil)
(alloc-other sap-widetag sap-size res node nil thread-tn)
(storew sap res sap-pointer-slot other-pointer-lowtag)))
(define-move-vop move-from-sap :move
(sap-reg) (descriptor-reg))

6
src/compiler/x86-64/simd-pack-256.lisp
View file

@ -89,10 +89,11 @@
(define-vop (move-from-avx2)
(:args (x :scs (single-avx2-reg double-avx2-reg int-avx2-reg)))
(:results (y :scs (descriptor-reg)))
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
(:note "AVX2 to pointer coercion")
(:generator 13
(alloc-other simd-pack-256-widetag simd-pack-256-size y node nil)
(alloc-other simd-pack-256-widetag simd-pack-256-size y node nil thread-tn)
;; see *simd-pack-element-types*
(storew (fixnumize
(sc-case x
@ -205,9 +206,10 @@
(:arg-types tagged-num unsigned-num unsigned-num unsigned-num unsigned-num)
(:results (dst :scs (descriptor-reg) :from :load))
(:result-types t)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
(:generator 13
(alloc-other simd-pack-256-widetag simd-pack-256-size dst node nil)
(alloc-other simd-pack-256-widetag simd-pack-256-size dst node nil thread-tn)
;; see *simd-pack-element-types*
(storew tag dst simd-pack-256-tag-slot other-pointer-lowtag)
(storew p0 dst simd-pack-256-p0-slot other-pointer-lowtag)

6
src/compiler/x86-64/simd-pack.lisp
View file

@ -83,10 +83,11 @@
(define-vop (move-from-sse)
(:args (x :scs (single-sse-reg double-sse-reg int-sse-reg)))
(:results (y :scs (descriptor-reg)))
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
(:note "SSE to pointer coercion")
(:generator 13
(alloc-other simd-pack-widetag simd-pack-size y node nil)
(alloc-other simd-pack-widetag simd-pack-size y node nil thread-tn)
;; see *simd-pack-element-types*
(storew (fixnumize
(sc-case x
@ -185,9 +186,10 @@
(:arg-types tagged-num unsigned-num unsigned-num)
(:results (dst :scs (descriptor-reg) :from :load))
(:result-types t)
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
(:generator 13
(alloc-other simd-pack-widetag simd-pack-size dst node nil)
(alloc-other simd-pack-widetag simd-pack-size dst node nil thread-tn)
;; see *simd-pack-element-types*
(storew tag dst simd-pack-tag-slot other-pointer-lowtag)
(storew lo dst simd-pack-lo-value-slot other-pointer-lowtag)

7
src/compiler/x86-64/system.lisp
View file

@ -404,9 +404,10 @@
(:arg-types tagged-num)
(:policy :fast-safe)
(:generator 2
(inst mov sap
(ea thread-segment-reg thread-tn
index (ash 1 (- word-shift n-fixnum-tag-bits)))))))
(let (#+gs-seg (thread-tn nil))
(inst mov sap
(ea thread-segment-reg thread-tn
index (ash 1 (- word-shift n-fixnum-tag-bits))))))))
(define-vop (halt)
(:generator 1

4
src/compiler/x86-64/target-insts.lisp
View file

@ -403,8 +403,8 @@
dstate))))
;; thread slots
((and (eql base-reg sb-vm::thread-reg)
#+gs-segment-thread (dstate-getprop dstate +gs-segment+)
#-gs-segment-thread (not (dstate-getprop dstate +fs-segment+)) ; not system TLS
#+gs-seg (dstate-getprop dstate +gs-segment+)
#-gs-seg (not (dstate-getprop dstate +fs-segment+)) ; not system TLS
(not index-reg) ; no index
(typep disp '(integer 0 *)) ; positive displacement
(zerop (logand disp 7))) ; lispword-aligned

49
src/compiler/x86-64/vm.lisp
View file

@ -13,6 +13,25 @@
;;;; register specs
;;; Observe that [R12 + displacement] needs an extra byte of encoding in
;;; certain addressing modes, as does [R13 + index]
;;; 49895B08 MOV [R11+8], RBX
;;; 49895C2408 MOV [R12+8], RBX
;;; 49895D08 MOV [R13+8], RBX
;;; 49891C03 MOV [R11+RAX], RBX
;;; 49891C04 MOV [R12+RAX], RBX
;;; 49895C0500 MOV [R13+RAX], RBX
;;; This is because 12 and 13 are equal-mod-8 to 4 and 5, the indices of RSP
;;; and RBP respectively, which have different behaviors in the ModRegR/M byte.
;;; So due to lack of perfectly orthogonal encodings, it would be slightly
;;; beneficial to hint to the register allocator that it should pick registers
;;; 12 and 13 only when all other registers are unavailable.
;;; And you might think that it should "work" simply to list the usable offsets
;;; in the SC in the order in which they should be chosen when the register
;;; allocator needs to pick the next available register, but unfortunately
;;; it does not work to do that, because it uses bitmaps from which to pick,
;;; and not an ordered list.
;;; A register that's never used by the code generator, and can therefore
;;; be used as an assembly temporary in cases where a VOP :TEMPORARY can't
;;; be used.
@ -23,12 +42,34 @@
#+ubsan (progn (define-symbol-macro temp-reg-tn r11-tn)
(defconstant global-temp-reg 11))
#+gs-segment-thread
#+gs-seg
(progn
;; There is no permanent THREAD-TN. There are a few problems in trying
;; cleverly to make PSEUDO-ATOMIC agnostic of whether you're using a global
;; THREAD-TN or a local one (a global symbol macro vs. a let binding)
;; 1) ECL seems to think that it is an error to LET bind a global symbol macro.
;; > (define-symbol-macro thread-tn 'wat)
;; > (defun f (&optional (thread-tn thread-tn)) (format t "Hi: ~a~%" thread-tn))
;; > (compile'f)
;; ;;; Error:
;; ;;; * The constant THREAD-TN is being bound.
;; 2) It actually doesn't completely work completely anyway,
;; because pseudo-atomic needs to know not to use a segment override,
;; and TNs don't indicate a memory segment.
;; While the second problem could be solved, the first can't,
;; and it's not clear to me whether ECL is wrong to say it's an error,
;; or SBCL is remiss in choosing not to style-warn (which would annoy me
;; for that reason).
;; So we wire the thread structure to r15 within some vops when convenient.
;; Wiring to r15 is not strictly necessary, but I want to see if sb-aprof
;; can be made to work slightly easier regardless of #+gs-seg.
;; And with 15 being the highest register number, it is the least likely
;; to be picked by the register allocator for anything else.
;; Additionally I'd like to have an optimization pass that avoids reloading
;; r15 when consecutive allocation sequences occur in straight-line code.
(define-symbol-macro thread-segment-reg :gs)
(define-symbol-macro thread-reg nil)
(define-symbol-macro thread-tn nil))
#-gs-segment-thread
(define-symbol-macro thread-reg nil))
#-gs-seg
(progn
(define-symbol-macro thread-segment-reg :cs)
;; r13 is preferable to r12 because 12 is an alias of 4 in ModRegRM, which

2
src/runtime/thread.c
View file

@ -233,7 +233,7 @@ struct thread *alloc_thread_struct(void*,lispobj);
DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), \
GetCurrentProcess(), (LPHANDLE)&thread->os_thread, 0, TRUE, \
DUPLICATE_SAME_ACCESS)
#elif defined LISP_FEATURE_GS_SEGMENT_THREAD
#elif defined LISP_FEATURE_GS_SEG
#include <asm/prctl.h>
#include <sys/prctl.h>
extern int arch_prctl(int code, unsigned long *addr);

2
tests/aprof.impure.lisp
View file

@ -72,7 +72,7 @@ sb-vm::
(words (- (/ bytes n-word-bytes) vector-data-offset)))
(instrument-alloc nil bytes node temp)
(pseudo-atomic ()
(allocation nil bytes 0 result node temp)
(allocation nil bytes 0 result node temp nil)
(storew* simple-array-unsigned-byte-64-widetag result 0 0 t)
(storew* (fixnumize words) result vector-length-slot 0 t)
(inst or :byte result other-pointer-lowtag)))))

2
tests/parallel-exec.sh
View file

@ -30,7 +30,7 @@ TEST_DIRECTORY=$junkdir SBCL_HOME=../obj/sbcl-home exec ../src/runtime/sbcl \
(let ((*evaluator-mode* :compile))
(with-compilation-unit () (load"run-tests")))
#+(and x86-64 linux sb-thread)
(unless (find :gs-segment-thread sb-impl:+internal-features+)
(unless (find :gs-seg sb-impl:+internal-features+)
(push :test-aprof *features*))
(in-package run-tests)
(import '(sb-alien:alien-funcall sb-alien:extern-alien