Basic support for AVX512 mask registers
arthur miller <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.devel |
|---|---|
| Message-ID | <VI1PR09MB24960D980845B79915DE976B96A42@VI1PR09MB2496.eurprd09.prod.outlook.com> |
Hi, I have been trying to add support for avx512 mask registers. The worktree: https://github.com/amno1/sbcl/tree/avx512-mask-regs I have also attached a patch if you prefer it over GH. A short glance over what is in the patch: * simd-pack-512-mask as intrinsic type (widetag) * associated book-keeping in VM and compiler for it * VM support for mask registers (mask-reg SC, SB, defregs, ...) * VOPs to compiler backend for construction, extraction * VOPs for movement: kregs<->kregs, kregs<->gpr and kregs<->mem * support for assembler in insts, avx2-insts and avx512-insts * fix evex emitter regarding mask registers * add evex printer support 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 support for mask regs Instructions regarding mask regs can be emitted and printed but no VOP ntrinsics other than to create, read and move masks are added (job for sb-simd). There is still more work on evex encodings left: r', v', b' for zmm16-zmm31 and on decoding. I'll work on it more, but for now, I think this is the minimum needed. I am sure there are bugs, you don't have to chase them, but appreciate if you do. However, I hope you can glance over it, see if it is OK. I hope I haven't messed up too much 🙂. CI on GH is green for all builds: https://github.com/amno1/sbcl/actions, but please check it first. _______________________________________________ Sbcl-devel mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/sbcl-devel
avx512-mask-regs.patch
(text/x-patch, 74.9 KB)
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..7e6aff33a 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 simd-pack-512 #+sb-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..ddf472ede 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -991,6 +991,7 @@ We could try a few things to mitigate this:
#+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
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..345e8aa84 100644
--- a/src/code/stubs.lisp
+++ b/src/code/stubs.lisp
@@ -182,6 +182,44 @@
(def %numerator)
(def %denominator))
+#+sb-simd-pack-512
+(progn
+ ;; (defun %make-simd-pack-512-mask (mask)
+ ;; (error "stub %make-simd-pack-512-mask called on ~S" mask))
+ ;; (defun %simd-pack-512-mask-value (mask)
+ ;; (error "stub %simd-pack-512-mask-value called on ~S" mask))
+
+ (defun sb-ext:%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 sb-kernel:%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..c986b883d 100644
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -196,37 +196,39 @@
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))
+ :type (simd-pack-512 single-float))
(!def-primitive-type simd-pack-512-double (double-avx512-reg descriptor-reg)
- :type (simd-pack-512 double-float))
+ :type (simd-pack-512 double-float))
(!def-primitive-type simd-pack-512-ub8 (int-avx512-reg descriptor-reg)
- :type (simd-pack-512 (unsigned-byte 8)))
+ :type (simd-pack-512 (unsigned-byte 8)))
(!def-primitive-type simd-pack-512-ub16 (int-avx512-reg descriptor-reg)
- :type (simd-pack-512 (unsigned-byte 16)))
+ :type (simd-pack-512 (unsigned-byte 16)))
(!def-primitive-type simd-pack-512-ub32 (int-avx512-reg descriptor-reg)
- :type (simd-pack-512 (unsigned-byte 32)))
+ :type (simd-pack-512 (unsigned-byte 32)))
(!def-primitive-type simd-pack-512-ub64 (int-avx512-reg descriptor-reg)
- :type (simd-pack-512 (unsigned-byte 64)))
+ :type (simd-pack-512 (unsigned-byte 64)))
(!def-primitive-type simd-pack-512-sb8 (int-avx512-reg descriptor-reg)
- :type (simd-pack-512 (signed-byte 8)))
+ :type (simd-pack-512 (signed-byte 8)))
(!def-primitive-type simd-pack-512-sb16 (int-avx512-reg descriptor-reg)
- :type (simd-pack-512 (signed-byte 16)))
+ :type (simd-pack-512 (signed-byte 16)))
(!def-primitive-type simd-pack-512-sb32 (int-avx512-reg descriptor-reg)
- :type (simd-pack-512 (signed-byte 32)))
+ :type (simd-pack-512 (signed-byte 32)))
(!def-primitive-type simd-pack-512-sb64 (int-avx512-reg descriptor-reg)
- :type (simd-pack-512 (signed-byte 64)))
+ :type (simd-pack-512 (signed-byte 64)))
(!def-primitive-type-alias simd-pack-512
'(:or simd-pack-512-single
- simd-pack-512-double
- simd-pack-512-ub8
- simd-pack-512-ub16
- simd-pack-512-ub32
- simd-pack-512-ub64
- simd-pack-512-sb8
- simd-pack-512-sb16
- simd-pack-512-sb32
- simd-pack-512-sb64)))
+ simd-pack-512-double
+ simd-pack-512-ub8
+ simd-pack-512-ub16
+ simd-pack-512-ub32
+ simd-pack-512-ub64
+ simd-pack-512-sb8
+ simd-pack-512-sb16
+ simd-pack-512-sb32
+ simd-pack-512-sb64)))
;;; primitive other-pointer array types
(/show0 "primtype.lisp 96")
@@ -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..c55036a24 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,8 +507,12 @@
(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)
+ double-float double-float double-float double-float)
(simd-pack-512 double-float)
(flushable movable foldable))
(defknown %make-simd-pack-512-single (single-float single-float single-float single-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..8d702bf00 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,19 @@
(defun xmm-tn-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
+;; (defun xmm-tn-p (thing)
+;; (and (tn-p thing)
+;; (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)
+;; (member (sc-name (tn-sc thing))
+;; '(single-reg
+;; double-reg
+;; complex-single-reg
+;; complex-double-reg
+;; #+sb-simd-pack sse-reg
+;; #+sb-simd-pack int-sse-reg
+;; #+sb-simd-pack single-sse-reg
+;; #+sb-simd-pack double-sse-reg)
+;; :test #'eq)))
(defun zmm-tn-p (tn)
(member (tn-sc tn) (list (sc-or-lose 'single-avx512-reg)
(sc-or-lose 'double-avx512-reg)
@@ -544,7 +584,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 +710,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)))))