master: Don't save avx512 registers in alloc tramps
stassats via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 5c3fe7ae65f38d3e3c7741900b0c45c0950dbd79 (commit)
from 50e47018399676a507a2c6a94269599f15b428c8 (commit)
- Log -----------------------------------------------------------------
commit 5c3fe7ae65f38d3e3c7741900b0c45c0950dbd79
Author: Stas Boukarev <[email protected]>
Date: Tue Aug 25 20:01:45 2026 +0300
Don't save avx512 registers in alloc tramps
Declare the allocation routines with :save-p :avx512, to save only the
live registers around the call (which shouldn't happen in optimized
code).
---
src/assembly/x86-64/alloc.lisp | 201 ++++++++++++++++-----------------
src/assembly/x86-64/support.lisp | 53 +++------
src/assembly/x86-64/tramps.lisp | 45 ++------
src/compiler/x86-64/alloc.lisp | 101 +++++++----------
src/compiler/x86-64/macros.lisp | 2 +
src/compiler/x86-64/simd-pack-512.lisp | 46 ++++----
src/compiler/x86-64/vm.lisp | 2 +-
tests/simd-pack-512-kmasks.pure.lisp | 14 ---
8 files changed, 191 insertions(+), 273 deletions(-)
diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp
index c4716b0cf..449f43c8c 100644
--- a/src/assembly/x86-64/alloc.lisp
+++ b/src/assembly/x86-64/alloc.lisp
@@ -26,108 +26,105 @@
;;;; +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
-(make-defs ((($avx512 $suffix)
- (t -avx512)
- (nil ||)))
- (macrolet
- ((float0-tn ()
- (make-random-tn (sc-or-lose 'single-reg) 0))
- (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-assembling
+(macrolet
+ ((float0-tn ()
+ (make-random-tn (sc-or-lose 'single-reg) 0))
+ (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-thread
(define-assembly-routine (alloc-tls-index
diff --git a/src/assembly/x86-64/support.lisp b/src/assembly/x86-64/support.lisp
index 3f9aa5b77..8be11c6bc 100644
--- a/src/assembly/x86-64/support.lisp
+++ b/src/assembly/x86-64/support.lisp
@@ -69,17 +69,11 @@
(defmacro call-reg-specific-asm-routine (node prefix tn &optional (suffix ""))
`(invoke-asm-routine
'call
- (aref (if (avx512-state-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+))
+ (aref ,(map 'vector
+ (lambda (x)
+ (unless (member x '(rsp rbp) :test 'string=)
+ (symbolicate prefix x suffix)))
+ +qword-register-names+)
(tn-offset ,tn))
,node))
@@ -109,26 +103,12 @@
(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 &key avx512)
- (let ((routine (if avx512
- (ecase selector
- (:save 'fpr-save-avx512)
- (:restore 'fpr-restore-avx512))
- (ecase selector
- (:save 'fpr-save)
- (:restore 'fpr-restore)))))
+(defun call-fpr-save/restore-routine (selector)
+ (let ((routine (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
@@ -151,8 +131,7 @@
;;; 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)
- avx512)
+(defmacro with-registers-preserved ((convention &key eflags except (frame-reg 'rbp))
&body body)
;: Convention:
;; C = save GPRs that C call can change
@@ -205,16 +184,12 @@
`((inst and rsp-tn ,(- fpr-align))))
(regs-pushlist ,@gprs)
,@(when save-fpr
- `((inst sub rsp-tn ,(+ alignment-bytes (if avx512
- xsave-avx512-area-size
- xsave-area-size)))
- (call-fpr-save/restore-routine :save :avx512 ,avx512)))
+ `((inst sub rsp-tn ,(+ alignment-bytes xsave-area-size))
+ (call-fpr-save/restore-routine :save)))
(assemble () ,@body)
,@(when save-fpr
- `((call-fpr-save/restore-routine :restore :avx512 ,avx512)
- (inst add rsp-tn ,(+ alignment-bytes (if avx512
- xsave-avx512-area-size
- xsave-area-size)))))
+ `((call-fpr-save/restore-routine :restore)
+ (inst add rsp-tn ,(+ alignment-bytes 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 cc80937fb..a709f7b76 100644
--- a/src/assembly/x86-64/tramps.lisp
+++ b/src/assembly/x86-64/tramps.lisp
@@ -104,28 +104,6 @@
(zeroize rdx-tn)
(inst xrstor (ea 8 rsp-tn))))
-;; Caller will have allocated xsave-avx512-area-size bytes above the stack-pointer
-;; prior to the CALL. Use that as the save area.
-;; Similar considerations pertain to the use of RAX and RDX as in FPR-SAVE.
-(define-assembly-routine (fpr-save-avx512) ()
- (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 mov rax-tn #xE7) ; OK to clobber RAX and RDX
- (zeroize rdx-tn)
- (inst xrstor (ea 8 rsp-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))
@@ -177,27 +155,24 @@
(inst test rax-tn rax-tn)
(inst jmp :z RESTART))))
-(make-defs ((($avx512 $suffix)
- (t -avx512)
- (nil ||)))
- (def-routine-pair (alloc-tramp$suffix) ()
- (with-registers-preserved (c :avx512 $avx512)
+ (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
- (def-routine-pair (list-alloc-tramp$suffix) () ; CONS, ACONS, LIST, LIST*
- (with-registers-preserved (c :avx512 $avx512)
+ (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 (listify-&rest$suffix (:return-style :none)) ()
- (with-registers-preserved (c :avx512 $avx512)
+ (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)
@@ -205,15 +180,15 @@
(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)
+ (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
-)
+ (inst ret 8)) ; pop one argument; the unpopped word now holds the result
+ )
(define-assembly-routine (alloc-funinstance) ()
(with-registers-preserved (c)
diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index 564176918..37a9ee6ea 100644
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -216,17 +216,6 @@
(defun avx512-tn-p (tn)
(sc-is tn int-avx512-reg double-avx512-reg single-avx512-reg mask-reg))
-(defun avx512-state-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 (avx512-tn-p tn)
- (return-from avx512-state-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.
@@ -238,11 +227,8 @@
;;; 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))
- (avx512 :default))
+ &key scale overflow (systemp (system-tlab-p type node)))
(declare (ignorable thread-temp))
- (when (eq avx512 :default)
- (setf avx512 (avx512-state-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()
@@ -255,13 +241,9 @@
(inst push size)))
(invoke-asm-routine
'call
- (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)))
+ (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))
@@ -347,7 +329,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
- &key alloc-temps init (avx512 :default)
+ &key alloc-temps init
&aux (bytes (pad-data-block nwords)))
(declare (dynamic-extent init))
#+bignum-assertions
@@ -358,13 +340,11 @@
(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
- :avx512 avx512)
+ (emit-allocation node thread-temp widetag bytes 0 result-tn alloc-temp)
(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
- :avx512 avx512)
+ (emit-allocation node thread-temp widetag bytes other-pointer-lowtag result-tn nil)
(storew* header result-tn 0 other-pointer-lowtag t)))
(when init
(funcall init)))))
@@ -1247,6 +1227,7 @@
(:temporary (:sc unsigned-reg :offset rbx-offset) rbx)
(:temporary (:sc unsigned-reg :offset rcx-offset) rcx)
(:temporary (:sc unsigned-reg) header)
+ (:save-p :avx512)
(:generator 1
;; fixedobj_pages alien linkage entry: 1 PTE per page, 12-byte struct
(inst mov rbx (rip-relative-ea (make-fixup "fixedobj_pages" :foreign-dataref)))
@@ -1262,36 +1243,36 @@
;; There is no way to inform GC that we are currently looking at a page
;; in anticipation of allocating to it.
(allocating ()
- (inst mov :dword rax (ea 4 rax)) ; rax := fixedobj_page_hint[1] (sizeclass=SYMBOL)
- (inst test :dword rax rax)
- (inst jmp :z FAIL) ; fail if hint page is 0
- (inst lea rbx (ea rbx rax 8)) ; rbx := &fixedobj_pages[hint].free_index
- ;; compute fixedobj_page_address(hint) into RAX
- (inst mov rcx (rip-relative-ea (make-fixup "FIXEDOBJ_SPACE_START" :foreign-dataref)))
- (inst shl rax (integer-length (1- immobile-card-bytes)))
- (inst add rax (ea rcx))
- ;; load the page's free pointer
- (inst mov :dword rcx (ea rbx)) ; rcx := fixedobj_pages[hint].free_index
- ;; fail if allocation would overrun the page
- (inst cmp :dword rcx (- immobile-card-bytes (* symbol-size n-word-bytes)))
- (inst jmp :a FAIL)
- ;; compute address of the allegedly free memory block into RESULT
- (inst lea result (ea rcx rax)) ; free_index + page_base
- ;; read the potential symbol header
- (inst mov rax (ea result))
- (inst test :dword rax 1)
- (inst jmp :nz FAIL) ; not a fixnum implies already taken
- ;; try to claim this word of memory
- (inst mov header (compute-object-header (1- symbol-size) symbol-widetag))
- (inst cmpxchg :lock (ea result) header)
- (inst jmp :ne FAIL) ; already taken
- ;; compute new free_index = spacing + old header + free_index
- (inst lea :dword rax (ea (* symbol-size n-word-bytes) rax rcx))
- (inst mov :dword (ea rbx) rax) ; store new free_index
- ;; set the low bit of the 'gens' field
- (inst or :lock :byte (ea 7 rbx) 1) ; 7+rbx = &fixedobj_pages[i].attr.parts.gens_
- (inst or :byte result other-pointer-lowtag) ; make_lispobj()
- (inst jmp OUT)
- FAIL
- (inst mov result null-tn)
- OUT)))
+ (inst mov :dword rax (ea 4 rax)) ; rax := fixedobj_page_hint[1] (sizeclass=SYMBOL)
+ (inst test :dword rax rax)
+ (inst jmp :z FAIL) ; fail if hint page is 0
+ (inst lea rbx (ea rbx rax 8)) ; rbx := &fixedobj_pages[hint].free_index
+ ;; compute fixedobj_page_address(hint) into RAX
+ (inst mov rcx (rip-relative-ea (make-fixup "FIXEDOBJ_SPACE_START" :foreign-dataref)))
+ (inst shl rax (integer-length (1- immobile-card-bytes)))
+ (inst add rax (ea rcx))
+ ;; load the page's free pointer
+ (inst mov :dword rcx (ea rbx)) ; rcx := fixedobj_pages[hint].free_index
+ ;; fail if allocation would overrun the page
+ (inst cmp :dword rcx (- immobile-card-bytes (* symbol-size n-word-bytes)))
+ (inst jmp :a FAIL)
+ ;; compute address of the allegedly free memory block into RESULT
+ (inst lea result (ea rcx rax)) ; free_index + page_base
+ ;; read the potential symbol header
+ (inst mov rax (ea result))
+ (inst test :dword rax 1)
+ (inst jmp :nz FAIL) ; not a fixnum implies already taken
+ ;; try to claim this word of memory
+ (inst mov header (compute-object-header (1- symbol-size) symbol-widetag))
+ (inst cmpxchg :lock (ea result) header)
+ (inst jmp :ne FAIL) ; already taken
+ ;; compute new free_index = spacing + old header + free_index
+ (inst lea :dword rax (ea (* symbol-size n-word-bytes) rax rcx))
+ (inst mov :dword (ea rbx) rax) ; store new free_index
+ ;; set the low bit of the 'gens' field
+ (inst or :lock :byte (ea 7 rbx) 1) ; 7+rbx = &fixedobj_pages[i].attr.parts.gens_
+ (inst or :byte result other-pointer-lowtag) ; make_lispobj()
+ (inst jmp OUT)
+ FAIL
+ (inst mov result null-tn)
+ OUT)))
diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index ddde225eb..0dcf49248 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -231,6 +231,8 @@
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
,@(remove :generator body :key 'car)
(:node-var node)
+ #+sb-simd-pack-512
+ (:save-p :avx512)
(:generator ,(car g) ; cost
(macrolet
((instrument-alloc (&rest args) `(emit-instrument-alloc node thread-tn ,@args))
diff --git a/src/compiler/x86-64/simd-pack-512.lisp b/src/compiler/x86-64/simd-pack-512.lisp
index 6a00eeb28..897d9e336 100644
--- a/src/compiler/x86-64/simd-pack-512.lisp
+++ b/src/compiler/x86-64/simd-pack-512.lisp
@@ -94,13 +94,15 @@
(define-allocator (move-from-mask)
(:args (x :scs (mask-reg)))
(:arg-types simd-pack-512-mask-type)
+ (:temporary (:sc unsigned-reg) tmp)
(:results (y :scs (descriptor-reg)))
(:result-types simd-pack-512-mask-type)
(:note "mask to pointer coercion")
(:generator 10
+ (inst kmovq tmp x) ;; save in a GPR for a potential call to alloc-tramp
(alloc-other simd-pack-512-mask-widetag simd-pack-512-mask-size y)
(let ((ea (object-slot-ea y simd-pack-512-mask-value-slot other-pointer-lowtag)))
- (inst kmovq ea x))))
+ (inst mov ea tmp))))
(define-vop (move-from-mask-to-unsigned)
(:args (x :scs (mask-reg)))
@@ -260,36 +262,36 @@
(int-avx512-reg single-avx512-reg double-avx512-reg)
(int-avx512-reg single-avx512-reg double-avx512-reg))
-(macrolet ((define-move-from-avx512 (type tag &rest scs)
+(macrolet ((define-move-from-avx512 (type tag move sc stack-sc)
(let ((name (symbolicate "MOVE-FROM-AVX512/" type)))
`(progn
(define-allocator (,name)
- (:args (x :scs ,scs))
+ (:args (x :scs (,sc)))
+ (:temporary (:sc ,sc :from (:argument 0)) tmp)
+ (:temporary (:sc ,stack-sc) stack)
(:results (y :scs (descriptor-reg)))
(:arg-types ,type)
(:note "AVX512 to pointer coercion")
(:generator 13
+ ;; Save on the stack for a potential call to alloc-tramp
+ (inst ,move (ea-for-avx512-stack stack) x)
(alloc-other simd-pack-512-widetag simd-pack-512-size y)
- (storew (fixnumize ,tag)
- y simd-pack-512-tag-slot other-pointer-lowtag)
- (let ((ea (object-slot-ea
- y simd-pack-512-p0-slot other-pointer-lowtag)))
- (if (float-avx512-p x)
- (inst vmovups ea x)
- (inst vmovdqu64 ea x)))))
- (define-move-vop ,name :move
- ,scs (descriptor-reg))))))
+ (inst ,move tmp (ea-for-avx512-stack stack))
+ (storew (fixnumize ,tag) y simd-pack-512-tag-slot other-pointer-lowtag)
+ (inst ,move (object-slot-ea y simd-pack-512-p0-slot other-pointer-lowtag)
+ tmp)))
+ (define-move-vop ,name :move (,sc) (descriptor-reg))))))
;; see +simd-pack-element-types+
- (define-move-from-avx512 simd-pack-512-single 0 single-avx512-reg)
- (define-move-from-avx512 simd-pack-512-double 1 double-avx512-reg)
- (define-move-from-avx512 simd-pack-512-ub8 2 int-avx512-reg)
- (define-move-from-avx512 simd-pack-512-ub16 3 int-avx512-reg)
- (define-move-from-avx512 simd-pack-512-ub32 4 int-avx512-reg)
- (define-move-from-avx512 simd-pack-512-ub64 5 int-avx512-reg)
- (define-move-from-avx512 simd-pack-512-sb8 6 int-avx512-reg)
- (define-move-from-avx512 simd-pack-512-sb16 7 int-avx512-reg)
- (define-move-from-avx512 simd-pack-512-sb32 8 int-avx512-reg)
- (define-move-from-avx512 simd-pack-512-sb64 9 int-avx512-reg))
+ (define-move-from-avx512 simd-pack-512-single 0 vmovups single-avx512-reg single-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-double 1 vmovupd double-avx512-reg double-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-ub8 2 vmovdqu64 int-avx512-reg int-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-ub16 3 vmovdqu64 int-avx512-reg int-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-ub32 4 vmovdqu64 int-avx512-reg int-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-ub64 5 vmovdqu64 int-avx512-reg int-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-sb8 6 vmovdqu64 int-avx512-reg int-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-sb16 7 vmovdqu64 int-avx512-reg int-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-sb32 8 vmovdqu64 int-avx512-reg int-avx512-stack)
+ (define-move-from-avx512 simd-pack-512-sb64 9 vmovdqu64 int-avx512-reg int-avx512-stack))
(define-vop (move-to-avx512)
(:args (x :scs (descriptor-reg)))
diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index 68b79b046..acddaeac8 100644
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -406,7 +406,7 @@
int-sse-stack single-sse-stack double-sse-stack))
#+sb-simd-pack-256
(defparameter *hword-sc-names* '(ymm-reg int-avx2-reg single-avx2-reg double-avx2-reg
- int-avx2-stack single-avx2-stack
+ int-avx2-stack single-avx2-stack
double-avx2-stack))
#+sb-simd-pack-512
(defparameter *zword-sc-names* '(int-avx512-reg
diff --git a/tests/simd-pack-512-kmasks.pure.lisp b/tests/simd-pack-512-kmasks.pure.lisp
index 3a9e2446a..c59bb5e4e 100644
--- a/tests/simd-pack-512-kmasks.pure.lisp
+++ b/tests/simd-pack-512-kmasks.pure.lisp
@@ -264,20 +264,6 @@
(assert (not (search "ALLOC" text)))
(assert (not (search "KMOVQ" text)))))
-(with-test (:name :avx512-state-tn-p)
- (let* ((vm (find-package "SB-VM"))
- (c (find-package "SB-C"))
- (pred (and vm (find-symbol "AVX512-STATE-TN-P" vm)))
- (mask-reg (and vm (find-symbol "MASK-REG" vm)))
- (sc-or-lose (and c (find-symbol "SC-OR-LOSE" c)))
- (make-random-tn (and c (find-symbol "MAKE-RANDOM-TN" c)))
- (sc (and sc-or-lose mask-reg
- (funcall sc-or-lose mask-reg)))
- (tn (and make-random-tn sc
- (funcall make-random-tn sc 0))))
- (when (and pred tn)
- (assert (funcall pred tn)))))
-
(with-test (:name :kandq-disassembly)
(let* ((fun (compile nil
'(lambda (x y)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL