master: Basic support for AVX512 mask registers
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 c3bb5b870018b1d2b0458eebbb215e796830e283 (commit)
from 49beef5fe437fcfc1019e0d39605c136b7b1121c (commit)
- Log -----------------------------------------------------------------
commit c3bb5b870018b1d2b0458eebbb215e796830e283
Author: arthur <[email protected]>
Date: Thu Aug 13 18:28:34 2026 +0200
Basic support for AVX512 mask registers
* add simd-pack-512-mask as intrinsic type (widetag)
* add associated book-keeping in VM, compiler and interpreter for simd-pack-512-mask
* add VM support for mask registers (mask-reg SC, SB, defregs, ...)
* add VOPs to compiler backend for construction, extraction
* add VOPs for movement: kregs<->kregs, kregs<->gpr and kregs<->mem
* add support for assembler in insts, avx2-insts and avx512-insts
* rewrite most of evex emitter regarding mask registers
* add print support in evex for mask related instructions
* fix some smaller bugs in previous simd-pack-512 support patch
* add tests for creation, extraction, movements, assembly printing and some internal functions
* refactor zmm-registers-used-p into avx512-state-used-p and update call sites
* add support for mask regs to avx512-state-used-p
---
src/assembly/x86-64/support.lisp | 2 +-
src/code/class.lisp | 8 +-
src/code/cross-type.lisp | 3 +-
src/code/load.lisp | 5 +
src/code/pred.lisp | 4 +-
src/code/print.lisp | 11 +
src/code/room.lisp | 2 +-
src/code/stubs.lisp | 33 +++
src/code/type.lisp | 1 +
src/code/typep.lisp | 4 +-
src/cold/exports.lisp | 12 +-
src/compiler/dump.lisp | 7 +
src/compiler/generic/early-objdef.lisp | 12 +-
src/compiler/generic/genesis.lisp | 3 +-
src/compiler/generic/interr.lisp | 1 +
src/compiler/generic/late-objdef.lisp | 1 +
src/compiler/generic/objdef.lisp | 7 +
src/compiler/generic/primtype.lisp | 5 +
src/compiler/generic/type-vops.lisp | 4 +-
src/compiler/generic/vm-fndb.lisp | 11 +
src/compiler/generic/vm-type.lisp | 4 +-
src/compiler/generic/vm-typetran.lisp | 2 +
src/compiler/ir1tran.lisp | 3 +-
src/compiler/typetran.lisp | 3 +-
src/compiler/x86-64/alloc.lisp | 17 +-
src/compiler/x86-64/avx2-insts.lisp | 65 ++++-
src/compiler/x86-64/avx512-insts.lisp | 214 ++++++++++++---
src/compiler/x86-64/c-call.lisp | 41 ++-
src/compiler/x86-64/insts.lisp | 2 +
src/compiler/x86-64/parms.lisp | 2 +-
src/compiler/x86-64/simd-pack-512.lisp | 166 ++++++++++-
src/compiler/x86-64/target-avx2-insts.lisp | 14 +-
src/compiler/x86-64/vm.lisp | 66 +++--
tests/simd-pack-512-kmasks.pure.lisp | 427 +++++++++++++++++++++++++++++
34 files changed, 1056 insertions(+), 106 deletions(-)
diff --git a/src/assembly/x86-64/support.lisp b/src/assembly/x86-64/support.lisp
index dc219f20b..3f9aa5b77 100644
--- a/src/assembly/x86-64/support.lisp
+++ b/src/assembly/x86-64/support.lisp
@@ -69,7 +69,7 @@
(defmacro call-reg-specific-asm-routine (node prefix tn &optional (suffix ""))
`(invoke-asm-routine
'call
- (aref (if (zmm-registers-used-p)
+ (aref (if (avx512-state-used-p)
,(map 'vector
(lambda (x)
(unless (member x '(rsp rbp) :test 'string=)
diff --git a/src/code/class.lisp b/src/code/class.lisp
index dbb113762..0bdabf8a8 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -951,7 +951,8 @@ between the ~A definition and the ~A definition"
;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2
(declaim (type cons **non-instance-classoid-types**))
(defglobal **non-instance-classoid-types**
- '(symbol system-area-pointer weak-pointer code-component fdefn random-class))
+ '(symbol system-area-pointer weak-pointer code-component fdefn random-class
+ #+sb-simd-pack-512 simd-pack-512-mask))
(defun classoid-non-instance-p (classoid)
(declare (type classoid classoid))
@@ -1109,6 +1110,11 @@ between the ~A definition and the ~A definition"
;; KLUDGE: doesn't work without AVX512 support from the CPU
;; (%make-simd-pack-512-ub64 42 42 42 42 42 42 42 42)
sb-pcl:+slot-unbound+)
+ #+sb-simd-pack-512
+ (simd-pack-512-mask
+ :codes (,#.sb-vm:simd-pack-512-mask-widetag)
+ :predicate simd-pack-512-mask-p
+ :prototype-form sb-pcl:+slot-unbound+)
(real :translation real :inherits (number) :prototype-form 0)
(float :translation float :inherits (real number) :prototype-form 0f0)
(single-float
diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index 6502e644f..8d97d3773 100644
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -152,7 +152,8 @@
;; probably not a function. What about FMT-CONTROL instances?
(values nil t)))
((system-area-pointer stream fdefn weak-pointer file-stream
- code-component pathname logical-pathname)
+ code-component pathname logical-pathname
+ #+sb-simd-pack-512 simd-pack-512-mask)
(values nil t)))
(cond ((eq name 'pathname)
(values (pathnamep obj) t))
diff --git a/src/code/load.lisp b/src/code/load.lisp
index c777e28fa..7775422ca 100644
--- a/src/code/load.lisp
+++ b/src/code/load.lisp
@@ -909,6 +909,11 @@
(%make-simd-pack tag
(fast-read-u-integer 8)
(fast-read-u-integer 8)))))))
+
+#+sb-simd-pack-512
+(define-fop 90 :not-host (fop-simd-pack-512-mask)
+ (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream))
+ (%make-simd-pack-512-mask (fast-read-u-integer 8))))
;;;; loading lists
diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index 3a934d9d6..dc3f85515 100644
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -119,6 +119,7 @@
#+sb-simd-pack (def-type-predicate-wrapper simd-pack-p)
#+sb-simd-pack-256 (def-type-predicate-wrapper simd-pack-256-p)
#+sb-simd-pack-512 (def-type-predicate-wrapper simd-pack-512-p)
+ #+sb-simd-pack-512 (def-type-predicate-wrapper simd-pack-512-mask-p)
(def-type-predicate-wrapper %instancep)
(def-type-predicate-wrapper funcallable-instance-p)
(def-type-predicate-wrapper symbolp)
@@ -212,7 +213,8 @@
:complexp (if (typep object 'simple-array) nil :maybe)
:element-type etype
:specialized-element-type etype))))
- ((or complex #+sb-simd-pack simd-pack #+sb-simd-pack-256 simd-pack-256 #+sb-simd-pack-512 simd-pack-512)
+ ((or complex #+sb-simd-pack simd-pack #+sb-simd-pack-256 simd-pack-256
+ #+sb-simd-pack-512 (or simd-pack-512 simd-pack-512-mask))
(type-specifier (ctype-of object)))
(simple-fun 'compiled-function)
(t
diff --git a/src/code/print.lisp b/src/code/print.lisp
index 7ee1a0f67..e9db9054f 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -2068,6 +2068,17 @@ variable: an unreadable object representing the error is printed instead.")
(multiple-value-call #'format stream "~S~@{ ~20@D~}" 'simd-pack-256
(%simd-pack-256-sb64s pack))))))))
+#+sb-simd-pack-512
+(defmethod print-object ((mask simd-pack-512-mask) stream)
+ (let ((value (%simd-pack-512-mask-value mask)))
+ (cond ((and *print-readably* *read-eval*)
+ (format stream "#.(~S #x~16,'0X)" '%make-simd-pack-512-mask value))
+ (*print-readably*
+ (print-not-readable-error mask stream))
+ (t
+ (print-unreadable-object (mask stream)
+ (format stream "~S ~20D" 'simd-pack-512-mask value))))))
+
#+sb-simd-pack-512
(defmethod print-object ((pack simd-pack-512) stream)
(cond ((and *print-readably* *read-eval*)
diff --git a/src/code/room.lisp b/src/code/room.lisp
index eed4d94d2..1fcfc11c7 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -990,7 +990,7 @@ We could try a few things to mitigate this:
,.(make-case '(or float (complex float) bignum
#+sb-simd-pack simd-pack
#+sb-simd-pack-256 simd-pack-256
- #+sb-simd-pack-512 simd-pack-512
+ #+sb-simd-pack-512 (or simd-pack-512 simd-pack-512-mask)
system-area-pointer)) ; nothing to do
,.(make-case 'weak-pointer
#+weak-vector-readbarrier
diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp
index 7bbbfc047..191a3bb71 100644
--- a/src/code/stubs.lisp
+++ b/src/code/stubs.lisp
@@ -182,6 +182,39 @@
(def %numerator)
(def %denominator))
+#+sb-simd-pack-512
+(progn
+ (defun %make-simd-pack-512-mask (mask)
+ (declare (type (unsigned-byte 64) mask))
+ (let ((obj
+ (sb-c::%primitive
+ sb-vm::fixed-alloc
+ '%make-simd-pack-512-mask
+ sb-vm:simd-pack-512-mask-size
+ sb-vm:simd-pack-512-mask-widetag
+ sb-vm:other-pointer-lowtag
+ nil)))
+ (with-pinned-objects (obj)
+ (let ((sap (int-sap
+ (logandc2 (get-lisp-obj-address obj)
+ sb-vm:lowtag-mask))))
+ (setf (sap-ref-word
+ sap
+ (* sb-vm::simd-pack-512-mask-value-slot
+ sb-vm:n-word-bytes))
+ mask)))
+ obj))
+
+ (defun %simd-pack-512-mask-value (mask)
+ (declare (type sb-ext:simd-pack-512-mask mask))
+ (with-pinned-objects (mask)
+ (sap-ref-word
+ (int-sap
+ (logandc2 (get-lisp-obj-address mask)
+ sb-vm:lowtag-mask))
+ (* sb-vm::simd-pack-512-mask-value-slot
+ sb-vm:n-word-bytes)))))
+
;;; Document only those that SB-MANUAL:@UNTYPED-MEMORY singles out as
;;; examples.
(setf (documentation 'int-sap 'function)
diff --git a/src/code/type.lisp b/src/code/type.lisp
index 94838edf6..16a0261e0 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -5473,6 +5473,7 @@ expansion happened."
#+sb-simd-pack-512
(progn
+ ;; simd-pack related
(define-type-class simd-pack-512 :enumerable nil :might-contain-other-types nil)
;; Though this involves a recursive call to parser, parsing context need not
diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 6edf04727..9ac522d93 100644
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -283,7 +283,7 @@
character-set-type
#+sb-simd-pack simd-pack-type
#+sb-simd-pack-256 simd-pack-256-type
- #+sb-simd-pack-512 simd-pack-512-type)
+ #+sb-simd-pack-512 simd-pack-512-type)
(values (%%typep obj type)
t))
(array-type
@@ -485,6 +485,8 @@ Experimental."
(simd-pack-256 (simd-subtype (%simd-pack-256-tag x) simd-pack-256))
#+sb-simd-pack-512
(simd-pack-512 (simd-subtype (%simd-pack-512-tag x) simd-pack-512))
+ #+sb-simd-pack-512
+ (simd-pack-512-mask (specifier-type 'simd-pack-512-mask))
(t
(classoid-of x)))))
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index 950f0b0d4..98202996c 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -453,6 +453,9 @@
(:export
"SIMD-PACK-512"
"SIMD-PACK-512-P"
+ "SIMD-PACK-512-MASK"
+ "SIMD-PACK-512-MASK-P"
+ "%MAKE-SIMD-PACK-512-MASK"
"%MAKE-SIMD-PACK-512-UB32"
"%MAKE-SIMD-PACK-512-UB64"
"%MAKE-SIMD-PACK-512-DOUBLE"
@@ -1600,6 +1603,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
#+sb-simd-pack "%MAKE-SIMD-PACK"
#+sb-simd-pack-256 "%MAKE-SIMD-PACK-256"
#+sb-simd-pack-512 "%MAKE-SIMD-PACK-512"
+ #+sb-simd-pack-512 "%MAKE-SIMD-PACK-512-MASK"
"%MAKE-STRUCTURE-INSTANCE"
"%MAKE-STRUCTURE-INSTANCE-ALLOCATOR"
"%MAP" "%MAP-FOR-EFFECT-ARITY-1"
@@ -1926,6 +1930,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
#+sb-simd-pack "OBJECT-NOT-SIMD-PACK-ERROR"
#+sb-simd-pack-256 "OBJECT-NOT-SIMD-PACK-256-ERROR"
#+sb-simd-pack-512 "OBJECT-NOT-SIMD-PACK-512-ERROR"
+ #+sb-simd-pack-512 "OBJECT-NOT-SIMD-PACK-512-MASK-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-ERROR"
@@ -2419,6 +2424,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"%SIMD-PACK-256-2" "%SIMD-PACK-256-3")
#+sb-simd-pack-512
(:export "%SIMD-PACK-512-TAG"
+ "%SIMD-PACK-512-MASK-VALUE"
"%SIMD-PACK-512-0" "%SIMD-PACK-512-1"
"%SIMD-PACK-512-2" "%SIMD-PACK-512-3"
"%SIMD-PACK-512-4" "%SIMD-PACK-512-5"
@@ -3264,6 +3270,7 @@ structure representations")
"SIMD-PACK-256-WIDETAG")
#+sb-simd-pack-512
(:export
+ "+MASK-REGISTER-NAMES+"
"SIMD-PACK-512-TAG-SLOT"
"SIMD-PACK-512-P0-SLOT"
"SIMD-PACK-512-P1-SLOT"
@@ -3274,7 +3281,10 @@ structure representations")
"SIMD-PACK-512-P6-SLOT"
"SIMD-PACK-512-P7-SLOT"
"SIMD-PACK-512-SIZE"
- "SIMD-PACK-512-WIDETAG"))
+ "SIMD-PACK-512-WIDETAG"
+ "SIMD-PACK-512-MASK-WIDETAG"
+ "SIMD-PACK-512-MASK-SIZE"
+ "SIMD-PACK-512-MASK-VALUE-SLOT"))
(defpackage "SB-DISASSEM"
(:documentation "private: stuff related to the implementation of the disassembler")
diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index e04dcd991..fdacbe45c 100644
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -518,6 +518,13 @@
(unless (similar-check-table x file)
(dump-simd-pack-512 x file)
(similar-save-object x file)))
+ #+(and (not sb-xc-host) sb-simd-pack-512)
+ (simd-pack-512-mask
+ (unless (similar-check-table x file)
+ (dump-fop 'fop-simd-pack-512-mask file)
+ (dump-integer-as-n-bytes
+ (%simd-pack-512-mask-value x) 8 file)
+ (similar-save-object x file)))
(t
;; This probably never happens, since bad things tend to
;; be detected during IR1 conversion.
diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp
index cec8d1a7f..11d8fb579 100644
--- a/src/compiler/generic/early-objdef.lisp
+++ b/src/compiler/generic/early-objdef.lisp
@@ -225,9 +225,10 @@
#-sb-simd-pack-256 unused03-widetag ; 62
#+sb-simd-pack-512 simd-pack-512-widetag ; 6D
#-sb-simd-pack-512 unused04-widetag ; 66
+ #+sb-simd-pack-512 simd-pack-512-mask-widetag ; 71
+ #-sb-simd-pack-512 unused05-widetag ; 6A
- filler-widetag ; 6A 6D
- unused05-widetag ; 6E 75
+ filler-widetag ; 6E 75
unused06-widetag ; 72 79
unused07-widetag ; 76 7D
#-64-bit unused08-widetag ; 7A
@@ -313,9 +314,10 @@
(unbound-marker-widetag "unbound-marker")
(weak-pointer-widetag "weakptr")
(fdefn-widetag "fdefn")
- (simd-pack-widetag "SIMD-pack")
- (simd-pack-256-widetag "SIMD-pack256")
- (simd-pack-512-widetag "SIMD-pack512")
+ #+sb-simd-pack (simd-pack-widetag "SIMD-pack")
+ #+sb-simd-pack-256 (simd-pack-256-widetag "SIMD-pack256")
+ #+sb-simd-pack-512 (simd-pack-512-widetag "SIMD-pack512")
+ #+sb-simd-pack-512 (simd-pack-512-mask-widetag "SIMD-pack512-mask")
(filler-widetag "filler")
(simple-array-widetag "simple-array")
(simple-array-nil-widetag "simple-array-NIL")
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 141609714..4c6e60468 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -3426,7 +3426,8 @@ Legal values for OFFSET are -4, -8, -12, ..."
(write-tags "" "-WIDETAG" (ash (1+ sb-vm:widetag-mask) -2) -2))
(dolist (name '(symbol ratio complex sb-vm::code simple-fun
closure funcallable-instance
- weak-pointer fdefn sb-vm::value-cell))
+ weak-pointer fdefn sb-vm::value-cell
+ #+sb-simd-pack-512 sb-vm::simd-pack-512-mask))
(format out "static char *~A_slots[] = {~%~{ \"~A: \",~} NULL~%};~%"
(c-name (string-downcase name))
(map 'list (lambda (x) (c-name (string-downcase (sb-vm:slot-name x))))
diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp
index 1d2187cfa..1e7a08467 100644
--- a/src/compiler/generic/interr.lisp
+++ b/src/compiler/generic/interr.lisp
@@ -182,6 +182,7 @@
#+sb-simd-pack simd-pack
#+sb-simd-pack-256 simd-pack-256
#+sb-simd-pack-512 simd-pack-512
+ #+sb-simd-pack-512 simd-pack-512-mask
weak-pointer
instance
#+sb-unicode
diff --git a/src/compiler/generic/late-objdef.lisp b/src/compiler/generic/late-objdef.lisp
index ec070aee6..9089d3033 100644
--- a/src/compiler/generic/late-objdef.lisp
+++ b/src/compiler/generic/late-objdef.lisp
@@ -75,6 +75,7 @@
#+sb-simd-pack (simd-pack "unboxed")
#+sb-simd-pack-256 (simd-pack-256 "unboxed")
#+sb-simd-pack-512 (simd-pack-512 "unboxed")
+ #+sb-simd-pack-512 (simd-pack-512-mask "unboxed")
(filler "filler" "lose" "filler")
(simple-array "array")
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index 1ab501f14..6acd4b8d7 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -468,6 +468,13 @@ during backtrace.
(p6 :c-type "long" :type (unsigned-byte 64))
(p7 :c-type "long" :type (unsigned-byte 64)))
+#+sb-simd-pack-512
+(define-primitive-object (simd-pack-512-mask
+ :lowtag other-pointer-lowtag
+ :size simd-pack-512-mask-size
+ :widetag simd-pack-512-mask-widetag)
+ (value :c-type "long" :type (unsigned-byte 64)))
+
;;; Define some slots that precede 'struct thread' so that each may be read
;;; using a small negative 1-byte displacement.
(defconstant-eqx +thread-header-slot-names+ #()
diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index 9369f72c0..28831782f 100644
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -196,6 +196,8 @@
simd-pack-256-sb64)))
#+sb-simd-pack-512
(progn
+ (!def-primitive-type simd-pack-512-mask-type (descriptor-reg mask-reg)
+ :type simd-pack-512-mask)
(!def-primitive-type simd-pack-512-single (single-avx512-reg descriptor-reg)
:type (simd-pack-512 single-float))
(!def-primitive-type simd-pack-512-double (double-avx512-reg descriptor-reg)
@@ -549,6 +551,9 @@
(values (primitive-type-or-lose (classoid-name type)) t))
((pathname logical-pathname)
(part-of instance))
+ #+sb-simd-pack-512
+ (simd-pack-512-mask
+ (values (primitive-type-or-lose 'simd-pack-512-mask-type) t))
(t
(any))))
(fun-designator-type
diff --git a/src/compiler/generic/type-vops.lisp b/src/compiler/generic/type-vops.lisp
index 398a712e0..2d429b209 100644
--- a/src/compiler/generic/type-vops.lisp
+++ b/src/compiler/generic/type-vops.lisp
@@ -188,7 +188,9 @@
#+sb-simd-pack-256
(define-type-vop simd-pack-256-p (simd-pack-256-widetag))
#+sb-simd-pack-512
-(define-type-vop simd-pack-512-p (simd-pack-512-widetag))
+(progn
+ (define-type-vop simd-pack-512-p (simd-pack-512-widetag))
+ (define-type-vop simd-pack-512-mask-p (simd-pack-512-mask-widetag)))
;;; Not type vops, but generic over all backends
(macrolet ((def (name lowtag)
diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 8c2085bfa..75529742c 100644
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -492,6 +492,13 @@
#+sb-simd-pack-512
(progn
+ (defknown simd-pack-512-mask-p (t) boolean (foldable movable flushable))
+ (defknown %make-simd-pack-512-mask ((unsigned-byte 64))
+ simd-pack-512-mask
+ (flushable movable foldable))
+ (defknown %simd-pack-512-mask-value (simd-pack-512-mask)
+ (unsigned-byte 64)
+ (flushable movable foldable))
(defknown simd-pack-512-p (t) boolean (foldable movable flushable))
(defknown %simd-pack-512-tag (simd-pack-512) fixnum (movable flushable))
(defknown %make-simd-pack-512 (fixnum (unsigned-byte 64) (unsigned-byte 64)
@@ -500,6 +507,10 @@
(unsigned-byte 64) (unsigned-byte 64))
simd-pack-512
(flushable movable foldable))
+ (defknown %simd-pack-512-single-item (simd-pack-512 (integer 0 15)) single-float
+ (flushable movable foldable))
+ (defknown %simd-pack-512-double-item (simd-pack-512 (integer 0 7)) double-float
+ (flushable movable foldable))
(defknown %make-simd-pack-512-double (double-float double-float double-float double-float
double-float double-float double-float double-float)
(simd-pack-512 double-float)
diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp
index 5af4908e0..dc86f1056 100644
--- a/src/compiler/generic/vm-type.lisp
+++ b/src/compiler/generic/vm-type.lisp
@@ -272,7 +272,9 @@
(cond ((built-in-classoid-p type)
(case (classoid-name type)
(system-area-pointer sb-vm:sap-widetag)
- (fdefn sb-vm:fdefn-widetag)))
+ (fdefn sb-vm:fdefn-widetag)
+ #+sb-simd-pack-512
+ (simd-pack-512-mask sb-vm:simd-pack-512-mask-widetag)))
((numeric-type-p type)
(cond ((type= type (specifier-type '(complex single-float)))
sb-vm:complex-single-float-widetag)
diff --git a/src/compiler/generic/vm-typetran.lisp b/src/compiler/generic/vm-typetran.lisp
index a83e6b7fb..61ae00d64 100644
--- a/src/compiler/generic/vm-typetran.lisp
+++ b/src/compiler/generic/vm-typetran.lisp
@@ -118,6 +118,8 @@
(define-type-predicate simd-pack-256-p simd-pack-256)
#+sb-simd-pack-512
(define-type-predicate simd-pack-512-p simd-pack-512)
+#+sb-simd-pack-512
+(define-type-predicate simd-pack-512-mask-p simd-pack-512-mask)
(define-type-predicate weak-pointer-p weak-pointer)
(define-type-predicate code-component-p code-component)
(define-type-predicate fdefn-p fdefn)
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 08e97bbde..66f5a6ec1 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -342,7 +342,8 @@
system-area-pointer
#+sb-simd-pack simd-pack
#+sb-simd-pack-256 simd-pack-256
- #+sb-simd-pack-512 simd-pack-512))
+ #+sb-simd-pack-512 simd-pack-512
+ #+sb-simd-pack-512 simd-pack-512-mask))
;; STANDARD-OBJECT layouts use MAKE-LOAD-FORM, but all other layouts
;; have the same status as symbols - composite objects but leaflike.
(and (typep obj 'layout) (not (layout-for-pcl-obj-p obj)))
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 033c548c3..d9ab1793b 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -100,7 +100,8 @@
'(or array
(and number (not (or fixnum #+64-bit single-float)))
fdefn (and symbol (not null))
- weak-pointer system-area-pointer code-component))
+ weak-pointer system-area-pointer code-component
+ #+sb-simd-pack-512 simd-pack-512-mask))
(defun type-other-pointer-p (type)
(csubtypep type (specifier-type 'other-pointer)))
diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index 6963b277e..56a2babfa 100644
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -213,16 +213,21 @@
(define-vop (sb-c::end-pseudo-atomic)
(:generator 1 (emit-end-pseudo-atomic)))
-(defun zmm-registers-used-p ()
+(defun avx512-state-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 (sc-is tn int-avx512-reg
- double-avx512-reg
- single-avx512-reg)
- (return-from zmm-registers-used-p t)))))
+ (when (avx512-state-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))))))
@@ -241,7 +246,7 @@
(avx512 :default))
(declare (ignorable thread-temp))
(when (eq avx512 :default)
- (setf avx512 (zmm-registers-used-p)))
+ (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()
diff --git a/src/compiler/x86-64/avx2-insts.lisp b/src/compiler/x86-64/avx2-insts.lisp
index 064da937c..d07fe886b 100644
--- a/src/compiler/x86-64/avx2-insts.lisp
+++ b/src/compiler/x86-64/avx2-insts.lisp
@@ -1,5 +1,9 @@
(in-package "SB-X86-64-ASM")
+(define-arg-type k-vvvv-reg
+ :prefilter #'invert-4
+ :printer #'print-kreg)
+
(define-arg-type ymmreg
:prefilter #'prefilter-reg-r
:printer #'print-ymmreg)
@@ -113,8 +117,23 @@
;; Opmask register k0-k7
(define-arg-type opmask-reg
- :printer #'print-opmask-reg)
+ :printer #'print-opmask-register)
+;;; K register in a ModR/M register field.
+(define-arg-type kreg
+ :prefilter (lambda (dstate value)
+ (declare (ignore dstate))
+ (get-fpr :kreg value))
+ :printer #'print-kreg)
+
+;;; K register or memory in a ModR/M r/m field.
+;;; This is only valid for instructions whose r/m operand can be K or memory.
+(define-arg-type kreg/mem
+ :prefilter (lambda (dstate mod r/m)
+ (if (= mod #b11)
+ (get-fpr :kreg r/m)
+ (decode-mod-r/m dstate mod r/m 'gpr)))
+ :printer #'print-kreg/mem)
(define-instruction-format (vex2 16)
(vex :field (byte 8 0) :value #xC5)
@@ -214,6 +233,48 @@
(reg :field (byte 3 (+ start 11))
:type 'reg))
+(define-vex-instruction-format (kreg-kreg/mem 16
+ :default-printer '(:name :tab reg ", " reg/mem))
+ (op :field (byte 8 (+ start 0)))
+ (reg/mem :fields (list (byte 2 (+ start 14)) (byte 3 (+ start 8)))
+ :type 'kreg/mem)
+ (reg :field (byte 3 (+ start 11))
+ :type 'kreg))
+
+(define-vex-instruction-format (kreg-reg/mem 16
+ :default-printer '(:name :tab reg ", " reg/mem))
+ (op :field (byte 8 (+ start 0)))
+ (reg/mem :fields (list (byte 2 (+ start 14)) (byte 3 (+ start 8)))
+ :type 'reg/mem)
+ (reg :field (byte 3 (+ start 11))
+ :type 'kreg))
+
+(define-vex-instruction-format (reg-kreg/mem 16
+ :default-printer '(:name :tab reg ", " reg/mem))
+ (op :field (byte 8 (+ start 0)))
+ (reg/mem :fields (list (byte 2 (+ start 14)) (byte 3 (+ start 8)))
+ :type 'kreg/mem)
+ (reg :field (byte 3 (+ start 11))
+ :type 'reg))
+
+(define-vex-instruction-format (kreg-kreg/mem-k 16
+ :default-printer '(:name :tab reg ", " vvvv ", " reg/mem))
+ (op :field (byte 8 (+ start 0)))
+ (reg/mem :fields (list (byte 2 (+ start 14)) (byte 3 (+ start 8)))
+ :type 'kreg/mem)
+ (reg :field (byte 3 (+ start 11))
+ :type 'kreg)
+ (vvvv :type 'k-vvvv-reg))
+
+(define-vex-instruction-format (kreg-kreg/mem-imm 16
+ :default-printer '(:name :tab reg ", " reg/mem ", " imm))
+ (op :field (byte 8 (+ start 0)))
+ (reg/mem :fields (list (byte 2 (+ start 14)) (byte 3 (+ start 8)))
+ :type 'kreg/mem)
+ (reg :field (byte 3 (+ start 11))
+ :type 'kreg)
+ (imm :type 'imm-byte))
+
;;; EVEX instruction formats for disassembly
;;; EVEX prefix is 4 bytes (32 bits):
;;; Byte 0: #x62
@@ -477,7 +538,7 @@ EVEX uses independent bit3 (R/B) and bit4 (R'/X) for 32-register encoding."
;; R from reg (ModR/M reg field) - bit 3
(r (if (null reg) 0 (reg-bit3 (reg-id reg))))
;; R' from reg - bit 4
- (r-prime (if (null reg) 0 (reg-bit4 (reg-id reg))))
+ (r-prime (if (or (null reg) (k-register-p reg)) 0 (reg-bit4 (reg-id reg))))
;; X from EA index, or bit 4 of r/m reg for register-direct
;; In EVEX, X doubles as B' (bit 4 of r/m) when mod=11 (reg-direct)
(x (cond ((and (ea-p thing)
diff --git a/src/compiler/x86-64/avx512-insts.lisp b/src/compiler/x86-64/avx512-insts.lisp
index f62ae489f..fe5ca1ddb 100644
--- a/src/compiler/x86-64/avx512-insts.lisp
+++ b/src/compiler/x86-64/avx512-insts.lisp
@@ -298,32 +298,135 @@
;;; Opmask instructions
;;; KMOV - Move to/from opmask registers
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun kmov-printer-list (format-stem prefix opcode w &key printer)
+ (let ((pp (vex-encode-pp prefix))
+ (m-mmmm (vex-encode-m-mmmm #x0F)))
+ (flet ((make-printer (inst-format fields)
+ `(:printer ,inst-format ,fields
+ ,@(when printer `(',printer)))))
+ (if (eql w 1)
+ (list
+ (make-printer
+ (symbolicate "VEX3-" format-stem)
+ `((pp ,pp)
+ (m-mmmm ,m-mmmm)
+ (w ,w)
+ (op ,opcode))))
+ (list
+ (make-printer
+ (symbolicate "VEX2-" format-stem)
+ `((pp ,pp)
+ (op ,opcode)))
+ (make-printer
+ (symbolicate "VEX3-" format-stem)
+ `((pp ,pp)
+ (m-mmmm ,m-mmmm)
+ (w ,w)
+ (op ,opcode)))))))))
+
;;; These use VEX encoding (not EVEX), with k registers in ModR/M fields
-(macrolet ((def (name prefix opcode-from opcode-to w)
+(macrolet ((def (name kk-prefix gr-prefix store-mem-prefix load-mem-prefix
+ op-k-k op-k-r op-r-k op-m-k op-k-m w)
`(define-instruction ,name (segment dst src)
(:emitter
- (cond ((k-register-p dst)
- ;; k <- k/m or k <- gpr
- (emit-vex segment nil src dst ,prefix #x0F nil ,w)
- (emit-bytes segment ,opcode-from)
- (emit-ea segment src dst))
- (t
- ;; m <- k or gpr <- k
- (emit-vex segment nil dst src ,prefix #x0F nil ,w)
- (emit-bytes segment ,opcode-to)
- (emit-ea segment dst src)))))))
- (def kmovw nil #x90 #x91 0)
- (def kmovb #x66 #x90 #x91 0)
- (def kmovd #x66 #x90 #x91 1)
- (def kmovq #xf2 #x90 #x91 1))
+ (cond
+ ((and (k-register-p dst) (k-register-p src))
+ ;; VEX: k1 <- k2
+ (emit-vex segment nil src dst ,kk-prefix #x0F 0 ,w)
+ (emit-bytes segment ,op-k-k)
+ (emit-ea segment src dst))
+
+ ((and (k-register-p dst) (gpr-p src))
+ ;; VEX: k1 <- r32/r64
+ (emit-vex segment nil src dst ,gr-prefix #x0F 0 ,w)
+ (emit-bytes segment ,op-k-r)
+ (emit-ea segment src dst))
+
+ ((and (gpr-p dst) (k-register-p src))
+ ;; VEX: r32/r64 <- k1
+ (emit-vex segment nil src dst ,gr-prefix #x0F 0 ,w)
+ (emit-bytes segment ,op-r-k)
+ (emit-ea segment src dst))
+
+ ((and (k-register-p dst) (or (ea-p src) (tn-p src)))
+ ;; VEX: k1 <- m16/m32/m64
+ (emit-vex segment nil src dst ,load-mem-prefix #x0F 0 ,w)
+ (emit-bytes segment ,op-k-m)
+ (emit-ea segment src dst))
+
+ ((and (or (ea-p dst) (tn-p dst)) (k-register-p src))
+ ;; VEX: m16/m32/m64 <- k1
+ (emit-vex segment nil dst src ,store-mem-prefix #x0F 0 ,w)
+ (emit-bytes segment ,op-m-k)
+ (emit-ea segment dst src))
+
+ (t
+ (error "invalid operands for ~A: ~S, ~S" ',name dst src))))
+
+ ;; printers:
+ ;; K <- K and K <- memory share the same opcode
+ ;; and are both decoded by kreg-kreg/mem.
+ ,@(kmov-printer-list 'kreg-kreg/mem kk-prefix op-k-k w)
+
+ ;; K <- GPR
+ ,@(kmov-printer-list 'kreg-reg/mem gr-prefix op-k-r w)
+
+ ;; GPR <- K
+ ,@(kmov-printer-list 'reg-kreg/mem gr-prefix op-r-k w)
+
+ ;; memory <- K
+ ;; ModRM.reg = K, ModRM.r/m = memory.
+ ;; kreg-kreg/mem can decode r/m as memory.
+ ,@(kmov-printer-list 'kreg-kreg/mem store-mem-prefix op-m-k w
+ :printer '(:name :tab reg/mem ", " reg)))))
+
+ ;; kk gr store load k<-k k<-r r<-k m<-k k<-m w
+ (def kmovw nil nil nil nil #x90 #x92 #x93 #x91 #x90 0)
+ (def kmovb #x66 #x66 #x66 #x66 #x90 #x92 #x93 #x91 #x90 0)
+ (def kmovd #x66 #x66 #x66 #x66 #x90 #x92 #x93 #x91 #x90 1)
+ (def kmovq nil #xf2 nil nil #x90 #x92 #x93 #x91 #x90 1))
;;; KAND, KOR, KXOR, etc. - Opmask logical operations (VEX.L1)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun klogical-printer-list (prefix opcode w)
+ (let ((pp (vex-encode-pp prefix))
+ (m-mmmm (vex-encode-m-mmmm #x0F)))
+ (flet ((make-printer (inst-format fields)
+ `(:printer ,inst-format ,fields)))
+ (if (eql w 1)
+ (list
+ (make-printer
+ (symbolicate "VEX3-" 'kreg-kreg/mem-k)
+ `((pp ,pp)
+ (m-mmmm ,m-mmmm)
+ (w ,w)
+ (l 1)
+ (op ,opcode))))
+ (list
+ (make-printer
+ (symbolicate "VEX2-" 'kreg-kreg/mem-k)
+ `((pp ,pp)
+ (l 1)
+ (op ,opcode)))
+ (make-printer
+ (symbolicate "VEX3-" 'kreg-kreg/mem-k)
+ `((pp ,pp)
+ (m-mmmm ,m-mmmm)
+ (w ,w)
+ (l 1)
+ (op ,opcode)))))))))
+
(macrolet ((def (name prefix opcode w)
`(define-instruction ,name (segment dst src1 src2)
(:emitter
(emit-vex segment src1 src2 dst ,prefix #x0F 1 ,w)
(emit-bytes segment ,opcode)
- (emit-ea segment src2 dst)))))
+ (emit-ea segment src2 dst))
+
+ ,@(klogical-printer-list prefix opcode w))))
+
(def kandw nil #x41 0)
(def kandb #x66 #x41 0)
(def kandd #x66 #x41 1)
@@ -346,12 +449,16 @@
(def kxnorq #xf2 #x46 1))
;;; KNOT, KTEST - single-source opmask operations
+;;; Encoding: ModRM.reg = dst, VEX.vvvv = src1, ModRM.r/m = src2
(macrolet ((def (name prefix opcode w)
`(define-instruction ,name (segment dst src)
(:emitter
- (emit-vex segment nil src dst ,prefix #x0F nil ,w)
+ (emit-vex segment nil src dst ,prefix #x0F 0 ,w)
(emit-bytes segment ,opcode)
- (emit-ea segment src dst)))))
+ (emit-ea segment src dst))
+
+ ,@(kmov-printer-list 'kreg-kreg/mem prefix opcode w))))
+
(def knotw nil #x44 0)
(def knotb #x66 #x44 0)
(def knotd #x66 #x44 1)
@@ -369,9 +476,12 @@
(macrolet ((def (name prefix w)
`(define-instruction ,name (segment dst src1 src2)
(:emitter
- (emit-vex segment src1 src2 dst ,prefix #x0F 1 ,w)
+ (emit-vex segment src1 src2 dst ,prefix #x0F nil ,w)
(emit-bytes segment #x4b)
- (emit-ea segment src2 dst)))))
+ (emit-ea segment src2 dst))
+
+ ,@(klogical-printer-list prefix #x4b w))))
+
(def kunpckbw #x66 0)
(def kunpckwd nil 0)
(def kunpckdq nil 1))
@@ -533,22 +643,16 @@
(def vprord #x72 0 0)
(def vprorq #x72 0 1))
-;;; vpsraq - dual form (register + immediate)
-(define-instruction vpsraq (segment dst src src2/imm)
+;;; VPSRAQ immediate form.
+;;; The variable-shift form VPSRAVQ is defined separately.
+(define-instruction vpsraq (segment dst src imm)
(:emitter
- (if (integerp src2/imm)
- (emit-avx512-inst-imm segment dst src src2/imm
- #x66 #x72 4
- :w 1)
- (emit-avx512-inst segment src2/imm dst #x66 #xe2
- :opcode-prefix #x0f38
- :vvvv src
- :w 1)))
- . #.(append (avx512-inst-printer-list 'ymm-ymm-imm #x66 #x72
- :w 1
- :more-fields '((/i 4)))
- (avx512-inst-printer-list 'ymm-ymm/mem #x66 #xe2
- :opcode-prefix #x0f38 :w 1 :nds t)))
+ (emit-avx512-inst-imm segment dst src imm
+ #x66 #x72 4
+ :w 1))
+ . #.(avx512-inst-printer-list 'ymm-ymm-imm #x66 #x72
+ :w 1
+ :more-fields '((/i 4))))
;;; Unsigned conversions (2-operand)
(macrolet ((def (name prefix opcode w &optional (opcode-prefix #x0f))
@@ -667,17 +771,34 @@
(def vpbroadcastq-gpr #x7c 1))
;;; VEX-encoded kshift (dst, src, imm8)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun kshift-printer-list (prefix opcode w)
+ (let ((fields
+ `((pp ,(vex-encode-pp prefix))
+ (m-mmmm ,(vex-encode-m-mmmm #x0F3A))
+ (w ,w)
+ (l 0)
+ (op ,opcode)
+ (imm nil :type 'imm-byte))))
+ (list
+ `(:printer ,(symbolicate "VEX3-" 'kreg-kreg/mem-imm)
+ ,fields)))))
+
(macrolet ((def (name prefix opcode w)
`(define-instruction ,name (segment dst src imm)
(:emitter
(emit-vex segment nil src dst ,prefix #x0F3A 0 ,w)
(emit-bytes segment ,opcode)
(emit-ea segment src dst :remaining-bytes 1)
- (emit-byte segment imm)))))
+ (emit-byte segment imm))
+
+ ,@(kshift-printer-list prefix opcode w))))
+
(def kshiftlb #x66 #x32 0)
(def kshiftlw #x66 #x32 1)
(def kshiftld #x66 #x33 0)
(def kshiftlq #x66 #x33 1)
+
(def kshiftrb #x66 #x30 0)
(def kshiftrw #x66 #x30 1)
(def kshiftrd #x66 #x31 0)
@@ -689,11 +810,14 @@
(:emitter
(emit-vex segment src1 src2 dst ,prefix #x0F 1 ,w)
(emit-bytes segment ,opcode)
- (emit-ea segment src2 dst)))))
- (def kaddb #x66 #x4a 0)
- (def kaddw nil #x4a 0)
- (def kaddd #x66 #x4a 1)
- (def kaddq #xf2 #x4a 1))
+ (emit-ea segment src2 dst))
+
+ ,@(klogical-printer-list prefix opcode w))))
+
+ (def kaddb #x66 #x4a 0)
+ (def kaddw nil #x4a 0)
+ (def kaddd #x66 #x4a 1)
+ (def kaddq #xf2 #x4a 1))
;;; Compare-to-k (kdst, src1, src2, imm8) - k-reg in ModR/M reg
(macrolet ((def (name prefix opcode w)
@@ -1093,8 +1217,8 @@
:aaa mask
:vm t)))))
;; Dword destinations (8 lanes, YMM dst; index is ZMM qword)
- (def vpgatherqd-z #x91 0)
- (def vgatherqps-z #x93 0)
+ (def vpgatherqd-z #x91 1)
+ (def vgatherqps-z #x93 1)
;; Qword destinations (8 lanes, ZMM dst; index is ZMM qword)
(def vpgatherqq-z #x91 1)
(def vgatherqpd-z #x93 1)
@@ -1115,8 +1239,8 @@
:w ,w
:aaa mask
:vm t)))))
- (def vpscatterqd-z #xa1 0)
- (def vscatterqps-z #xa3 0)
+ (def vpscatterqd-z #xa1 1)
+ (def vscatterqps-z #xa3 1)
(def vpscatterqq-z #xa1 1)
(def vscatterqpd-z #xa3 1)
(def vpscatterdd-z #xa0 0)
diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index ef603ab17..a10e4be9d 100644
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -653,14 +653,43 @@ Floats are passed in integer registers."
'#:r8 '#:r9 '#:r10 '#:r11))
(vars))
(append
+ ;; Caller-saved GPRs.
(loop for gpr in gprs
- for offset = (symbol-value (intern (concatenate 'string (symbol-name gpr) "-OFFSET") "SB-VM"))
- collect `(:temporary (:sc any-reg :offset ,offset :from :eval :to :result)
- ,(car (push gpr vars))))
- (loop for float to 15
+ for offset = (symbol-value
+ (intern (concatenate 'string
+ (symbol-name gpr)
+ "-OFFSET")
+ "SB-VM"))
+ collect `(:temporary
+ (:sc any-reg :offset ,offset :from :eval :to :result)
+ ,(car (push gpr vars))))
+
+ ;; Low 16 vector registers, XMM0-15.
+ ;; These also cover the low halves of YMM0-15 and ZMM0-15.
+ (loop for float below 16
for varname = (format nil "FLOAT~D" float)
- collect `(:temporary (:sc single-reg :offset ,float :from :eval :to :result)
- ,(car (push (make-symbol varname) vars))))
+ collect `(:temporary
+ (:sc single-reg :offset ,float :from :eval :to :result)
+ ,(car (push (make-symbol varname) vars))))
+
+ ;; AVX-512 high ZMM registers, ZMM16-31.
+ #+sb-simd-pack-512
+ (loop for zmm from 16 below 32
+ for varname = (format nil "ZMM~D" zmm)
+ collect `(:temporary
+ (:sc single-avx512-reg :offset ,zmm
+ :from :eval :to :result)
+ ,(car (push (make-symbol varname) vars))))
+
+ ;; AVX-512 opmask registers K1-K7.
+ ;; K0 is not allocatable so not listed here
+ #+sb-simd-pack-512
+ (loop for mask from 1 to 7
+ for varname = (format nil "MASK~D" mask)
+ collect `(:temporary
+ (:sc mask-reg :offset ,mask :from :eval :to :result)
+ ,(car (push (make-symbol varname) vars))))
+
`((:ignore ,@vars))))))
(define-vop (call-out)
diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp
index 3d517f474..c0b9786a6 100644
--- a/src/compiler/x86-64/insts.lisp
+++ b/src/compiler/x86-64/insts.lisp
@@ -1178,6 +1178,8 @@
(get-fpr :ymm (tn-offset operand)))
((eq (sb-name (sc-sb (tn-sc operand))) 'float-registers)
(get-fpr :xmm (tn-offset operand)))
+ ((eq (sb-name (sc-sb (tn-sc operand))) 'sb-vm::mask-registers)
+ (get-fpr :kreg (tn-offset operand)))
(t ; a stack SC or constant
operand)))
operands))
diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp
index bc12da842..9333260f1 100644
--- a/src/compiler/x86-64/parms.lisp
+++ b/src/compiler/x86-64/parms.lisp
@@ -199,7 +199,7 @@
;;; Bit indices into *CPU-FEATURE-BITS*
(defconstant cpu-has-ymm-registers 0)
(defconstant cpu-has-popcnt 1)
-(defconstant cpu-has-zmm-registers 2) ;; fixme512 which bit: 3?
+(defconstant cpu-has-zmm-registers 2)
#+sb-simd-pack
(progn
diff --git a/src/compiler/x86-64/simd-pack-512.lisp b/src/compiler/x86-64/simd-pack-512.lisp
index 5fd01fab4..5f5a1433e 100644
--- a/src/compiler/x86-64/simd-pack-512.lisp
+++ b/src/compiler/x86-64/simd-pack-512.lisp
@@ -22,7 +22,7 @@
(defun int-avx512-p (tn)
(sc-is tn int-avx512-reg int-avx512-stack fp-immediate))
-
+
#+sb-xc-host
(progn ; the host compiler will complain about absence of these
(defun %simd-pack-512-0 (x) (error "Called %SIMD-PACK-512-0 ~S" x))
@@ -32,7 +32,164 @@
(defun %simd-pack-512-4 (x) (error "Called %SIMD-PACK-512-4 ~S" x))
(defun %simd-pack-512-5 (x) (error "Called %SIMD-PACK-512-5 ~S" x))
(defun %simd-pack-512-6 (x) (error "Called %SIMD-PACK-512-6 ~S" x))
- (defun %simd-pack-512-7 (x) (error "Called %SIMD-PACK-512-7 ~S" x)))
+ (defun %simd-pack-512-7 (x) (error "Called %SIMD-PACK-512-7 ~S" x))
+ (defun %simd-pack-512-mask-value (x) (error "Called %SIMD-PACK-512-MASK-VALUE ~S" x)))
+
+;; mask registers
+
+;; Mask registers are 64-bit registers so we can reuse ea from scalar regs for
+;; stack spilling, but the system has to use the specialized kmovq instruction
+;; since they live in their own hardware registers, not shared with either
+;; scalar nor zmm regs.
+
+(define-move-fun (load-mask 2) (vop x y)
+ ((kmask-stack) (mask-reg))
+ (inst kmovq y x))
+
+(define-move-fun (store-mask 2) (vop x y)
+ ((mask-reg) (kmask-stack))
+ (inst kmovq y x))
+
+(define-move-fun (load-mask-immediate 1) (vop x y)
+ ((fp-immediate) (mask-reg))
+ (let ((val (%simd-pack-512-mask-value (tn-value x))))
+ (cond ((= val 0) (inst kxorq y y y))
+ ((= val (ldb (byte 64 0) -1)) (inst kxnorq y y y))
+ (t (inst kmovq y (register-inline-constant :qword val))))))
+
+(define-vop (mask-move)
+ (:args (x :scs (mask-reg) :target y :load-if (not (location= x y))))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (y :scs (mask-reg) :load-if (not (location= x y))))
+ (:result-types simd-pack-512-mask-type)
+ (:note "avx512 mask move")
+ (:generator 3
+ (unless (location= y x)
+ (inst kmovq y x))))
+
+(define-vop (move-mask-arg)
+ (:args (x :scs (mask-reg) :target y)
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y mask-reg))))
+ (:results (y))
+ (:note "avx512 mask argument move")
+ (:generator 4
+ (sc-case y
+ (mask-reg
+ (unless (location= x y)
+ (inst kmovq y x)))
+ (kmask-stack
+ (inst kmovq (ea (frame-byte-offset (tn-offset y)) fp) x)))))
+
+(define-vop (move-to-mask)
+ (:args (x :scs (descriptor-reg)))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (y :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:note "pointer to mask coercion")
+ (:generator 2
+ (let ((ea (object-slot-ea x simd-pack-512-mask-value-slot other-pointer-lowtag)))
+ (inst kmovq y ea))))
+
+(define-allocator (move-from-mask)
+ (:args (x :scs (mask-reg)))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (y :scs (descriptor-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:note "mask to pointer coercion")
+ (:generator 10
+ (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))))
+
+(define-vop (move-from-mask-to-unsigned)
+ (:args (x :scs (mask-reg)))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (y :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:note "mask to unsigned move")
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-vop (move-from-unsigned-to-mask)
+ (:args (x :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:results (y :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:note "unsigned to mask move")
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-vop (move-from-mask-to-signed)
+ (:args (x :scs (mask-reg)))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (y :scs (signed-reg)))
+ (:result-types signed-num)
+ (:note "mask to signed move")
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-vop (move-from-signed-to-mask)
+ (:args (x :scs (signed-reg)))
+ (:arg-types signed-num)
+ (:results (y :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:note "signed to mask move")
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-vop (move-from-mask-to-any)
+ (:args (x :scs (mask-reg)))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (y :scs (any-reg)))
+ (:result-types *)
+ (:note "mask to any move")
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-vop (move-from-any-to-mask)
+ (:args (x :scs (any-reg)))
+ (:arg-types *)
+ (:results (y :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:note "any to mask move")
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-move-vop move-from-mask-to-any :move (mask-reg) (any-reg))
+(define-move-vop move-from-any-to-mask :move (any-reg) (mask-reg))
+(define-move-vop move-from-mask-to-signed :move (mask-reg) (signed-reg))
+(define-move-vop move-from-signed-to-mask :move (signed-reg) (mask-reg))
+(define-move-vop move-from-mask-to-unsigned :move (mask-reg) (unsigned-reg))
+(define-move-vop move-from-unsigned-to-mask :move (unsigned-reg) (mask-reg))
+(define-move-vop move-to-mask :move (descriptor-reg) (mask-reg))
+(define-move-vop move-from-mask :move (mask-reg) (descriptor-reg))
+(define-move-vop mask-move :move (mask-reg) (mask-reg))
+(define-move-vop move-mask-arg :move-arg (mask-reg) (mask-reg))
+(define-move-vop move-arg :move-arg (mask-reg) (descriptor-reg))
+
+(define-vop (%make-simd-pack-512-mask)
+ (:translate sb-ext:%make-simd-pack-512-mask)
+ (:policy :fast-safe)
+ (:args (val :scs (unsigned-reg) :target dst))
+ (:arg-types unsigned-num)
+ (:results (dst :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:generator 1
+ (inst kmovq dst val)))
+
+(define-vop (%simd-pack-512-mask-value)
+ (:translate sb-kernel:%simd-pack-512-mask-value)
+ (:policy :fast-safe)
+ (:args (val :scs (descriptor-reg)))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (dst :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:note "extract simd-pack-512 mask")
+ (:generator 3
+ (loadw dst val simd-pack-512-mask-value-slot other-pointer-lowtag)))
+
+;; simd-pack-512 related
(define-move-fun (load-int-avx512-immediate 1) (vop x y)
((fp-immediate) (int-avx512-reg))
@@ -69,7 +226,7 @@
;; in 512 it works on zmm regs; we good
(inst vxorps y y y))
((= p0 p1 p2 p3 p4 p5 p6 p7 (ldb (byte 64 0) -1))
- (inst vpcmpeqd 0 y y)) ;; fixme512 ???
+ (inst vpcmpeqd y y y))
(t
(inst vmovdqu64 y (register-inline-constant x))))))
@@ -111,7 +268,6 @@
(:results (y :scs (descriptor-reg)))
(:arg-types ,type)
(:note "AVX512 to pointer coercion")
- ;; fixme512 below is definitely wrong for avx512
(:generator 13
(alloc-other simd-pack-512-widetag simd-pack-512-size y)
(storew (fixnumize ,tag)
@@ -120,7 +276,7 @@
y simd-pack-512-p0-slot other-pointer-lowtag)))
(if (float-avx512-p x)
(inst vmovups ea x)
- (inst vmovdqu ea x)))))
+ (inst vmovdqu64 ea x)))))
(define-move-vop ,name :move
,scs (descriptor-reg))))))
;; see +simd-pack-element-types+
diff --git a/src/compiler/x86-64/target-avx2-insts.lisp b/src/compiler/x86-64/target-avx2-insts.lisp
index 79f78fffb..2da6c31df 100644
--- a/src/compiler/x86-64/target-avx2-insts.lisp
+++ b/src/compiler/x86-64/target-avx2-insts.lisp
@@ -39,6 +39,11 @@
(when stream
(write-string name stream))))
+(defun print-kreg/mem (value stream dstate)
+ (if (machine-ea-p value)
+ (print-mem-ref :ref value :qword stream dstate)
+ (print-kreg value stream dstate)))
+
(defun print-ymmreg/mem (value stream dstate)
(if (machine-ea-p value)
(print-mem-ref :ref value nil stream dstate)
@@ -80,12 +85,9 @@
(print-xmmreg/mem-with-width
value (inst-operand-size-default-qword dstate) t stream dstate))
-(defconstant-eqx +opmask-reg-names+
- #("K0" "K1" "K2" "K3" "K4" "K5" "K6" "K7")
- #'equalp)
-
-(defun print-opmask-reg (value stream dstate)
+#+sb-simd-pack-512
+(defun print-opmask-register (value stream dstate)
(declare (ignore dstate))
- (let ((name (svref +opmask-reg-names+ (logand value 7))))
+ (let ((name (svref +mask-register-names+ (logand value 7))))
(if stream
(write-string name stream))))
diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index 173465b06..2a9136e1d 100644
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -201,11 +201,28 @@
(defreg float31 31 :float)
(defregset *float-regs* float0 float1 float2 float3 float4 float5 float6 float7
float8 float9 float10 float11 float12 float13 float14 float15)
- ;; ZMM16-31 are only accessible via EVEX encoding
- (defregset *zmm-regs* float0 float1 float2 float3 float4 float5 float6 float7
- float8 float9 float10 float11 float12 float13 float14 float15
- float16 float17 float18 float19 float20 float21 float22 float23
- float24 float25 float26 float27 float28 float29 float30 float31)
+ #+sb-simd-pack-512
+ (progn
+ ;; ZMM16-31 are only accessible via EVEX encoding
+ (defregset *zmm-regs* float0 float1 float2 float3 float4 float5 float6 float7
+ float8 float9 float10 float11 float12 float13 float14 float15
+ float16 float17 float18 float19 float20 float21 float22 float23
+ float24 float25 float26 float27 float28 float29 float30 float31)
+ ;; mask registers for use with avx512
+ (defreg k0 0 :qword)
+ (defreg k1 1 :qword)
+ (defreg k2 2 :qword)
+ (defreg k3 3 :qword)
+ (defreg k4 4 :qword)
+ (defreg k5 5 :qword)
+ (defreg k6 6 :qword)
+ (defreg k7 7 :qword)
+ ;; k0 is special meaning "no masking", so we can't schedule those regs for
+ ;; normal ops. I am not sure how to best model it, this is the simplest try
+ (defregset *mask-regs* k1 k2 k3 k4 k5 k6 k7)
+ (defconstant-eqx +mask-register-names+
+ #("K0" "K1" "K2" "K3" "K4" "K5" "K6" "K7")
+ #'equalp))
;; registers used to pass arguments
;;
@@ -226,7 +243,7 @@
(define-storage-base registers :finite :size 16)
(define-storage-base float-registers :finite :size 32)
-
+(define-storage-base mask-registers :finite :size 8)
;;; Start from 2, for the old RBP (aka OCFP) and return address
(define-storage-base stack :unbounded :size 2 :size-increment 1)
(define-storage-base constant :non-packed)
@@ -276,6 +293,8 @@
(double-avx512-stack stack :element-size 8)
#+sb-simd-pack-512
(single-avx512-stack stack :element-size 8)
+ #+sb-simd-pack-512
+ (kmask-stack stack)
;;
;; things that can go in the integer registers
@@ -413,14 +432,22 @@
:constant-scs (fp-immediate)
:save-p t
:alternate-scs (single-avx512-stack))
+ #+sb-simd-pack-512
+ (mask-reg mask-registers
+ :locations #.*mask-regs*
+ :constant-scs (fp-immediate)
+ :save-p t
+ :alternate-scs (kmask-stack))
- (catch-block stack :element-size catch-block-size)
- (unwind-block stack :element-size unwind-block-size)))
+ (catch-block stack :element-size catch-block-size)
+ (unwind-block stack :element-size unwind-block-size)))
(defparameter *qword-sc-names*
'(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
signed-stack unsigned-stack sap-stack single-stack
- character-reg character-stack constant))
+ character-reg character-stack constant
+ #+sb-simd-pack-512 mask-reg
+ #+sb-simd-pack-512 kmask-stack))
;;; added by jrd. I guess the right thing to do is to treat floats
;;; as a separate size...
;;;
@@ -437,12 +464,12 @@
int-avx2-stack single-avx2-stack
double-avx2-stack))
#+sb-simd-pack-512
-(defparameter *zword-sc-names* '(#+sb-simd-pack-512 int-avx512-reg
- #+sb-simd-pack-512 single-avx512-reg
- #+sb-simd-pack-512 double-avx512-reg
- #+sb-simd-pack-512 int-avx512-stack
- #+sb-simd-pack-512 single-avx512-stack
- #+sb-simd-pack-512 double-avx512-stack))
+(defparameter *zword-sc-names* '(int-avx512-reg
+ single-avx512-reg
+ double-avx512-reg
+ int-avx512-stack
+ single-avx512-stack
+ double-avx512-stack))
) ; EVAL-WHEN
(!define-storage-classes
. #.(mapcar (lambda (class-spec)
@@ -488,8 +515,8 @@
(make-random-tn (sc-or-lose 'unsigned-reg) nil)
#'constantly-t)
(def-fpr-tns single-reg
- float0 float1 float2 float3 float4 float5 float6 float7
- float8 float9 float10 float11 float12 float13 float14 float15))
+ float0 float1 float2 float3 float4 float5 float6 float7
+ float8 float9 float10 float11 float12 float13 float14 float15))
;;; Return true if THING is a general-purpose register TN.
(defun gpr-tn-p (thing)
@@ -499,6 +526,7 @@
(defun xmm-tn-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
+
(defun zmm-tn-p (tn)
(member (tn-sc tn) (list (sc-or-lose 'single-avx512-reg)
(sc-or-lose 'double-avx512-reg)
@@ -544,7 +572,8 @@
((or float (complex float)
#+(and sb-simd-pack (not sb-xc-host)) simd-pack
#+(and sb-simd-pack-256 (not sb-xc-host)) simd-pack-256
- #+(and sb-simd-pack-512 (not sb-xc-host)) simd-pack-512)
+ #+(and sb-simd-pack-512 (not sb-xc-host)) simd-pack-512
+ #+(and sb-simd-pack-512 (not sb-xc-host)) simd-pack-512-mask)
fp-immediate-sc-number)
;; This case has to follow the numeric cases because proxy floating-point numbers
;; are host structs. Or we could implement and use something like SB-XC:TYPECASE
@@ -669,6 +698,7 @@
(stack (format nil "S~D" offset))
(constant (format nil "Const~D" offset))
(immediate-constant "Immed")
+ (mask-registers (format nil "K~D" offset))
(noise (symbol-name (sc-name sc))))))
(defconstant nargs-offset rcx-offset)
diff --git a/tests/simd-pack-512-kmasks.pure.lisp b/tests/simd-pack-512-kmasks.pure.lisp
new file mode 100644
index 000000000..f7ff2c9f9
--- /dev/null
+++ b/tests/simd-pack-512-kmasks.pure.lisp
@@ -0,0 +1,427 @@
+;;;; Potentially side-effectful tests of the AVX-512 mask register infrastructure.
+
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;; Skip the file if the feature is missing or hardware does not support AVX-512.
+#-sb-simd-pack-512 (invoke-restart 'run-tests::skip-file)
+(when (zerop (sb-alien:extern-alien "avx512_supported" int))
+ (format t "~&INFO: AVX-512 (and thus masks) not supported on this hardware")
+ (invoke-restart 'run-tests::skip-file))
+
+;; I like this first because it clobbers the terminal with some ugly printouts
+(with-test (:name :load-simd-pack-512-mask-literal)
+ (let ((file (scratch-file-name))
+ (fasl nil)
+ (var '*loaded-mask-literal*))
+ (unwind-protect
+ (progn
+ ;; Force the compiler to dump a real SIMD-PACK-512-MASK object
+ ;; as a literal constant, not compile a call to %MAKE-MASK.
+ (with-open-file (s file
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (let ((*print-readably* t)
+ (*read-eval* t))
+ (prin1
+ `(defparameter ,var
+ #.(sb-ext:%make-simd-pack-512-mask #x123456789ABCDEF0))
+ s)))
+
+ (multiple-value-bind (fasl-path warnings-p failure-p)
+ (compile-file file)
+ (declare (ignore warnings-p))
+ (assert (not failure-p))
+ (setq fasl fasl-path))
+
+ (makunbound var)
+ (load fasl)
+
+ (assert (boundp var))
+ (let ((mask (symbol-value var)))
+ (assert (sb-ext:simd-pack-512-mask-p mask))
+ (assert (= #x123456789ABCDEF0
+ (sb-kernel:%simd-pack-512-mask-value mask)))))
+ (when fasl (delete-file fasl))
+ (when file (delete-file file)))))
+
+(defun make-constant-masks ()
+ (values (sb-ext:%make-simd-pack-512-mask 0)
+ (sb-ext:%make-simd-pack-512-mask (ldb (byte 64 0) -1))
+ (sb-ext:%make-simd-pack-512-mask #x123456789ABCDEF0)))
+
+(with-test (:name :compile-simd-pack-512-mask-identity)
+ (multiple-value-bind (x y z) (make-constant-masks)
+ (declare (type sb-ext:simd-pack-512-mask x))
+ (assert (= 0 (sb-kernel:%simd-pack-512-mask-value x)))
+ (assert (= (ldb (byte 64 0) -1) (sb-kernel:%simd-pack-512-mask-value y)))
+ (assert (= #x123456789ABCDEF0 (sb-kernel:%simd-pack-512-mask-value z)))))
+
+(with-test (:name (simd-pack-512-mask print :smoke))
+ (let ((masks (multiple-value-list (make-constant-masks))))
+ (dolist (mask masks)
+ (with-output-to-string (stream)
+ (write mask :stream stream :pretty t :escape nil)))))
+
+(defvar *tmp-filename* (scratch-file-name))
+(defvar *mask*)
+
+(with-test (:name :load-simd-pack-512-mask-fasl)
+ (with-open-file (s *tmp-filename* :direction :output :if-exists :supersede :if-does-not-exist :create)
+ (print '(setq *mask* (sb-ext:%make-simd-pack-512-mask #xDEADBEEFCAFEBABE)) s))
+ (let (tmp-fasl)
+ (unwind-protect
+ (progn
+ (setq tmp-fasl (compile-file *tmp-filename*))
+ (let ((*mask* nil))
+ (load tmp-fasl)
+ (assert (sb-ext:simd-pack-512-mask-p *mask*))
+ (assert (= #xDEADBEEFCAFEBABE (sb-kernel:%simd-pack-512-mask-value *mask*)))))
+ (when tmp-fasl (delete-file tmp-fasl))
+ (delete-file *tmp-filename*))))
+
+(with-test (:name :mask-spilling)
+ (checked-compile-and-assert ()
+ `(lambda (x y)
+ (declare (type sb-ext:simd-pack-512-mask x))
+ (eval y)
+ (sb-kernel:%simd-pack-512-mask-value x))
+ (((sb-ext:%make-simd-pack-512-mask #x1337) 0) #x1337)))
+
+(with-test (:name (simd-pack-512-mask subtypep :smoke))
+ (assert-tri-eq t t (subtypep 'sb-ext:simd-pack-512-mask 'sb-ext:simd-pack-512-mask))
+ (assert-tri-eq t t (subtypep 'sb-ext:simd-pack-512-mask 't))
+ (assert-tri-eq nil t (subtypep 't 'sb-ext:simd-pack-512-mask)))
+
+(with-test (:name (simd-pack-512-mask :ctype-unparse :smoke))
+ (flet ((unparsed (s) (sb-kernel:type-specifier (sb-kernel:specifier-type s))))
+ (assert (equal (unparsed 'sb-ext:simd-pack-512-mask) 'sb-ext:simd-pack-512-mask))))
+
+(with-test (:name :simd-pack-512-mask-type-errors)
+ (locally
+ (declare (muffle-conditions warning))
+ (assert-error (sb-ext:%make-simd-pack-512-mask (ash 1 64)) type-error)
+ (assert-error (sb-ext:%make-simd-pack-512-mask -1) type-error)))
+
+(cl:in-package "SB-VM")
+
+(sb-c::defknown sb-vm::%mask-identity
+ (sb-ext:simd-pack-512-mask)
+ sb-ext:simd-pack-512-mask
+ (sb-c::flushable sb-c::movable))
+
+(sb-c::defknown sb-vm::%make-mask-from-unsigned
+ ((unsigned-byte 64))
+ sb-ext:simd-pack-512-mask
+ (sb-c::flushable sb-c::movable))
+
+(sb-c::defknown sb-vm::%mask-to-unsigned
+ (sb-ext:simd-pack-512-mask)
+ (unsigned-byte 64)
+ (sb-c::flushable sb-c::movable))
+
+(sb-c::defknown sb-vm::%mask-kandq
+ (sb-ext:simd-pack-512-mask sb-ext:simd-pack-512-mask)
+ sb-ext:simd-pack-512-mask
+ (sb-c::flushable sb-c::movable))
+
+(sb-c::defknown sb-vm::%mask-kshiftrq
+ (sb-ext:simd-pack-512-mask (integer 0 63))
+ sb-ext:simd-pack-512-mask
+ (sb-c::flushable sb-c::movable))
+
+(defun %mask-identity (x)
+ (declare (type simd-pack-512-mask x)
+ (ignore x))
+ (error "%mask-identity stub"))
+
+(defun %make-mask-from-unsigned (x)
+ (declare (type (unsigned-byte 64) x)
+ (ignore x))
+ (error "%mask-from-unsigned stub"))
+
+(defun %mask-to-unsigned (x)
+ (declare (type simd-pack-512-mask x)
+ (ignore x))
+ (error "%mask-to-unsigned stub"))
+
+(defun %mask-kandq (x y)
+ (declare (ignore x y))
+ (error "%mask-kandq stub"))
+
+(defun %mask-kshiftrq (x count)
+ (declare (ignore x count))
+ (error "%mask-kshiftrq stub"))
+
+(define-vop (%mask-identity)
+ (:translate %mask-identity)
+ (:policy :fast-safe)
+ (:args (x :scs (mask-reg)))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (y :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-vop (%make-mask-from-unsigned)
+ (:translate %make-mask-from-unsigned)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:results (y :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-vop (%mask-to-unsigned)
+ (:translate %mask-to-unsigned)
+ (:policy :fast-safe)
+ (:args (x :scs (mask-reg)))
+ (:arg-types simd-pack-512-mask-type)
+ (:results (y :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (inst kmovq y x)))
+
+(define-vop (%mask-kandq)
+ (:translate %mask-kandq)
+ (:policy :fast-safe)
+ (:args (x :scs (mask-reg))
+ (y :scs (mask-reg)))
+ (:arg-types simd-pack-512-mask-type simd-pack-512-mask-type)
+ (:results (z :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:generator 1
+ (inst kandq z x y)))
+
+(define-vop (%mask-kshiftrq)
+ (:translate %mask-kshiftrq)
+ (:policy :fast-safe)
+ (:args (x :scs (mask-reg)))
+ (:info count)
+ (:arg-types simd-pack-512-mask-type (:constant t))
+ (:results (z :scs (mask-reg)))
+ (:result-types simd-pack-512-mask-type)
+ (:generator 1
+ (inst kshiftrq z x count)))
+
+(cl:in-package :test-util)
+
+(with-test (:name :mask-raw-spilling)
+ (checked-compile-and-assert ()
+ `(lambda (x y)
+ (declare (type (unsigned-byte 64) x))
+ (let ((tmp (sb-vm::%make-mask-from-unsigned x)))
+ (eval y)
+ (sb-vm::%mask-to-unsigned tmp)))
+ ((#x1234 0) #x1234)))
+
+(with-test (:name :mask-gpr-kmask-gpr-roundtrip)
+ (checked-compile-and-assert ()
+ `(lambda (x)
+ (declare (type (unsigned-byte 64) x))
+ (sb-vm::%mask-to-unsigned (sb-vm::%make-mask-from-unsigned x)))
+ ((#xDEADBEEFCAFEBABE) #xDEADBEEFCAFEBABE)))
+
+(with-test (:name :mask-gpr-to-kmask-to-boxed)
+ (checked-compile-and-assert ()
+ `(lambda (x)
+ (declare (type (unsigned-byte 64) x))
+ (sb-kernel:%simd-pack-512-mask-value
+ (sb-vm::%make-mask-from-unsigned x)))
+ ((#x1337) #x1337)))
+
+(with-test (:name :mask-identity-kmask-kmask)
+ (checked-compile-and-assert ()
+ `(lambda (x)
+ (declare (type (unsigned-byte 64) x))
+ (sb-vm::%mask-to-unsigned
+ (sb-vm::%mask-identity
+ (sb-vm::%make-mask-from-unsigned x))))
+ ((#x1234) #x1234)))
+
+(with-test (:name :mask-constant-folding)
+ (let* ((fun (compile nil
+ '(lambda ()
+ (sb-kernel:%simd-pack-512-mask-value
+ (sb-ext:%make-simd-pack-512-mask
+ #x123456789ABCDEF0)))))
+ (text (with-output-to-string (s)
+ (disassemble fun :stream s))))
+ (assert (= (funcall fun) #x123456789ABCDEF0))
+ ;; if constant folding works, the compiled body should not need
+ ;; to allocate a mask object or move values through K registers.
+ (assert (not (search "ALLOC" text)))
+ (assert (not (search "KMOVQ" text)))))
+
+(with-test (:name :destroyed-c-registers-include-kmasks)
+ (let* ((vm (find-package "SB-VM"))
+ (fun (and vm (find-symbol "DESTROYED-C-REGISTERS" vm)))
+ (forms (and fun (funcall fun))))
+ (when (and fun forms)
+ (flet ((mask-temp-p (form)
+ (and (listp form)
+ (eq (first form) :temporary)
+ (let ((spec (second form)))
+ (and (listp spec)
+ (eq (getf (cdr spec) :sc) 'mask-reg))))))
+ (let ((mask-temps (remove-if-not #'mask-temp-p forms)))
+ (assert (= (length mask-temps) 7))
+ (assert
+ (equal
+ (sort (mapcar (lambda (form)
+ (getf (cdr (second form)) :offset))
+ mask-temps)
+ #'<)
+ '(1 2 3 4 5 6 7))))))))
+
+(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)
+ (declare (type (unsigned-byte 64) x y))
+ (sb-vm::%mask-kandq
+ (sb-vm::%make-mask-from-unsigned x)
+ (sb-vm::%make-mask-from-unsigned y)))))
+ (text (with-output-to-string (s)
+ (disassemble fun :stream s))))
+ (assert (search "KANDQ" text))
+ (assert (not (search "BYTE #XC4" text)))))
+
+(with-test (:name :kshiftrq-disassembly)
+ (let* ((fun (compile nil
+ '(lambda (x)
+ (declare (type (unsigned-byte 64) x))
+ (sb-vm::%mask-kshiftrq
+ (sb-vm::%make-mask-from-unsigned x)
+ 1))))
+ (text (with-output-to-string (s)
+ (disassemble fun :stream s))))
+ (assert (search "KSHIFTRQ" text))
+ (assert (not (search "BYTE #XC4" text)))))
+
+(with-test (:name :location-print-name)
+ (let* ((vm (find-package "SB-VM"))
+ (c (find-package "SB-C"))
+ (location-print-name (and vm (find-symbol "LOCATION-PRINT-NAME" vm)))
+ (mask-reg-name (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-name
+ (funcall sc-or-lose mask-reg-name)))
+ (tn (and make-random-tn sc
+ (funcall make-random-tn sc 1))))
+ (when (and location-print-name tn)
+ (let ((name (funcall location-print-name tn)))
+ (assert (stringp name))
+ (assert (string= name "K1"))))))
+
+(with-test (:name :mask-reg-sc-locations)
+ (let* ((vm (find-package "SB-VM"))
+ (c (find-package "SB-C"))
+ (mask-reg-name (and vm (find-symbol "MASK-REG" vm)))
+ (sc-or-lose (and c (find-symbol "SC-OR-LOSE" c)))
+ (sc-locations (and c (find-symbol "SC-LOCATIONS" c)))
+ (sc (and sc-or-lose mask-reg-name
+ (funcall sc-or-lose mask-reg-name)))
+ (locs (and sc-locations sc
+ (funcall sc-locations sc))))
+ (assert locs)
+ ;; #xFE = #b11111110 -> K1-K7 only, K0 excluded.
+ (assert (= locs #xFE))))
+
+(with-test (:name :simd-pack-512-mask-print-readably)
+ (let* ((value #x123456789ABCDEF0)
+ (mask (sb-ext:%make-simd-pack-512-mask value))
+ (*print-readably* t)
+ (*read-eval* t)
+ (printed (prin1-to-string mask))
+ (read-back (read-from-string printed)))
+ (assert (sb-ext:simd-pack-512-mask-p read-back))
+ (assert (= value
+ (sb-kernel:%simd-pack-512-mask-value read-back)))))
+
+(with-test (:name :mask-reg-sc-locations)
+ (let* ((vm (find-package "SB-VM"))
+ (c (find-package "SB-C"))
+ (mask-reg-name (and vm (find-symbol "MASK-REG" vm)))
+ (sc-or-lose (and c (find-symbol "SC-OR-LOSE" c)))
+ (sc-locations (and c (find-symbol "SC-LOCATIONS" c)))
+ (sc (and sc-or-lose mask-reg-name
+ (funcall sc-or-lose mask-reg-name)))
+ (locs (and sc-locations sc
+ (funcall sc-locations sc))))
+ (assert locs)
+ ;; 254 = #b11111110, i.e. K1-K7 only.
+ (assert (= locs #xFE))))
+
+;; This particular test does not test for avx512 feature per se
+;; cpu-has-zmm-registers has a low constant number, 2, so
+;; check if there is a collision, just to be on the safe side.
+;; It checks acutally all cpu feature bits, but I guess it is OK.
+(with-test (:name :cpu-feature-bit-no-collisions)
+ (let* ((vm (find-package "SB-VM"))
+ (seen (make-hash-table))
+ (collisions nil))
+ (do-symbols (sym vm)
+ (when (and (boundp sym)
+ (let ((name (symbol-name sym)))
+ (and (<= 8 (length name))
+ (string= name "CPU-HAS-" :end1 8 :end2 8))))
+ (let* ((sym (find-symbol (symbol-name sym) vm))
+ (value (symbol-value sym)))
+ (when (gethash value seen)
+ (push (list sym (gethash value seen) value) collisions))
+ (setf (gethash value seen) sym))))
+ (assert (null collisions) nil
+ "CPU feature bits collide: ~S" collisions)))
+
+;; assembly printer
+(with-test (:name :kmovq-disassembly)
+ (let* ((fun (compile nil
+ '(lambda (x)
+ (declare (type (unsigned-byte 64) x))
+ (sb-vm::%mask-to-unsigned
+ (sb-vm::%mask-identity
+ (sb-vm::%make-mask-from-unsigned x))))))
+ (text (with-output-to-string (s)
+ (disassemble fun :stream s))))
+ (assert (search "KMOVQ" text))
+ ;; Ensure we are not seeing raw VEX bytes instead of decoded KMOVQ.
+ (assert (not (search "BYTE #XC4" text)))))
+
+(with-test (:name :kmovq-memory-disassembly)
+ (let* ((fun (compile nil
+ '(lambda (x y)
+ (declare (type (unsigned-byte 64) x))
+ (let ((tmp (sb-vm::%make-mask-from-unsigned x)))
+ (eval y)
+ (sb-vm::%mask-to-unsigned tmp)))))
+ (text (with-output-to-string (s)
+ (disassemble fun :stream s))))
+ (assert (search "KMOVQ" text))
+ (assert (search "[RBP" text)) ; memory store/load somewhere
+ (assert (not (search "BYTE #XC4" text)))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL