master: Save avx512 state in separate alloc tramp routines
stassats via Sbcl-commits <[email protected]> Wed, 01 Jul 2026 03:38:50 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via b76c7fe95868bc720426fe88591fde5f94d8c453 (commit)
from bdc8c073cf1efd670012d59defeda3ac5a6449f4 (commit)
- Log -----------------------------------------------------------------
commit b76c7fe95868bc720426fe88591fde5f94d8c453
Author: Stas Boukarev <[email protected]>
Date: Wed Jul 1 05:47:40 2026 +0300
Save avx512 state in separate alloc tramp routines
---
src/assembly/x86-64/alloc.lisp | 197 +++++++++++++++++-----------------
src/assembly/x86-64/support.lisp | 55 +++++++---
src/assembly/x86-64/tramps.lisp | 90 ++++++++++------
src/compiler/generic/genesis.lisp | 2 +-
src/compiler/x86-64/alloc.lisp | 65 +++++++----
src/compiler/x86-64/avx2-insts.lisp | 6 +-
src/compiler/x86-64/avx512-insts.lisp | 12 +--
src/runtime/x86-64-arch.c | 15 +--
8 files changed, 264 insertions(+), 178 deletions(-)
diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp
index 4bf214461..f9af2092a 100644
--- a/src/assembly/x86-64/alloc.lisp
+++ b/src/assembly/x86-64/alloc.lisp
@@ -26,103 +26,106 @@
;;;; +BIGNUM-TO-Rxx : choose a 1, 2, or 3-digit bignum given [high:low] on stack,
;;;; ensuring that if the sign bit of the high word is on, the third digit
;;;; is zeroized to ensure that the result is a positive bignum.
-#+sb-assembling
-(macrolet
- ((alloc-other (&rest rest)
- `(emit-alloc-other nil thread-tn ,@rest))
- (signed (reg)
- `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg))
- ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
- (inst push number)
- (alloc-other bignum-widetag (+ bignum-digits-offset 1) number)
- (popw number bignum-digits-offset other-pointer-lowtag)))
- (unsigned (reg)
- `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg))
- ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
- (inst ror number (1+ n-fixnum-tag-bits)) ; restore unrotated value
- (inst test number number) ; rotates do not update SF
- (inst push number)
- (inst jmp :ns one-word-bignum)
- ;; Two word bignum
- (alloc-other bignum-widetag (+ bignum-digits-offset 2) number)
- (popw number bignum-digits-offset other-pointer-lowtag)
- (inst ret)
- ONE-WORD-BIGNUM
- (alloc-other bignum-widetag (+ bignum-digits-offset 1) number)
- (popw number bignum-digits-offset other-pointer-lowtag)))
- (from-digits (reg)
- ;; stack args:
- ;; +16 high-digit
- ;; +8 low-digit
- ;; rsp : return-pc
- `(define-assembly-routine (,(symbolicate "BIGNUM-TO-" reg) (:return-style :none))
- ((:temp result unsigned-reg ,(symbolicate reg "-OFFSET")))
- (inst test :byte result result) ; is-two-digit flag
- (inst jmp :z one-word-bignum)
- (alloc-other bignum-widetag (+ bignum-digits-offset 2) result)
- (inst movdqu float0-tn (ea 8 rsp-tn))
- (inst movdqu (object-slot-ea result 1 other-pointer-lowtag) float0-tn)
- (inst ret 16) ; pop args
- ONE-WORD-BIGNUM
- (alloc-other bignum-widetag (+ bignum-digits-offset 1) result)
- (inst movq float0-tn (ea 8 rsp-tn))
- (inst movq (object-slot-ea result 1 other-pointer-lowtag) float0-tn)
- (inst ret 16)))
- ;; "from unsigned" might need to allocate 3 digits, but it receives only high:low
- ;; because the highest digit if needed must be all 0.
- (from-digits-unsigned (reg)
- ;; stack args:
- ;; +16 high-digit
- ;; +8 low-digit
- ;; rsp : return-pc
- `(define-assembly-routine (,(symbolicate "+BIGNUM-TO-" reg) (:return-style :none))
- ((:temp result unsigned-reg ,(symbolicate reg "-OFFSET")))
- (inst test :byte result result) ; is-two-or-three-digit flag
- (inst jmp :z one-word-bignum)
- ;; Since 2 digits and 3 digits consume the same number of bytes
- ;; due to padding, they can share the allocation request.
- (alloc-other bignum-widetag (+ bignum-digits-offset 3) result)
- (inst movdqu float0-tn (ea 8 rsp-tn))
- (inst movdqu (object-slot-ea result 1 other-pointer-lowtag) float0-tn)
- ;; don't assume prezeroed unboxed pages. (zeroize word even if 2-digit result)
- (inst mov :qword (object-slot-ea result 3 other-pointer-lowtag) 0)
- ;; Test sign bit of digit index 1
- (inst test :byte (ea (+ 7 (ash (+ bignum-digits-offset 1) word-shift)
- (- other-pointer-lowtag)) result) #xff)
- (inst jmp :s SKIP) ; if signed, then keep all 3 digits
- ;; else, no sign bit, so change it to 2-digit bignum
- (inst mov :byte (ea (- 1 other-pointer-lowtag) result) 2)
- SKIP
- (inst ret 16) ; pop args
- ONE-WORD-BIGNUM
- (alloc-other bignum-widetag (+ bignum-digits-offset 1) result)
- (inst movq float0-tn (ea 8 rsp-tn))
- (inst movq (object-slot-ea result 1 other-pointer-lowtag) float0-tn)
- (inst ret 16)))
- ;; The high bit is in the carry flag.
- (two-word-bignum (reg)
- `(define-assembly-routine (,(symbolicate "TWO-WORD-BIGNUM-TO-" reg) (:return-style :none))
- ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
- (inst push number)
- (inst set :c number)
- (inst movzx '(:byte :dword) number number)
- (inst push number)
- (alloc-other bignum-widetag (+ bignum-digits-offset 2) number)
- (inst pop (object-slot-ea number 2 other-pointer-lowtag))
- (inst pop (object-slot-ea number 1 other-pointer-lowtag))
- (inst ret)))
- (define (op)
- ;; R13 is usually the thread register, but might not be
- `(progn
- ,@(loop for reg in ; can't cons into card-table or thread register
- (remove (intern (aref +qword-register-names+ card-table-reg))
- '(rax rcx rdx rbx rsi rdi r8 r9 r10 r11 r12 #+gs-seg r13 r14 r15))
- collect `(,op ,reg)))))
- (define from-digits)
- (define from-digits-unsigned)
- (define two-word-bignum)
- (define signed)
- (define unsigned))
+;#+sb-assembling
+(make-defs ((($avx512 $suffix)
+ (t -avx512)
+ (nil ||)))
+ (macrolet
+ ((alloc-other (&rest rest)
+ `(emit-alloc-other nil thread-tn ,@rest :avx512 $avx512))
+ (signed (reg)
+ `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg '$suffix))
+ ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
+ (inst push number)
+ (alloc-other bignum-widetag (+ bignum-digits-offset 1) number)
+ (popw number bignum-digits-offset other-pointer-lowtag)))
+ (unsigned (reg)
+ `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg '$suffix))
+ ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
+ (inst ror number (1+ n-fixnum-tag-bits)) ; restore unrotated value
+ (inst test number number) ; rotates do not update SF
+ (inst push number)
+ (inst jmp :ns one-word-bignum)
+ ;; Two word bignum
+ (alloc-other bignum-widetag (+ bignum-digits-offset 2) number)
+ (popw number bignum-digits-offset other-pointer-lowtag)
+ (inst ret)
+ ONE-WORD-BIGNUM
+ (alloc-other bignum-widetag (+ bignum-digits-offset 1) number)
+ (popw number bignum-digits-offset other-pointer-lowtag)))
+ (from-digits (reg)
+ ;; stack args:
+ ;; +16 high-digit
+ ;; +8 low-digit
+ ;; rsp : return-pc
+ `(define-assembly-routine (,(symbolicate "BIGNUM-TO-" reg '$suffix) (:return-style :none))
+ ((:temp result unsigned-reg ,(symbolicate reg "-OFFSET")))
+ (inst test :byte result result) ; is-two-digit flag
+ (inst jmp :z one-word-bignum)
+ (alloc-other bignum-widetag (+ bignum-digits-offset 2) result)
+ (inst movdqu float0-tn (ea 8 rsp-tn))
+ (inst movdqu (object-slot-ea result 1 other-pointer-lowtag) float0-tn)
+ (inst ret 16) ; pop args
+ ONE-WORD-BIGNUM
+ (alloc-other bignum-widetag (+ bignum-digits-offset 1) result)
+ (inst movq float0-tn (ea 8 rsp-tn))
+ (inst movq (object-slot-ea result 1 other-pointer-lowtag) float0-tn)
+ (inst ret 16)))
+ ;; "from unsigned" might need to allocate 3 digits, but it receives only high:low
+ ;; because the highest digit if needed must be all 0.
+ (from-digits-unsigned (reg)
+ ;; stack args:
+ ;; +16 high-digit
+ ;; +8 low-digit
+ ;; rsp : return-pc
+ `(define-assembly-routine (,(symbolicate "+BIGNUM-TO-" reg '$suffix) (:return-style :none))
+ ((:temp result unsigned-reg ,(symbolicate reg "-OFFSET")))
+ (inst test :byte result result) ; is-two-or-three-digit flag
+ (inst jmp :z one-word-bignum)
+ ;; Since 2 digits and 3 digits consume the same number of bytes
+ ;; due to padding, they can share the allocation request.
+ (alloc-other bignum-widetag (+ bignum-digits-offset 3) result)
+ (inst movdqu float0-tn (ea 8 rsp-tn))
+ (inst movdqu (object-slot-ea result 1 other-pointer-lowtag) float0-tn)
+ ;; don't assume prezeroed unboxed pages. (zeroize word even if 2-digit result)
+ (inst mov :qword (object-slot-ea result 3 other-pointer-lowtag) 0)
+ ;; Test sign bit of digit index 1
+ (inst test :byte (ea (+ 7 (ash (+ bignum-digits-offset 1) word-shift)
+ (- other-pointer-lowtag)) result) #xff)
+ (inst jmp :s SKIP) ; if signed, then keep all 3 digits
+ ;; else, no sign bit, so change it to 2-digit bignum
+ (inst mov :byte (ea (- 1 other-pointer-lowtag) result) 2)
+ SKIP
+ (inst ret 16) ; pop args
+ ONE-WORD-BIGNUM
+ (alloc-other bignum-widetag (+ bignum-digits-offset 1) result)
+ (inst movq float0-tn (ea 8 rsp-tn))
+ (inst movq (object-slot-ea result 1 other-pointer-lowtag) float0-tn)
+ (inst ret 16)))
+ ;; The high bit is in the carry flag.
+ (two-word-bignum (reg)
+ `(define-assembly-routine (,(symbolicate "TWO-WORD-BIGNUM-TO-" reg '$suffix) (:return-style :none))
+ ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET")))
+ (inst push number)
+ (inst set :c number)
+ (inst movzx '(:byte :dword) number number)
+ (inst push number)
+ (alloc-other bignum-widetag (+ bignum-digits-offset 2) number)
+ (inst pop (object-slot-ea number 2 other-pointer-lowtag))
+ (inst pop (object-slot-ea number 1 other-pointer-lowtag))
+ (inst ret)))
+ (define (op)
+ ;; R13 is usually the thread register, but might not be
+ `(progn
+ ,@(loop for reg in ; can't cons into card-table or thread register
+ (remove (intern (aref +qword-register-names+ card-table-reg))
+ '(rax rcx rdx rbx rsi rdi r8 r9 r10 r11 r12 #+gs-seg r13 r14 r15))
+ collect `(,op ,reg)))))
+ (define from-digits)
+ (define from-digits-unsigned)
+ (define two-word-bignum)
+ (define signed)
+ (define unsigned)))
#+sb-thread
(define-assembly-routine (alloc-tls-index
diff --git a/src/assembly/x86-64/support.lisp b/src/assembly/x86-64/support.lisp
index fb30ecf6f..aa47df8cd 100644
--- a/src/assembly/x86-64/support.lisp
+++ b/src/assembly/x86-64/support.lisp
@@ -69,11 +69,17 @@
(defmacro call-reg-specific-asm-routine (node prefix tn &optional (suffix ""))
`(invoke-asm-routine
'call
- (aref ,(map 'vector
- (lambda (x)
- (unless (member x '(rsp rbp) :test 'string=)
- (symbolicate prefix x suffix)))
- +qword-register-names+)
+ (aref (if (zmm-registers-used-p)
+ ,(map 'vector
+ (lambda (x)
+ (unless (member x '(rsp rbp) :test 'string=)
+ (symbolicate prefix x suffix '-avx512)))
+ +qword-register-names+)
+ ,(map 'vector
+ (lambda (x)
+ (unless (member x '(rsp rbp) :test 'string=)
+ (symbolicate prefix x suffix)))
+ +qword-register-names+))
(tn-offset ,tn))
,node))
@@ -100,15 +106,29 @@
(inst ret)))
((:none :full-call-no-return))))
-(defconstant xsave-area-size (+ 512 64 256))
(defconstant xsave-area-alignment 64)
+(defconstant xsave-area-size (+ 512 64 256))
+
+;; uncompacted XSAVE size for AVX-512:
+;; Legacy (512) + Header (64) = 576
+;; YMM (256) at offset 576 = 832
+;; GAP (256) Intel MPX = 1088
+;; KMM (64) at offset 1088 = 1152
+;; ZMM (0-15) (512) at 1152 = 1664
+;; GAP (448) at 1664 = 2112
+;; ZMM (16-31) (1024) at 2112 = 3136
+(defconstant xsave-avx512-area-size (+ 512 64 256 256 64 512 448 1024))
;;; Save or restore all FPRs at the stack pointer as it existed just prior
;;; to the call to the asm routine.
-(defun call-fpr-save/restore-routine (selector)
- (let ((routine (ecase selector
- (:save 'fpr-save)
- (:restore 'fpr-restore))))
+(defun call-fpr-save/restore-routine (selector &key avx512)
+ (let ((routine (if avx512
+ (ecase selector
+ (:save 'fpr-save-avx512)
+ (:restore 'fpr-restore-avx512))
+ (ecase selector
+ (:save 'fpr-save)
+ (:restore 'fpr-restore)))))
(if (or (not (boundp 'sb-c:*component-being-compiled*))
(code-immobile-p sb-c:*component-being-compiled*))
;; direct call from asm routine or immobile code
@@ -131,7 +151,8 @@
;;; After the customary 2-instruction prologue of "PUSH RBP ; MOV RBP,RSP"
;;; there is a correct chain of saved RBP values, but 1 word up from the current RBP
;;; is probably not a saved program counter, and will look weird to treat it as such.
-(defmacro with-registers-preserved ((convention &key eflags except (frame-reg 'rbp))
+(defmacro with-registers-preserved ((convention &key eflags except (frame-reg 'rbp)
+ avx512)
&body body)
;: Convention:
;; C = save GPRs that C call can change
@@ -184,12 +205,16 @@
`((inst and rsp-tn ,(- fpr-align))))
(regs-pushlist ,@gprs)
,@(when save-fpr
- `((inst sub rsp-tn ,(+ alignment-bytes xsave-area-size))
- (call-fpr-save/restore-routine :save)))
+ `((inst sub rsp-tn ,(+ alignment-bytes (if avx512
+ xsave-avx512-area-size
+ xsave-area-size)))
+ (call-fpr-save/restore-routine :save :avx512 ,avx512)))
(assemble () ,@body)
,@(when save-fpr
- `((call-fpr-save/restore-routine :restore)
- (inst add rsp-tn ,(+ alignment-bytes xsave-area-size))))
+ `((call-fpr-save/restore-routine :restore :avx512 ,avx512)
+ (inst add rsp-tn ,(+ alignment-bytes (if avx512
+ xsave-avx512-area-size
+ xsave-area-size)))))
(regs-poplist ,@gprs)
,@(cond ((and (eq frame-tn 'rbp-tn) (not eflags))
'((inst leave)))
diff --git a/src/assembly/x86-64/tramps.lisp b/src/assembly/x86-64/tramps.lisp
index 9703ec130..bdab924ee 100644
--- a/src/assembly/x86-64/tramps.lisp
+++ b/src/assembly/x86-64/tramps.lisp
@@ -105,6 +105,33 @@
(inst xrstor (ea 16 rsp-tn))
(inst pop rdx-tn)))
+;; Caller will have allocated xsave-avx512-area-size bytes above the stack-pointer
+;; prior to the CALL. Use that as the save area.
+(define-assembly-routine (fpr-save-avx512) ()
+ ;; Although most of the time RDX can be clobbered, some of the time it can't.
+ ;; If WITH-REGISTERS-PRESERVED wraps a lisp function to make it appear to preserve
+ ;; all registers, we obviously need to return its primary value in RDX.
+ ;; RAX need not be saved though.
+ (inst push rdx-tn)
+ (zeroize rdx-tn)
+ ;; After PUSH the save area is at RSP+16 with the return-PC at [RSP+8]
+ ;; Zero the header
+ (inst lea rax-tn (ea (+ 512 16) rsp-tn))
+ (dotimes (i 8)
+ (inst mov (ea (ash i word-shift) rax-tn) rdx-tn))
+ ;; AVX-512 state mask for EAX:
+ ;; x87(0) | SSE(1) | AVX(2) | KMM(5) | ZMM 0-15(6) | ZMM 16-31(7) = 0xE7
+ (inst mov rax-tn #xE7)
+ (inst xsave (ea 16 rsp-tn))
+ (inst pop rdx-tn))
+
+(define-assembly-routine (fpr-restore-avx512) ()
+ (inst push rdx-tn)
+ (inst mov rax-tn #xE7) ; OK to clobber RAX
+ (zeroize rdx-tn)
+ (inst xrstor (ea 16 rsp-tn))
+ (inst pop rdx-tn))
+
(define-assembly-routine (switch-to-arena (:return-style :raw)) ()
;; RSI and RDI are vop temps, so don't bother preserving them
(with-registers-preserved (c :except (rsi rdi))
@@ -156,39 +183,42 @@
(inst test rax-tn rax-tn)
(inst jmp :z RESTART))))
-(def-routine-pair (alloc-tramp) ()
- (with-registers-preserved (c)
- RESTART
- (call-c "alloc" (ea 16 rbp-tn) system-tlab-p)
- (test-arena-exhausted :bytes-non-list)
- SUCCESS
- (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack
+(make-defs ((($avx512 $suffix)
+ (t -avx512)
+ (nil ||)))
+ (def-routine-pair (alloc-tramp$suffix) ()
+ (with-registers-preserved (c :avx512 $avx512)
+ RESTART
+ (call-c "alloc" (ea 16 rbp-tn) system-tlab-p)
+ (test-arena-exhausted :bytes-non-list)
+ SUCCESS
+ (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack
-(def-routine-pair (list-alloc-tramp) () ; CONS, ACONS, LIST, LIST*
- (with-registers-preserved (c)
- RESTART
- (call-c "alloc_list" (ea 16 rbp-tn) system-tlab-p)
- (test-arena-exhausted :bytes-list)
- SUCCESS
- (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack
+ (def-routine-pair (list-alloc-tramp$suffix) () ; CONS, ACONS, LIST, LIST*
+ (with-registers-preserved (c :avx512 $avx512)
+ RESTART
+ (call-c "alloc_list" (ea 16 rbp-tn) system-tlab-p)
+ (test-arena-exhausted :bytes-list)
+ SUCCESS
+ (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack
-(def-routine-pair (listify-&rest (:return-style :none)) ()
- (with-registers-preserved (c)
- RESTART
- (call-c "listify_rest_arg" (ea 16 rbp-tn) (ea 24 rbp-tn) system-tlab-p)
- (test-arena-exhausted :list-elts)
- SUCCESS
- (inst mov (ea 24 rbp-tn) rax-tn)) ; result
- (inst ret 8)) ; pop one argument; the unpopped word now holds the result
+ (def-routine-pair (listify-&rest$suffix (:return-style :none)) ()
+ (with-registers-preserved (c :avx512 $avx512)
+ RESTART
+ (call-c "listify_rest_arg" (ea 16 rbp-tn) (ea 24 rbp-tn) system-tlab-p)
+ (test-arena-exhausted :list-elts)
+ SUCCESS
+ (inst mov (ea 24 rbp-tn) rax-tn)) ; result
+ (inst ret 8)) ; pop one argument; the unpopped word now holds the result
-(def-routine-pair (make-list (:return-style :none)) ()
- (with-registers-preserved (c)
- RESTART
- (call-c "make_list" (ea 16 rbp-tn) (ea 24 rbp-tn) system-tlab-p)
- (test-arena-exhausted :list-elts)
- SUCCESS
- (inst mov (ea 24 rbp-tn) rax-tn)) ; result
- (inst ret 8)) ; pop one argument; the unpopped word now holds the result
+ (def-routine-pair (make-list$suffix (:return-style :none)) ()
+ (with-registers-preserved (c :avx512 $avx512)
+ RESTART
+ (call-c "make_list" (ea 16 rbp-tn) (ea 24 rbp-tn) system-tlab-p)
+ (test-arena-exhausted :list-elts)
+ SUCCESS
+ (inst mov (ea 24 rbp-tn) rax-tn)) ; result
+ (inst ret 8))) ; pop one argument; the unpopped word now holds the result
)
(define-assembly-routine (alloc-funinstance) ()
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 0150aa23c..a7e0037a2 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -269,7 +269,7 @@
(defvar *immobile-space-map* nil))
;; Vector capacity must be adequate for the number of asm routines, but (KLUDGE)
;; the exact count of routines is unknown until make-host-2 is done.
-#+x86-64 (defconstant asm-jump-vect-nelems 112) ; arb
+#+x86-64 (defconstant asm-jump-vect-nelems 186) ; arb
#-linkage-space (defvar *c-callable-syms*)
(defstruct page
diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index a8c445e75..61b549b8a 100644
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -213,6 +213,20 @@
(define-vop (sb-c::end-pseudo-atomic)
(:generator 1 (emit-end-pseudo-atomic)))
+(defun zmm-registers-used-p ()
+ (when (and #+sb-xc-host (boundp '*component-being-compiled*))
+ (let ((comp (component-info *component-being-compiled*)))
+ (flet ((used-p (tn)
+ (do ((tn tn (sb-c::tn-next tn)))
+ ((null tn))
+ (when (sc-is tn zmm-reg
+ int-avx512-reg
+ double-avx512-reg
+ single-avx512-reg)
+ (return-from zmm-registers-used-p t)))))
+ (used-p (sb-c::ir2-component-normal-tns comp))
+ (used-p (sb-c::ir2-component-wired-tns comp))))))
+
;;; Emit code to allocate an object with a size in bytes given by
;;; SIZE into ALLOC-TN. The size may be an integer of a TN.
;;; NODE may be used to make policy-based decisions.
@@ -224,8 +238,11 @@
;;; 2. where to put the result
;;; 3. node (for determining immobile-space-p) and a scratch register or two
(defun emit-allocation (node thread-temp type size lowtag alloc-tn temp
- &key scale overflow (systemp (system-tlab-p type node)))
+ &key scale overflow (systemp (system-tlab-p type node))
+ (avx512 :default))
(declare (ignorable thread-temp))
+ (when (eq avx512 :default)
+ (setf avx512 (zmm-registers-used-p)))
(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()
@@ -238,9 +255,13 @@
(inst push size)))
(invoke-asm-routine
'call
- (if systemp
- (if (eql type +cons-primtype+) 'sys-list-alloc-tramp 'sys-alloc-tramp)
- (if (eql type +cons-primtype+) 'list-alloc-tramp 'alloc-tramp))
+ (if avx512
+ (if systemp
+ (if (eql type +cons-primtype+) 'sys-list-alloc-tramp-avx512 'sys-alloc-tramp-avx512)
+ (if (eql type +cons-primtype+) 'list-alloc-tramp-avx512 'alloc-tramp-avx512))
+ (if systemp
+ (if (eql type +cons-primtype+) 'sys-list-alloc-tramp 'sys-alloc-tramp)
+ (if (eql type +cons-primtype+) 'list-alloc-tramp 'alloc-tramp)))
node)
(inst pop alloc-tn)))
(let* ((NOT-INLINE (gen-label))
@@ -248,12 +269,12 @@
(free-pointer (thread-slot-ea
(if systemp
(if (eql type +cons-primtype+)
- thread-sys-cons-tlab-slot
- thread-sys-mixed-tlab-slot)
- (if (eql type +cons-primtype+)
- thread-cons-tlab-slot
- thread-mixed-tlab-slot))
- #+gs-seg thread-temp))
+ thread-sys-cons-tlab-slot
+ thread-sys-mixed-tlab-slot)
+ (if (eql type +cons-primtype+)
+ thread-cons-tlab-slot
+ thread-mixed-tlab-slot))
+ #+gs-seg thread-temp))
(end-addr (ea (sb-x86-64-asm::ea-segment free-pointer)
(+ n-word-bytes (ea-disp free-pointer))
(ea-base free-pointer))))
@@ -326,7 +347,7 @@
;;; below the region's free pointer. Right now we can do the inits either inside or outside
;;; of pseudo-atomic because all pages except CONS are prezeroed.
(defun emit-alloc-other (node thread-temp widetag nwords result-tn
- &optional alloc-temps init
+ &key alloc-temps init (avx512 :default)
&aux (bytes (pad-data-block nwords)))
(declare (dynamic-extent init))
#+bignum-assertions
@@ -337,11 +358,13 @@
(alloc-temp (if (listp alloc-temps) (car alloc-temps) alloc-temps)))
(allocating ()
(cond (alloc-temp
- (emit-allocation node thread-temp widetag bytes 0 result-tn alloc-temp)
+ (emit-allocation node thread-temp widetag bytes 0 result-tn alloc-temp
+ :avx512 avx512)
(storew* header result-tn 0 0 t)
(inst or :byte result-tn other-pointer-lowtag))
(t
- (emit-allocation node thread-temp widetag bytes other-pointer-lowtag result-tn nil)
+ (emit-allocation node thread-temp widetag bytes other-pointer-lowtag result-tn nil
+ :avx512 avx512)
(storew* header result-tn 0 other-pointer-lowtag t)))
(when init
(funcall init)))))
@@ -746,7 +769,7 @@
(let ((nbytes (calc-shadow-bits-size result)))
(allocating ()
;; Allocate the bits into RESULT
- (allocation simple-bit-vector-widetag nbytes 0 result temp nil)
+ (allocation simple-bit-vector-widetag nbytes 0 result 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))
@@ -998,8 +1021,9 @@
(:args (name :scs (descriptor-reg) :to :eval))
(:results (result :scs (descriptor-reg) :from :argument))
(:generator 37
- (alloc-other fdefn-widetag fdefn-size result nil
- (lambda () (storew name result fdefn-name-slot other-pointer-lowtag)))))
+ (alloc-other fdefn-widetag fdefn-size result
+ :init (lambda ()
+ (storew name result fdefn-name-slot other-pointer-lowtag)))))
(define-allocator (make-closure)
(:info label length stack-allocate-p)
@@ -1048,10 +1072,11 @@
:load-if (not (reg-or-legal-imm32-p value))))
(:results (result :scs (descriptor-reg) :from :eval))
(:generator 10
- (alloc-other value-cell-widetag value-cell-size result nil
- (lambda ()
- (storew (encode-value-if-immediate value)
- result value-cell-value-slot other-pointer-lowtag)))))
+ (alloc-other value-cell-widetag value-cell-size result
+ :init
+ (lambda ()
+ (storew (encode-value-if-immediate value)
+ result value-cell-value-slot other-pointer-lowtag)))))
;;;; automatic allocators for primitive objects
diff --git a/src/compiler/x86-64/avx2-insts.lisp b/src/compiler/x86-64/avx2-insts.lisp
index 0aff4747d..6a4403cc2 100644
--- a/src/compiler/x86-64/avx2-insts.lisp
+++ b/src/compiler/x86-64/avx2-insts.lisp
@@ -461,7 +461,7 @@ EVEX uses independent bit3 (R/B) and bit4 (R'/X) for 32-register encoding."
((is-ymm-id-p (reg-id r)) #b01)
((xmm-register-p r) #b00))))
(let ((ll (cond (ll ll)
- ;; Skip k-registers — they pass xmm-register-p but
+ ;; Skip k-registers - they pass xmm-register-p but
;; aren't XMM/YMM/ZMM, so fpr-size returns wrong value
((and reg (xmm-register-p reg)
(not (is-kreg-id-p (reg-id reg))))
@@ -580,8 +580,8 @@ THING is the destination (NDD, encoded in vvvv).
REG is the source (encoded in ModR/M.r/m).
/I is encoded in ModR/M.reg bits 5:3."
(aver (<= 0 /i 7))
- ;; thing = destination → goes in vvvv (NDD encoding)
- ;; reg = source → goes in r/m
+ ;; thing = destination -> goes in vvvv (NDD encoding)
+ ;; reg = source -> goes in r/m
(multiple-value-bind (ll r x b r-prime v-prime)
(determine-evex-flags reg nil ll thing)
(let ((vvvv-num (if thing (reg-id-num (reg-id thing)) 0)))
diff --git a/src/compiler/x86-64/avx512-insts.lisp b/src/compiler/x86-64/avx512-insts.lisp
index d2a2a26f3..4906a1508 100644
--- a/src/compiler/x86-64/avx512-insts.lisp
+++ b/src/compiler/x86-64/avx512-insts.lisp
@@ -533,7 +533,7 @@
(def vprord #x72 0 0)
(def vprorq #x72 0 1))
-;;; vpsraq — dual form (register + immediate)
+;;; vpsraq - dual form (register + immediate)
(define-instruction vpsraq (segment dst src src2/imm)
(:emitter
(if (integerp src2/imm)
@@ -649,7 +649,7 @@
(def vpbroadcastmb2q #x2a 1)
(def vpbroadcastmw2d #x3a 0))
-;;; Broadcast from GPR (EVEX.512.66.0F38 — separate opcodes from xmm-source forms)
+;;; Broadcast from GPR (EVEX.512.66.0F38 - separate opcodes from xmm-source forms)
;;; vpbroadcastd zmm, r32 uses opcode #x7C W=0
;;; vpbroadcastq zmm, r64 uses opcode #x7C W=1
;;; Encoding: ModR/M.reg = ZMM dst, ModR/M.r/m = GPR src
@@ -695,7 +695,7 @@
(def kaddd #x66 #x4a 1)
(def kaddq #xf2 #x4a 1))
-;;; Compare-to-k (kdst, src1, src2, imm8) — k-reg in ModR/M reg
+;;; Compare-to-k (kdst, src1, src2, imm8) - k-reg in ModR/M reg
(macrolet ((def (name prefix opcode w)
`(define-instruction ,name (segment dst src1 src2 imm)
,@(avx512-inst-printer-list 'ymm-ymm/mem-imm prefix opcode
@@ -713,7 +713,7 @@
(def vpcmpq #x66 #x1f 1)
(def vpcmpuq #x66 #x1e 1))
-;;; Test-to-k (kdst, src1, src2) — k-reg in ModR/M reg
+;;; Test-to-k (kdst, src1, src2) - k-reg in ModR/M reg
(macrolet ((def (name prefix opcode w)
`(define-instruction ,name (segment dst src1 src2)
,@(avx512-inst-printer-list 'ymm-ymm/mem prefix opcode
@@ -744,7 +744,7 @@
(def vpblendmb #x66 0)
(def vpblendmw #x66 1))
-;;; Compare byte/word to k — k-reg in ModR/M reg
+;;; Compare byte/word to k - k-reg in ModR/M reg
(macrolet ((def (name prefix opcode w)
`(define-instruction ,name (segment dst src1 src2 imm)
,@(avx512-inst-printer-list 'ymm-ymm/mem-imm prefix opcode
@@ -762,7 +762,7 @@
(def vpcmpw #x66 #x3f 1)
(def vpcmpuw #x66 #x3e 1))
-;;; Test byte/word to k — k-reg in ModR/M reg
+;;; Test byte/word to k - k-reg in ModR/M reg
(macrolet ((def (name prefix opcode w)
`(define-instruction ,name (segment dst src1 src2)
,@(avx512-inst-printer-list 'ymm-ymm/mem prefix opcode
diff --git a/src/runtime/x86-64-arch.c b/src/runtime/x86-64-arch.c
index c6ca3dc8a..878b99819 100644
--- a/src/runtime/x86-64-arch.c
+++ b/src/runtime/x86-64-arch.c
@@ -114,7 +114,7 @@ void tune_asm_routines_for_microarch(void)
consts->text_card_marks = (lispobj)text_page_touched_bits;
#endif
- unsigned int eax, ebx, ecx, edx;
+ unsigned int eax, ebx, ecx, edx, xcr0;
unsigned int cpuid_fn1_ecx = 0;
cpuid(0, 0, &eax, &ebx, &ecx, &edx);
@@ -123,16 +123,19 @@ void tune_asm_routines_for_microarch(void)
cpuid(1, 0, &eax, &ebx, &ecx, &edx);
cpuid_fn1_ecx = ecx;
if ((ecx & avx_mask) == avx_mask) {
- xgetbv(&eax, &edx);
- if ((eax & 0x06) == 0x06) { // YMM and XMM
+
+ xgetbv(&xcr0, &edx);
+ if ((xcr0 & 0x06) == 0x06) { // YMM and XMM
avx_supported = 1;
- if ((eax & 5) == 5 && (eax & 7) == 7) { // ZMM
- avx512_supported = 1;
- }
+
cpuid(7, 0, &eax, &ebx, &ecx, &edx);
if (ebx & 0x20) {
avx2_supported = 1;
}
+ if ((ebx & (1u << 16)) && // AVX512F
+ ((xcr0 & 0xE6) == 0xE6)) { // OS supports ZMM
+ avx512_supported = 1;
+ }
}
}
}
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
_______________________________________________
Sbcl-commits mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/sbcl-commits