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

Basic support for avx512

Browse source
This commit is contained in:
arthur 2026-06-29 17:44:07 +02:00 committed by Stas Boukarev
parent db2b204bb1
commit bdc8c073cf
43 changed files with 1747 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
build-all-cores.sh
View file

@ -49,14 +49,14 @@
("x86-ascii" :little-endian :largefile (not :sb-unicode)) ("x86-ascii" :little-endian :largefile (not :sb-unicode))
("x86-thread" :little-endian :largefile :sb-thread) ("x86-thread" :little-endian :largefile :sb-thread)
("x86-linux" :little-endian :largefile :sb-thread :linux :unix :elf :sb-thread)) ("x86-linux" :little-endian :largefile :sb-thread :linux :unix :elf :sb-thread))
("x86-64" ("x86-64" :little-endian :avx2 :gencgc :sb-simd-pack :sb-simd-pack-256) ("x86-64" ("x86-64" :little-endian :avx2 :gencgc :sb-simd-pack :sb-simd-pack-256 :avx512 :sb-simd-pack-512)
("x86-64-linux" :linux :unix :elf :little-endian :avx2 :gencgc :sb-simd-pack :sb-simd-pack-256 ("x86-64-linux" :linux :unix :elf :little-endian :avx2 :gencgc :sb-simd-pack :sb-simd-pack-256
(not :sb-eval) :sb-fasteval) :avx512 :sb-simd-pack-512 (not :sb-eval) :sb-fasteval)
("x86-64-darwin" :darwin :bsd :unix :mach-o :little-endian :avx2 :gencgc ("x86-64-darwin" :darwin :bsd :unix :mach-o :little-endian :avx2 :gencgc
:sb-simd-pack :sb-simd-pack-256) :sb-simd-pack :sb-simd-pack-256)
("x86-64-imm" :little-endian :avx2 :gencgc :sb-simd-pack :sb-simd-pack-256 ("x86-64-imm" :little-endian :avx2 :gencgc :sb-simd-pack :sb-simd-pack-256
:immobile-space (not :sb-unicode)) :avx512 :sb-simd-pack-512 :immobile-space (not :sb-unicode))
("x86-64-permgen" :little-endian :avx2 :gencgc :sb-simd-pack :sb-simd-pack-256 ("x86-64-permgen" :little-endian :avx2 :gencgc :sb-simd-pack :sb-simd-pack-256 :avx512 :sb-simd-pack-512
:permgen)))) :permgen))))
(setq sb-ext:*evaluator-mode* :compile) (setq sb-ext:*evaluator-mode* :compile)

8
crossbuild-runner/Makefile
View file

@ -90,12 +90,12 @@ obj/xbuild/x86-linux.core: obj/xbuild/x86-linux/xc.core
$(SBCL) $(ARGS) x86-linux < $(SCRIPT2) $(SBCL) $(ARGS) x86-linux < $(SCRIPT2)
obj/xbuild/x86-64/xc.core: $(DEPS1) obj/xbuild/x86-64/xc.core: $(DEPS1)
$(SBCL) $(ARGS) x86-64 x86-64 "(:WIN32 :SB-THREAD :SB-SAFEPOINT :LITTLE-ENDIAN :AVX2 :GENCGC :SB-SIMD-PACK :SB-SIMD-PACK-256)" < $(SCRIPT1) $(SBCL) $(ARGS) x86-64 x86-64 "(:WIN32 :SB-THREAD :SB-SAFEPOINT :LITTLE-ENDIAN :AVX2 :AVX512 :GENCGC :SB-SIMD-PACK :SB-SIMD-PACK-256 :SB-SIMD-PACK-512)" < $(SCRIPT1)
obj/xbuild/x86-64.core: obj/xbuild/x86-64/xc.core obj/xbuild/x86-64.core: obj/xbuild/x86-64/xc.core
$(SBCL) $(ARGS) x86-64 < $(SCRIPT2) $(SBCL) $(ARGS) x86-64 < $(SCRIPT2)
obj/xbuild/x86-64-linux/xc.core: $(DEPS1) obj/xbuild/x86-64-linux/xc.core: $(DEPS1)
$(SBCL) $(ARGS) x86-64-linux x86-64 "(:LINUX :UNIX :ELF :LITTLE-ENDIAN :AVX2 :GENCGC :SB-SIMD-PACK :SB-SIMD-PACK-256 (NOT :SB-EVAL) :SB-FASTEVAL :OS-PROVIDES-CLOCK-GETTIME)" < $(SCRIPT1) $(SBCL) $(ARGS) x86-64-linux x86-64 "(:LINUX :UNIX :ELF :LITTLE-ENDIAN :AVX2 :AVX512 :GENCGC :SB-SIMD-PACK :SB-SIMD-PACK-256 :SB-SIMD-PACK-512 (NOT :SB-EVAL) :SB-FASTEVAL :OS-PROVIDES-CLOCK-GETTIME)" < $(SCRIPT1)
obj/xbuild/x86-64-linux.core: obj/xbuild/x86-64-linux/xc.core obj/xbuild/x86-64-linux.core: obj/xbuild/x86-64-linux/xc.core
$(SBCL) $(ARGS) x86-64-linux < $(SCRIPT2) $(SBCL) $(ARGS) x86-64-linux < $(SCRIPT2)
@ -105,11 +105,11 @@ obj/xbuild/x86-64-darwin.core: obj/xbuild/x86-64-darwin/xc.core
$(SBCL) $(ARGS) x86-64-darwin < $(SCRIPT2) $(SBCL) $(ARGS) x86-64-darwin < $(SCRIPT2)
obj/xbuild/x86-64-imm/xc.core: $(DEPS1) obj/xbuild/x86-64-imm/xc.core: $(DEPS1)
$(SBCL) $(ARGS) x86-64-imm x86-64 "(:WIN32 :SB-THREAD :SB-SAFEPOINT :LITTLE-ENDIAN :AVX2 :GENCGC :SB-SIMD-PACK :SB-SIMD-PACK-256 :IMMOBILE-SPACE (NOT :SB-UNICODE))" < $(SCRIPT1) $(SBCL) $(ARGS) x86-64-imm x86-64 "(:WIN32 :SB-THREAD :SB-SAFEPOINT :LITTLE-ENDIAN :AVX2 :AVX512 :GENCGC :SB-SIMD-PACK :SB-SIMD-PACK-256 :SB-SIMD-PACK-512 :IMMOBILE-SPACE (NOT :SB-UNICODE))" < $(SCRIPT1)
obj/xbuild/x86-64-imm.core: obj/xbuild/x86-64-imm/xc.core obj/xbuild/x86-64-imm.core: obj/xbuild/x86-64-imm/xc.core
$(SBCL) $(ARGS) x86-64-imm < $(SCRIPT2) $(SBCL) $(ARGS) x86-64-imm < $(SCRIPT2)
obj/xbuild/x86-64-permgen/xc.core: $(DEPS1) obj/xbuild/x86-64-permgen/xc.core: $(DEPS1)
$(SBCL) $(ARGS) x86-64-permgen x86-64 "(:WIN32 :SB-THREAD :SB-SAFEPOINT :LITTLE-ENDIAN :AVX2 :GENCGC :SB-SIMD-PACK :SB-SIMD-PACK-256 :PERMGEN)" < $(SCRIPT1) $(SBCL) $(ARGS) x86-64-permgen x86-64 "(:WIN32 :SB-THREAD :SB-SAFEPOINT :LITTLE-ENDIAN :AVX2 :AVX512 :GENCGC :SB-SIMD-PACK :SB-SIMD-PACK-256 :SB-SIMD-PACK-512 :PERMGEN)" < $(SCRIPT1)
obj/xbuild/x86-64-permgen.core: obj/xbuild/x86-64-permgen/xc.core obj/xbuild/x86-64-permgen.core: obj/xbuild/x86-64-permgen/xc.core
$(SBCL) $(ARGS) x86-64-permgen < $(SCRIPT2) $(SBCL) $(ARGS) x86-64-permgen < $(SCRIPT2)

2
make-config.sh
View file

@ -735,7 +735,7 @@ case "$sbcl_arch" in
fi fi
;; ;;
x86-64) x86-64)
printf ' :sb-simd-pack :sb-simd-pack-256 :avx2' >> $ltf # not mandatory printf ' :sb-simd-pack :sb-simd-pack-256 :avx2 :sb-simd-pack-512 :avx512' >> $ltf # not mandatory
if $android; then if $android; then
$GNUMAKE -C tools-for-build avx2 2> /dev/null $GNUMAKE -C tools-for-build avx2 2> /dev/null

8
src/code/class.lisp
View file

@ -1101,6 +1101,14 @@ between the ~A definition and the ~A definition"
;; KLUDGE: doesn't work without AVX2 support from the CPU ;; KLUDGE: doesn't work without AVX2 support from the CPU
;; (%make-simd-pack-256-ub64 42 42 42 42) ;; (%make-simd-pack-256-ub64 42 42 42 42)
sb-pcl:+slot-unbound+) sb-pcl:+slot-unbound+)
#+sb-simd-pack-512
(simd-pack-512
:translation simd-pack-512
:codes (,sb-vm:simd-pack-512-widetag)
:prototype-form
;; 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+)
(real :translation real :inherits (number) :prototype-form 0) (real :translation real :inherits (number) :prototype-form 0)
(float :translation float :inherits (real number) :prototype-form 0f0) (float :translation float :inherits (real number) :prototype-form 0f0)
(single-float (single-float

3
src/code/cross-type.lisp
View file

@ -135,7 +135,8 @@
;; But the empty (OR) should match nothing, so, what's up with that? ;; But the empty (OR) should match nothing, so, what's up with that?
;; Maybe we can define host-side types named simd-pack-blah deftyped to NIL? ;; Maybe we can define host-side types named simd-pack-blah deftyped to NIL?
((or #+sb-simd-pack simd-pack-type ((or #+sb-simd-pack simd-pack-type
#+sb-simd-pack-256 simd-pack-256-type) #+sb-simd-pack-256 simd-pack-256-type
#+sb-simd-pack-512 simd-pack-512-type)
(values nil t)) (values nil t))
(character-set-type (character-set-type
;; provided that CHAR-CODE doesn't fail, the answer is certain ;; provided that CHAR-CODE doesn't fail, the answer is certain

85
src/code/debug-int.lisp
View file

@ -2529,6 +2529,59 @@
(sap-ref-double nfp (number-stack-offset 8)) (sap-ref-double nfp (number-stack-offset 8))
(sap-ref-double nfp (number-stack-offset 16)) (sap-ref-double nfp (number-stack-offset 16))
(sap-ref-double nfp (number-stack-offset 24))))) (sap-ref-double nfp (number-stack-offset 24)))))
#+sb-simd-pack-512
((#.sb-vm::zmm-reg-sc-number #.sb-vm::int-avx512-reg-sc-number)
(escaped-float-value simd-pack-512-int))
#+sb-simd-pack-512
((#.sb-vm::single-avx512-reg-sc-number)
(escaped-float-value simd-pack-512-single))
#+sb-simd-pack-512
((#.sb-vm::double-avx512-reg-sc-number)
(escaped-float-value simd-pack-512-double))
#+sb-simd-pack-512
((#.sb-vm::int-avx512-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-512-ub64
(sap-ref-64 nfp (number-stack-offset 0))
(sap-ref-64 nfp (number-stack-offset 8))
(sap-ref-64 nfp (number-stack-offset 16))
(sap-ref-64 nfp (number-stack-offset 24))
(sap-ref-64 nfp (number-stack-offset 32))
(sap-ref-64 nfp (number-stack-offset 40))
(sap-ref-64 nfp (number-stack-offset 48))
(sap-ref-64 nfp (number-stack-offset 56)))))
#+sb-simd-pack-512
((#.sb-vm::single-avx512-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-512-single
(sap-ref-single nfp (number-stack-offset 0))
(sap-ref-single nfp (number-stack-offset 4))
(sap-ref-single nfp (number-stack-offset 8))
(sap-ref-single nfp (number-stack-offset 12))
(sap-ref-single nfp (number-stack-offset 16))
(sap-ref-single nfp (number-stack-offset 20))
(sap-ref-single nfp (number-stack-offset 24))
(sap-ref-single nfp (number-stack-offset 28))
(sap-ref-single nfp (number-stack-offset 32))
(sap-ref-single nfp (number-stack-offset 36))
(sap-ref-single nfp (number-stack-offset 40))
(sap-ref-single nfp (number-stack-offset 44))
(sap-ref-single nfp (number-stack-offset 48))
(sap-ref-single nfp (number-stack-offset 52))
(sap-ref-single nfp (number-stack-offset 54))
(sap-ref-single nfp (number-stack-offset 60)))))
#+sb-simd-pack-512
((#.sb-vm::double-avx512-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-512-double
(sap-ref-double nfp (number-stack-offset 0))
(sap-ref-double nfp (number-stack-offset 8))
(sap-ref-double nfp (number-stack-offset 16))
(sap-ref-double nfp (number-stack-offset 24))
(sap-ref-double nfp (number-stack-offset 32))
(sap-ref-double nfp (number-stack-offset 40))
(sap-ref-double nfp (number-stack-offset 48))
(sap-ref-double nfp (number-stack-offset 56)))))
(#.single-reg-sc-number (#.single-reg-sc-number
(escaped-float-value single-float)) (escaped-float-value single-float))
(#.double-reg-sc-number (#.double-reg-sc-number
@ -2765,6 +2818,38 @@
(sap-ref-double nfp (number-stack-offset 8)) b (sap-ref-double nfp (number-stack-offset 8)) b
(sap-ref-double nfp (number-stack-offset 16)) c (sap-ref-double nfp (number-stack-offset 16)) c
(sap-ref-double nfp (number-stack-offset 24)) d)))) (sap-ref-double nfp (number-stack-offset 24)) d))))
#+sb-simd-pack-512
((#.sb-vm::single-avx512-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-512-single
(sap-ref-single nfp (number-stack-offset 0))
(sap-ref-single nfp (number-stack-offset 4))
(sap-ref-single nfp (number-stack-offset 8))
(sap-ref-single nfp (number-stack-offset 12))
(sap-ref-single nfp (number-stack-offset 16))
(sap-ref-single nfp (number-stack-offset 20))
(sap-ref-single nfp (number-stack-offset 24))
(sap-ref-single nfp (number-stack-offset 28))
(sap-ref-single nfp (number-stack-offset 32))
(sap-ref-single nfp (number-stack-offset 36))
(sap-ref-single nfp (number-stack-offset 40))
(sap-ref-single nfp (number-stack-offset 44))
(sap-ref-single nfp (number-stack-offset 48))
(sap-ref-single nfp (number-stack-offset 52))
(sap-ref-single nfp (number-stack-offset 54))
(sap-ref-single nfp (number-stack-offset 60)))))
#+sb-simd-pack-512
((#.sb-vm::double-avx512-stack-sc-number)
(with-nfp (nfp)
(%make-simd-pack-512-double
(sap-ref-double nfp (number-stack-offset 0))
(sap-ref-double nfp (number-stack-offset 8))
(sap-ref-double nfp (number-stack-offset 16))
(sap-ref-double nfp (number-stack-offset 24))
(sap-ref-double nfp (number-stack-offset 32))
(sap-ref-double nfp (number-stack-offset 40))
(sap-ref-double nfp (number-stack-offset 48))
(sap-ref-double nfp (number-stack-offset 56)))))
(#.single-reg-sc-number (#.single-reg-sc-number
#-(or x86 x86-64) ;; don't have escaped floats. #-(or x86 x86-64) ;; don't have escaped floats.
(set-escaped-float-value single-float value)) (set-escaped-float-value single-float value))

6
src/code/early-classoid.lisp
View file

@ -668,6 +668,8 @@
(simd-pack-type (!alloc-simd-pack-type bits (simd-pack-type-tag-mask x))) (simd-pack-type (!alloc-simd-pack-type bits (simd-pack-type-tag-mask x)))
#+sb-simd-pack-256 #+sb-simd-pack-256
(simd-pack-256-type (!alloc-simd-pack-256-type bits (simd-pack-256-type-tag-mask x))) (simd-pack-256-type (!alloc-simd-pack-256-type bits (simd-pack-256-type-tag-mask x)))
#+sb-simd-pack-512
(simd-pack-512-type (!alloc-simd-pack-512-type bits (simd-pack-512-type-tag-mask x)))
(alien-type-type (!alloc-alien-type-type bits (alien-type-type-alien-type x))))))) (alien-type-type (!alloc-alien-type-type bits (alien-type-type-alien-type x)))))))
) ; end MACROLET ) ; end MACROLET
@ -707,7 +709,9 @@
(get-lisp-obj-address instance))))))) (get-lisp-obj-address instance)))))))
(etypecase instance (etypecase instance
((or numeric-union-type member-type character-set-type ; nothing extra to do ((or numeric-union-type member-type character-set-type ; nothing extra to do
#+sb-simd-pack simd-pack-type #+sb-simd-pack-256 simd-pack-256-type #+sb-simd-pack simd-pack-type
#+sb-simd-pack-256 simd-pack-256-type
#+sb-simd-pack-512 simd-pack-512-type
hairy-type)) hairy-type))
(args-type (args-type
(ensure-interned-list (args-type-required instance) *ctype-list-hashset*) (ensure-interned-list (args-type-required instance) *ctype-list-hashset*)

11
src/code/load.lisp
View file

@ -894,6 +894,17 @@
(fast-read-u-integer 8) (fast-read-u-integer 8)
(fast-read-u-integer 8) (fast-read-u-integer 8)
(fast-read-u-integer 8))) (fast-read-u-integer 8)))
#+sb-simd-pack-512
((logbitp 7 tag)
(%make-simd-pack-512 (logand tag #b00111111)
(fast-read-u-integer 8)
(fast-read-u-integer 8)
(fast-read-u-integer 8)
(fast-read-u-integer 8)
(fast-read-u-integer 8)
(fast-read-u-integer 8)
(fast-read-u-integer 8)
(fast-read-u-integer 8)))
(t (t
(%make-simd-pack tag (%make-simd-pack tag
(fast-read-u-integer 8) (fast-read-u-integer 8)

3
src/code/pred.lisp
View file

@ -118,6 +118,7 @@
(def-type-predicate-wrapper single-float-p) (def-type-predicate-wrapper single-float-p)
#+sb-simd-pack (def-type-predicate-wrapper simd-pack-p) #+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-256 (def-type-predicate-wrapper simd-pack-256-p)
#+sb-simd-pack-512 (def-type-predicate-wrapper simd-pack-512-p)
(def-type-predicate-wrapper %instancep) (def-type-predicate-wrapper %instancep)
(def-type-predicate-wrapper funcallable-instance-p) (def-type-predicate-wrapper funcallable-instance-p)
(def-type-predicate-wrapper symbolp) (def-type-predicate-wrapper symbolp)
@ -211,7 +212,7 @@
:complexp (if (typep object 'simple-array) nil :maybe) :complexp (if (typep object 'simple-array) nil :maybe)
:element-type etype :element-type etype
:specialized-element-type etype)))) :specialized-element-type etype))))
((or complex #+sb-simd-pack simd-pack #+sb-simd-pack-256 simd-pack-256) ((or complex #+sb-simd-pack simd-pack #+sb-simd-pack-256 simd-pack-256 #+sb-simd-pack-512 simd-pack-512)
(type-specifier (ctype-of object))) (type-specifier (ctype-of object)))
(simple-fun 'compiled-function) (simple-fun 'compiled-function)
(t (t

50
src/code/print.lisp
View file

@ -2067,6 +2067,56 @@ variable: an unreadable object representing the error is printed instead.")
((simd-pack-256 (signed-byte 64)) ((simd-pack-256 (signed-byte 64))
(multiple-value-call #'format stream "~S~@{ ~20@D~}" 'simd-pack-256 (multiple-value-call #'format stream "~S~@{ ~20@D~}" 'simd-pack-256
(%simd-pack-256-sb64s pack)))))))) (%simd-pack-256-sb64s pack))))))))
#+sb-simd-pack-512
(defmethod print-object ((pack simd-pack-512) stream)
(cond ((and *print-readably* *read-eval*)
(format stream "#.(~S #b~3,'0B #x~16,'0D #x~16,'0D #x~16,'0D #x~16,'0D #x~16,'0D #x~16,'0D #x~16,'0D #x~16,'0D)"
'%make-simd-pack-512
(%simd-pack-512-tag pack)
(%simd-pack-512-0 pack)
(%simd-pack-512-1 pack)
(%simd-pack-512-2 pack)
(%simd-pack-512-3 pack)
(%simd-pack-512-4 pack)
(%simd-pack-512-5 pack)
(%simd-pack-512-6 pack)
(%simd-pack-512-7 pack)))
(*print-readably*
(print-not-readable-error pack stream))
(t
(print-unreadable-object (pack stream)
(etypecase pack
((simd-pack-512 double-float)
(multiple-value-call #'format stream "~S~@{ ~,13E~}" 'simd-pack-512
(%simd-pack-512-doubles pack)))
((simd-pack-512 single-float)
(multiple-value-call #'format stream "~S~@{ ~,7E~}" 'simd-pack-512
(%simd-pack-512-singles pack)))
((simd-pack-512 (unsigned-byte 8))
(multiple-value-call #'format stream "~S~@{ ~3D~}" 'simd-pack-512
(%simd-pack-512-ub8s pack)))
((simd-pack-512 (unsigned-byte 16))
(multiple-value-call #'format stream "~S~@{ ~5D~}" 'simd-pack-512
(%simd-pack-512-ub16s pack)))
((simd-pack-512 (unsigned-byte 32))
(multiple-value-call #'format stream "~S~@{ ~10D~}" 'simd-pack-512
(%simd-pack-512-ub32s pack)))
((simd-pack-512 (unsigned-byte 64))
(multiple-value-call #'format stream "~S~@{ ~20D~}" 'simd-pack-512
(%simd-pack-512-ub64s pack)))
((simd-pack-512 (signed-byte 8))
(multiple-value-call #'format stream "~S~@{ ~4@D~}" 'simd-pack-512
(%simd-pack-512-sb8s pack)))
((simd-pack-512 (signed-byte 16))
(multiple-value-call #'format stream "~S~@{ ~6@D~}" 'simd-pack-512
(%simd-pack-512-sb16s pack)))
((simd-pack-512 (signed-byte 32))
(multiple-value-call #'format stream "~S~@{ ~11@D~}" 'simd-pack-512
(%simd-pack-512-sb32s pack)))
((simd-pack-512 (signed-byte 64))
(multiple-value-call #'format stream "~S~@{ ~20@D~}" 'simd-pack-512
(%simd-pack-512-sb64s pack))))))))
;;;; functions ;;;; functions

1
src/code/room.lisp
View file

@ -990,6 +990,7 @@ We could try a few things to mitigate this:
,.(make-case '(or float (complex float) bignum ,.(make-case '(or float (complex float) bignum
#+sb-simd-pack simd-pack #+sb-simd-pack simd-pack
#+sb-simd-pack-256 simd-pack-256 #+sb-simd-pack-256 simd-pack-256
#+sb-simd-pack-512 simd-pack-512
system-area-pointer)) ; nothing to do system-area-pointer)) ; nothing to do
,.(make-case 'weak-pointer ,.(make-case 'weak-pointer
#+weak-vector-readbarrier #+weak-vector-readbarrier

20
src/code/stubs.lisp
View file

@ -158,6 +158,12 @@
(%make-simd-pack-256-double (a b c d)) (%make-simd-pack-256-double (a b c d))
(%make-simd-pack-256-ub64 (a b c d)) (%make-simd-pack-256-ub64 (a b c d))
(%simd-pack-256-tag)) (%simd-pack-256-tag))
#+sb-simd-pack-512
(def* (%make-simd-pack-512 (tag p0 p1 p2 p3 p4 p5 p6 p7))
(%make-simd-pack-512-single (a b c d e f g h i j k l m n p q))
(%make-simd-pack-512-double (a b c d e f g h))
(%make-simd-pack-512-ub64 (a b c d e f g h))
(%simd-pack-512-tag))
#+(or sb-thread x86-64) (def sb-vm::current-thread-offset-sap) #+(or sb-thread x86-64) (def sb-vm::current-thread-offset-sap)
(def current-sp ()) (def current-sp ())
(def current-fp ()) (def current-fp ())
@ -203,6 +209,20 @@
(def %simd-pack-256-2) (def %simd-pack-256-2)
(def %simd-pack-256-3)) (def %simd-pack-256-3))
#+sb-simd-pack-512
(macrolet ((def (name)
`(defun ,name (pack)
(sb-vm::simd-pack-512-dispatch pack
(,name pack)))))
(def %simd-pack-512-0)
(def %simd-pack-512-1)
(def %simd-pack-512-2)
(def %simd-pack-512-3)
(def %simd-pack-512-4)
(def %simd-pack-512-5)
(def %simd-pack-512-6)
(def %simd-pack-512-7))
(defun spin-loop-hint () (defun spin-loop-hint ()
"Hints the processor that the current thread is spin-looping." "Hints the processor that the current thread is spin-looping."
(spin-loop-hint)) (spin-loop-hint))

12
src/code/type-class.lisp
View file

@ -347,6 +347,8 @@
(simd-pack simd-pack-type) (simd-pack simd-pack-type)
#+sb-simd-pack-256 #+sb-simd-pack-256
(simd-pack-256 simd-pack-256-type) (simd-pack-256 simd-pack-256-type)
#+sb-simd-pack-512
(simd-pack-512 simd-pack-512-type)
;; clearly alien-type-type is not consistent with the (FOO FOO-TYPE) theme ;; clearly alien-type-type is not consistent with the (FOO FOO-TYPE) theme
(alien alien-type-type))) (alien alien-type-type)))
(defun ctype-instance->type-class (name) (defun ctype-instance->type-class (name)
@ -748,7 +750,7 @@
,(ecase name ; Compute or propagate the flag bits ,(ecase name ; Compute or propagate the flag bits
(hairy-type ctype-contains-hairy) (hairy-type ctype-contains-hairy)
(unknown-type (logior ctype-contains-unknown ctype-contains-hairy)) (unknown-type (logior ctype-contains-unknown ctype-contains-hairy))
((simd-pack-type simd-pack-256-type alien-type-type) 0) ((simd-pack-type simd-pack-256-type simd-pack-512-type alien-type-type) 0)
(negation-type '(type-flags type)) (negation-type '(type-flags type))
(array-type '(type-flags element-type))) (array-type '(type-flags element-type)))
,@(cdr private-ctor-args)))))))) ,@(cdr private-ctor-args))))))))
@ -1274,6 +1276,14 @@
:type (and (unsigned-byte #.(length +simd-pack-element-types+)) :type (and (unsigned-byte #.(length +simd-pack-element-types+))
(not (eql 0))))) (not (eql 0)))))
#+sb-simd-pack-512
(def-type-model (simd-pack-512-type
(:constructor* %make-simd-pack-512-type (tag-mask)))
(tag-mask (missing-arg)
:test = :hasher identity ; the tag-mask is its own hash
:type (and (unsigned-byte #.(length +simd-pack-element-types+))
(not (eql 0)))))
(declaim (ftype (sfunction (ctype ctype) (values t t)) csubtypep)) (declaim (ftype (sfunction (ctype ctype) (values t t)) csubtypep))
;;; Look for nice relationships for types that have nice relationships ;;; Look for nice relationships for types that have nice relationships
;;; only when one is a hierarchical subtype of the other. ;;; only when one is a hierarchical subtype of the other.

41
src/code/type.lisp
View file

@ -1366,7 +1366,8 @@
(loop for class in '(character-set classoid member named (loop for class in '(character-set classoid member named
numeric-union numeric-union
#+sb-simd-pack simd-pack #+sb-simd-pack simd-pack
#+sb-simd-pack-256 simd-pack-256) #+sb-simd-pack-256 simd-pack-256
#+sb-simd-pack-512 simd-pack-512)
sum (ash 1 (type-class-name->id class)))) sum (ash 1 (type-class-name->id class))))
(quick-fail-complex-= () (quick-fail-complex-= ()
;; Fail if neither arg is in a class that defines a COMPLEX-= method ;; Fail if neither arg is in a class that defines a COMPLEX-= method
@ -5456,6 +5457,44 @@ expansion happened."
(if (eql intersection 0) *empty-type* (%make-simd-pack-256-type intersection)))) (if (eql intersection 0) *empty-type* (%make-simd-pack-256-type intersection))))
(!define-superclasses simd-pack-256 ((simd-pack-256)) !cold-init-forms)) (!define-superclasses simd-pack-256 ((simd-pack-256)) !cold-init-forms))
#+sb-simd-pack-512
(progn
(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
;; be passed down, because an unknown-type condition is an immediate failure.
(def-type-translator simd-pack-512 (&optional (element-type-spec '*))
(simd-type-parser-helper element-type-spec 'simd-pack-512 #'%make-simd-pack-512-type))
(define-type-method (simd-pack-512 :negate) (type)
(let ((not-pack (make-negation-type (specifier-type 'simd-pack-512)))
(mask (logxor (simd-pack-512-type-tag-mask type) +simd-pack-wild+)))
(if (eql mask 0)
not-pack
(type-union not-pack (%make-simd-pack-512-type mask)))))
(define-type-method (simd-pack-512 :unparse) (flags type)
(simd-type-unparser-helper 'simd-pack-512 (simd-pack-512-type-tag-mask type)))
(define-type-method (simd-pack-512 :simple-subtypep) (type1 type2)
(declare (type simd-pack-512-type type1 type2))
(values (zerop (logandc2 (simd-pack-512-type-tag-mask type1)
(simd-pack-512-type-tag-mask type2)))
t))
(define-type-method (simd-pack-512 :simple-union2) (type1 type2)
(declare (type simd-pack-512-type type1 type2))
(%make-simd-pack-512-type (logior (simd-pack-512-type-tag-mask type1)
(simd-pack-512-type-tag-mask type2))))
(define-type-method (simd-pack-512 :simple-intersection2) (type1 type2)
(declare (type simd-pack-512-type type1 type2))
(let ((intersection (logand (simd-pack-512-type-tag-mask type1)
(simd-pack-512-type-tag-mask type2))))
(if (eql intersection 0) *empty-type* (%make-simd-pack-512-type intersection))))
(!define-superclasses simd-pack-512 ((simd-pack-512)) !cold-init-forms))
;;;; utilities shared between cross-compiler and target system ;;;; utilities shared between cross-compiler and target system

9
src/code/typep.lisp
View file

@ -102,6 +102,10 @@
(simd-pack-256-type (simd-pack-256-type
(and (simd-pack-256-p object) (and (simd-pack-256-p object)
(logbitp (%simd-pack-256-tag object) (simd-pack-256-type-tag-mask type)))) (logbitp (%simd-pack-256-tag object) (simd-pack-256-type-tag-mask type))))
#+sb-simd-pack-512
(simd-pack-512-type
(and (simd-pack-512-p object)
(logbitp (%simd-pack-512-tag object) (simd-pack-512-type-tag-mask type))))
(character-set-type (character-set-type
(test-character-type type)) (test-character-type type))
(negation-type (negation-type
@ -278,7 +282,8 @@
member-type member-type
character-set-type character-set-type
#+sb-simd-pack simd-pack-type #+sb-simd-pack simd-pack-type
#+sb-simd-pack-256 simd-pack-256-type) #+sb-simd-pack-256 simd-pack-256-type
#+sb-simd-pack-512 simd-pack-512-type)
(values (%%typep obj type) (values (%%typep obj type)
t)) t))
(array-type (array-type
@ -478,6 +483,8 @@ Experimental."
(simd-pack (simd-subtype (%simd-pack-tag x) simd-pack)) (simd-pack (simd-subtype (%simd-pack-tag x) simd-pack))
#+sb-simd-pack-256 #+sb-simd-pack-256
(simd-pack-256 (simd-subtype (%simd-pack-256-tag x) simd-pack-256)) (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))
(t (t
(classoid-of x))))) (classoid-of x)))))

157
src/code/x86-64-vm.lisp
View file

@ -23,9 +23,13 @@
(* unsigned) (context (* os-context-t)) (index int)) (* unsigned) (context (* os-context-t)) (index int))
#+linux #+linux
(progn
(define-alien-routine ("os_context_ymm_register_addr" context-ymm-register-addr) (define-alien-routine ("os_context_ymm_register_addr" context-ymm-register-addr)
(* unsigned) (context (* os-context-t)) (index int)) (* unsigned) (context (* os-context-t)) (index int))
(define-alien-routine ("os_context_zmm_register_addr" context-zmm-register-addr)
(* unsigned) (context (* os-context-t)) (index int)))
;;; This is like CONTEXT-REGISTER, but returns the value of a float ;;; This is like CONTEXT-REGISTER, but returns the value of a float
;;; register. FORMAT is the type of float to return. ;;; register. FORMAT is the type of float to return.
@ -113,7 +117,115 @@
(sap-ref-double sap 0) (sap-ref-double sap 0)
(sap-ref-double sap 8) (sap-ref-double sap 8)
(sap-ref-double saph 0) (sap-ref-double saph 0)
(sap-ref-double saph 8))))))) (sap-ref-double saph 8))))
;; fixme512: check if this is correct
#+sb-simd-pack-512
(simd-pack-512-int
(if (< index 16)
;; ZMM0 - ZMM15
(let ((sapy #+linux (alien-sap (context-ymm-register-addr context index))
#-linux sap)
(sapz #+linux (alien-sap (context-zmm-register-addr context index))
#-linux sap))
(if integer
(error "Integer not yet implemented")
(%make-simd-pack-512-ub64
(sap-ref-64 sap 0)
(sap-ref-64 sap 8)
(sap-ref-64 sapy 0)
(sap-ref-64 sapy 8)
(sap-ref-64 sapz 0)
(sap-ref-64 sapz 8)
(sap-ref-64 sapz 16)
(sap-ref-64 sapz 24))))
;; ZMM16 - ZMM31
(let ((sapz #+linux (alien-sap (context-zmm-register-addr context index))
#-linux sap))
(if integer
(error "Integer not yet implemented")
(%make-simd-pack-512-ub64
(sap-ref-64 sapz 0)
(sap-ref-64 sapz 8)
(sap-ref-64 sapz 16)
(sap-ref-64 sapz 24)
(sap-ref-64 sapz 32)
(sap-ref-64 sapz 40)
(sap-ref-64 sapz 48)
(sap-ref-64 sapz 56))))))
#+sb-simd-pack-512
(simd-pack-512-single
(if (< index 16)
;; ZMM0 - ZMM15
(let ((sapy #+linux (alien-sap (context-ymm-register-addr context index))
#-linux sap)
(sapz #+linux (alien-sap (context-zmm-register-addr context index))
#-linux sap))
(%make-simd-pack-512-single
(sap-ref-single sap 0)
(sap-ref-single sap 4)
(sap-ref-single sap 8)
(sap-ref-single sap 12)
(sap-ref-single sapy 0)
(sap-ref-single sapy 4)
(sap-ref-single sapy 8)
(sap-ref-single sapy 12)
(sap-ref-single sapz 0)
(sap-ref-single sapz 4)
(sap-ref-single sapz 8)
(sap-ref-single sapz 12)
(sap-ref-single sapz 16)
(sap-ref-single sapz 20)
(sap-ref-single sapz 24)
(sap-ref-single sapz 28)))
;; ZMM16 - ZMM31
(let ((sapz #+linux (alien-sap (context-zmm-register-addr context index))
#-linux sap))
(%make-simd-pack-512-single
(sap-ref-single sapz 0)
(sap-ref-single sapz 4)
(sap-ref-single sapz 8)
(sap-ref-single sapz 12)
(sap-ref-single sapz 16)
(sap-ref-single sapz 20)
(sap-ref-single sapz 24)
(sap-ref-single sapz 28)
(sap-ref-single sapz 32)
(sap-ref-single sapz 36)
(sap-ref-single sapz 40)
(sap-ref-single sapz 44)
(sap-ref-single sapz 48)
(sap-ref-single sapz 52)
(sap-ref-single sapz 56)
(sap-ref-single sapz 60)))))
#+sb-simd-pack-512
(simd-pack-512-double
(if (< index 16)
;; ZMM0 - ZMM15
(let ((sapy #+linux (alien-sap (context-ymm-register-addr context index))
#-linux sap)
(sapz #+linux (alien-sap (context-zmm-register-addr context index))
#-linux sap))
(%make-simd-pack-512-double
(sap-ref-double sap 0)
(sap-ref-double sap 8)
(sap-ref-double sapy 0)
(sap-ref-double sapy 8)
(sap-ref-double sapz 0)
(sap-ref-double sapz 8)
(sap-ref-double sapz 16)
(sap-ref-double sapz 24)))
;; ZMM16 - ZMM31
(let ((sapz #+linux (alien-sap (context-zmm-register-addr context index))
#-linux sap))
(%make-simd-pack-512-double
(sap-ref-double sapz 0)
(sap-ref-double sapz 8)
(sap-ref-double sapz 16)
(sap-ref-double sapz 24)
(sap-ref-double sapz 32)
(sap-ref-double sapz 40)
(sap-ref-double sapz 48)
(sap-ref-double sapz 56))))))))
(defun %set-context-float-register (context index format value) (defun %set-context-float-register (context index format value)
(declare (ignorable context index format)) (declare (ignorable context index format))
@ -179,7 +291,48 @@
(setf (sap-ref-double sap 0) a (setf (sap-ref-double sap 0) a
(sap-ref-double sap 8) b (sap-ref-double sap 8) b
(sap-ref-double sap 16) c (sap-ref-double sap 16) c
(sap-ref-double sap 24) d)))))) (sap-ref-double sap 24) d)))
#+sb-simd-pack-512
(simd-pack-512-int
(multiple-value-bind (a b c d e f g h) (%simd-pack-512-ub64s value)
(setf (sap-ref-64 sap 0) a
(sap-ref-64 sap 8) b
(sap-ref-64 sap 16) c
(sap-ref-64 sap 24) d
(sap-ref-64 sap 32) e
(sap-ref-64 sap 40) f
(sap-ref-64 sap 48) g
(sap-ref-64 sap 56) h)))
#+sb-simd-pack-512
(simd-pack-512-single
(multiple-value-bind (a b c d e f g h i j k l m n p q) (%simd-pack-512-singles value)
(setf (sap-ref-single sap 0) a
(sap-ref-single sap 4) b
(sap-ref-single sap 8) c
(sap-ref-single sap 12) d
(sap-ref-single sap 16) e
(sap-ref-single sap 20) f
(sap-ref-single sap 24) g
(sap-ref-single sap 28) h
(sap-ref-single sap 32) i
(sap-ref-single sap 36) j
(sap-ref-single sap 40) k
(sap-ref-single sap 44) l
(sap-ref-single sap 48) m
(sap-ref-single sap 52) n
(sap-ref-single sap 54) p
(sap-ref-single sap 60) q)))
#+sb-simd-pack-512
(simd-pack-512-double
(multiple-value-bind (a b c d e f g h) (%simd-pack-512-doubles value)
(setf (sap-ref-double sap 0) a
(sap-ref-double sap 8) b
(sap-ref-double sap 16) c
(sap-ref-double sap 24) d
(sap-ref-double sap 32) e
(sap-ref-double sap 40) f
(sap-ref-double sap 48) g
(sap-ref-double sap 56) h))))))
;;; Given a signal context, return the floating point modes word in ;;; Given a signal context, return the floating point modes word in
;;; the same format as returned by FLOATING-POINT-MODES. ;;; the same format as returned by FLOATING-POINT-MODES.

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

@ -391,7 +391,7 @@
("src/compiler/target-dstate" :not-host) ("src/compiler/target-dstate" :not-host)
("src/compiler/asm-target/insts") ("src/compiler/asm-target/insts")
#+avx2 ("src/compiler/{arch}/avx2-insts") #+avx2 ("src/compiler/{arch}/avx2-insts")
#+avx2 ("src/compiler/{arch}/avx512-insts") #+avx512 ("src/compiler/{arch}/avx512-insts")
("src/compiler/{arch}/macros") ("src/compiler/{arch}/macros")
("src/assembly/{arch}/support") ("src/assembly/{arch}/support")
@ -400,6 +400,7 @@
("src/compiler/{arch}/float") ("src/compiler/{arch}/float")
#+sb-simd-pack ("src/compiler/{arch}/simd-pack") #+sb-simd-pack ("src/compiler/{arch}/simd-pack")
#+sb-simd-pack-256 ("src/compiler/{arch}/simd-pack-256") #+sb-simd-pack-256 ("src/compiler/{arch}/simd-pack-256")
#+sb-simd-pack-512 ("src/compiler/{arch}/simd-pack-512")
("src/compiler/{arch}/sap") ("src/compiler/{arch}/sap")
("src/compiler/{arch}/char") ("src/compiler/{arch}/char")
("src/compiler/{arch}/system") ("src/compiler/{arch}/system")

55
src/cold/exports.lisp
View file

@ -448,7 +448,25 @@
"%SIMD-PACK-256-SB32S" "%SIMD-PACK-256-SB32S"
"%SIMD-PACK-256-SB64S" "%SIMD-PACK-256-SB64S"
"%SIMD-PACK-256-DOUBLES" "%SIMD-PACK-256-DOUBLES"
"%SIMD-PACK-256-SINGLES")) "%SIMD-PACK-256-SINGLES")
#+sb-simd-pack-512
(:export
"SIMD-PACK-512"
"SIMD-PACK-512-P"
"%MAKE-SIMD-PACK-512-UB32"
"%MAKE-SIMD-PACK-512-UB64"
"%MAKE-SIMD-PACK-512-DOUBLE"
"%MAKE-SIMD-PACK-512-SINGLE"
"%SIMD-PACK-512-UB8S"
"%SIMD-PACK-512-UB16S"
"%SIMD-PACK-512-UB32S"
"%SIMD-PACK-512-UB64S"
"%SIMD-PACK-512-SB8S"
"%SIMD-PACK-512-SB16S"
"%SIMD-PACK-512-SB32S"
"%SIMD-PACK-512-SB64S"
"%SIMD-PACK-512-DOUBLES"
"%SIMD-PACK-512-SINGLES"))
(defpackage "SB-INT" (defpackage "SB-INT"
(:documentation (:documentation
@ -1576,6 +1594,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"%MAKE-RATIO" "%MAKE-RATIO"
#+sb-simd-pack "%MAKE-SIMD-PACK" #+sb-simd-pack "%MAKE-SIMD-PACK"
#+sb-simd-pack-256 "%MAKE-SIMD-PACK-256" #+sb-simd-pack-256 "%MAKE-SIMD-PACK-256"
#+sb-simd-pack-512 "%MAKE-SIMD-PACK-512"
"%MAKE-STRUCTURE-INSTANCE" "%MAKE-STRUCTURE-INSTANCE"
"%MAKE-STRUCTURE-INSTANCE-ALLOCATOR" "%MAKE-STRUCTURE-INSTANCE-ALLOCATOR"
"%MAP" "%MAP-FOR-EFFECT-ARITY-1" "%MAP" "%MAP-FOR-EFFECT-ARITY-1"
@ -1899,10 +1918,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-ERROR"
#+long-float #+long-float
"OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR"
#+sb-simd-pack #+sb-simd-pack "OBJECT-NOT-SIMD-PACK-ERROR"
"OBJECT-NOT-SIMD-PACK-ERROR" #+sb-simd-pack-256 "OBJECT-NOT-SIMD-PACK-256-ERROR"
#+sb-simd-pack-256 #+sb-simd-pack-512 "OBJECT-NOT-SIMD-PACK-512-ERROR"
"OBJECT-NOT-SIMD-PACK-256-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR"
"OBJECT-NOT-SIMPLE-ARRAY-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-ERROR"
@ -2391,6 +2409,12 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
(:export "%SIMD-PACK-256-TAG" (:export "%SIMD-PACK-256-TAG"
"%SIMD-PACK-256-0" "%SIMD-PACK-256-1" "%SIMD-PACK-256-0" "%SIMD-PACK-256-1"
"%SIMD-PACK-256-2" "%SIMD-PACK-256-3") "%SIMD-PACK-256-2" "%SIMD-PACK-256-3")
#+sb-simd-pack-512
(:export "%SIMD-PACK-512-TAG"
"%SIMD-PACK-512-0" "%SIMD-PACK-512-1"
"%SIMD-PACK-512-2" "%SIMD-PACK-512-3"
"%SIMD-PACK-512-4" "%SIMD-PACK-512-5"
"%SIMD-PACK-512-6" "%SIMD-PACK-512-7")
#+sb-simd-pack #+sb-simd-pack
(:export "SIMD-PACK-SINGLE" (:export "SIMD-PACK-SINGLE"
"SIMD-PACK-DOUBLE" "SIMD-PACK-DOUBLE"
@ -2404,6 +2428,12 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"SIMD-PACK-256-INT" "SIMD-PACK-256-INT"
"SIMD-PACK-256-TYPE" "SIMD-PACK-256-TYPE"
"SIMD-PACK-256-TYPE-TAG-MASK") "SIMD-PACK-256-TYPE-TAG-MASK")
#+sb-simd-pack-512
(:export "SIMD-PACK-512-SINGLE"
"SIMD-PACK-512-DOUBLE"
"SIMD-PACK-512-INT"
"SIMD-PACK-512-TYPE"
"SIMD-PACK-512-TYPE-TAG-MASK")
#+long-float #+long-float
(:export "LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS" (:export "LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS"
"LONG-FLOAT-HIGH-BITS" "LONG-FLOAT-LOW-BITS" "LONG-FLOAT-HIGH-BITS" "LONG-FLOAT-LOW-BITS"
@ -3213,7 +3243,20 @@ structure representations")
"SIMD-PACK-256-P2-SLOT" "SIMD-PACK-256-P2-SLOT"
"SIMD-PACK-256-P3-SLOT" "SIMD-PACK-256-P3-SLOT"
"SIMD-PACK-256-SIZE" "SIMD-PACK-256-SIZE"
"SIMD-PACK-256-WIDETAG")) "SIMD-PACK-256-WIDETAG")
#+sb-simd-pack-512
(:export
"SIMD-PACK-512-TAG-SLOT"
"SIMD-PACK-512-P0-SLOT"
"SIMD-PACK-512-P1-SLOT"
"SIMD-PACK-512-P2-SLOT"
"SIMD-PACK-512-P3-SLOT"
"SIMD-PACK-512-P4-SLOT"
"SIMD-PACK-512-P5-SLOT"
"SIMD-PACK-512-P6-SLOT"
"SIMD-PACK-512-P7-SLOT"
"SIMD-PACK-512-SIZE"
"SIMD-PACK-512-WIDETAG"))
(defpackage "SB-DISASSEM" (defpackage "SB-DISASSEM"
(:documentation "private: stuff related to the implementation of the disassembler") (:documentation "private: stuff related to the implementation of the disassembler")

18
src/compiler/dump.lisp
View file

@ -513,6 +513,11 @@
(unless (similar-check-table x file) (unless (similar-check-table x file)
(dump-simd-pack-256 x file) (dump-simd-pack-256 x file)
(similar-save-object x file))) (similar-save-object x file)))
#+(and (not sb-xc-host) sb-simd-pack-512)
(simd-pack-512
(unless (similar-check-table x file)
(dump-simd-pack-512 x file)
(similar-save-object x file)))
(t (t
;; This probably never happens, since bad things tend to ;; This probably never happens, since bad things tend to
;; be detected during IR1 conversion. ;; be detected during IR1 conversion.
@ -529,6 +534,19 @@
(dump-integer-as-n-bytes (%simd-pack-256-2 x) 8 file) (dump-integer-as-n-bytes (%simd-pack-256-2 x) 8 file)
(dump-integer-as-n-bytes (%simd-pack-256-3 x) 8 file)) (dump-integer-as-n-bytes (%simd-pack-256-3 x) 8 file))
#+(and (not sb-xc-host) sb-simd-pack-512)
(defun dump-simd-pack-512 (x file)
(dump-fop 'fop-simd-pack file)
(dump-integer-as-n-bytes (logior (%simd-pack-512-tag x) (ash 1 7)) 8 file)
(dump-integer-as-n-bytes (%simd-pack-512-0 x) 8 file)
(dump-integer-as-n-bytes (%simd-pack-512-1 x) 8 file)
(dump-integer-as-n-bytes (%simd-pack-512-2 x) 8 file)
(dump-integer-as-n-bytes (%simd-pack-512-3 x) 8 file)
(dump-integer-as-n-bytes (%simd-pack-512-4 x) 8 file)
(dump-integer-as-n-bytes (%simd-pack-512-5 x) 8 file)
(dump-integer-as-n-bytes (%simd-pack-512-6 x) 8 file)
(dump-integer-as-n-bytes (%simd-pack-512-7 x) 8 file))
;;; Dump an object of any type by dispatching to the correct ;;; Dump an object of any type by dispatching to the correct
;;; type-specific dumping function. We pick off immediate objects, ;;; type-specific dumping function. We pick off immediate objects,
;;; symbols and magic lists here. Other objects are handled by ;;; symbols and magic lists here. Other objects are handled by

7
src/compiler/generic/early-objdef.lisp
View file

@ -223,8 +223,10 @@
#-sb-simd-pack unused01-widetag ; 5E #-sb-simd-pack unused01-widetag ; 5E
#+sb-simd-pack-256 simd-pack-256-widetag ; 69 #+sb-simd-pack-256 simd-pack-256-widetag ; 69
#-sb-simd-pack-256 unused03-widetag ; 62 #-sb-simd-pack-256 unused03-widetag ; 62
filler-widetag ; 66 6D #+sb-simd-pack-512 simd-pack-512-widetag ; 6D
unused04-widetag ; 6A 71 #-sb-simd-pack-512 unused04-widetag ; 66
filler-widetag ; 6A 6D
unused05-widetag ; 6E 75 unused05-widetag ; 6E 75
unused06-widetag ; 72 79 unused06-widetag ; 72 79
unused07-widetag ; 76 7D unused07-widetag ; 76 7D
@ -313,6 +315,7 @@
(fdefn-widetag "fdefn") (fdefn-widetag "fdefn")
(simd-pack-widetag "SIMD-pack") (simd-pack-widetag "SIMD-pack")
(simd-pack-256-widetag "SIMD-pack256") (simd-pack-256-widetag "SIMD-pack256")
(simd-pack-512-widetag "SIMD-pack512")
(filler-widetag "filler") (filler-widetag "filler")
(simple-array-widetag "simple-array") (simple-array-widetag "simple-array")
(simple-array-nil-widetag "simple-array-NIL") (simple-array-nil-widetag "simple-array-NIL")

2
src/compiler/generic/genesis.lisp
View file

@ -4585,7 +4585,7 @@ static char *event_printf_format[] = {~{~% ~S~^,~}~%};~%#endif~2%"
(mapcar #'get-primitive-obj (mapcar #'get-primitive-obj
'(bignum ratio single-float double-float '(bignum ratio single-float double-float
complex complex-single-float complex-double-float complex complex-single-float complex-double-float
simd-pack simd-pack-256)))) simd-pack simd-pack-256 simd-pack-512))))
(defun write-c-headers (c-header-dir-name) (defun write-c-headers (c-header-dir-name)
(macrolet ((out-to (name &body body) ; write boilerplate and inclusion guard (macrolet ((out-to (name &body body) ; write boilerplate and inclusion guard

1
src/compiler/generic/interr.lisp
View file

@ -181,6 +181,7 @@
#+long-float ((complex long-float) object-not-complex-long-float) #+long-float ((complex long-float) object-not-complex-long-float)
#+sb-simd-pack simd-pack #+sb-simd-pack simd-pack
#+sb-simd-pack-256 simd-pack-256 #+sb-simd-pack-256 simd-pack-256
#+sb-simd-pack-512 simd-pack-512
weak-pointer weak-pointer
instance instance
#+sb-unicode #+sb-unicode

1
src/compiler/generic/late-objdef.lisp
View file

@ -74,6 +74,7 @@
#+sb-simd-pack (simd-pack "unboxed") #+sb-simd-pack (simd-pack "unboxed")
#+sb-simd-pack-256 (simd-pack-256 "unboxed") #+sb-simd-pack-256 (simd-pack-256 "unboxed")
#+sb-simd-pack-512 (simd-pack-512 "unboxed")
(filler "filler" "lose" "filler") (filler "filler" "lose" "filler")
(simple-array "array") (simple-array "array")

1
src/compiler/generic/layout-ids.lisp
View file

@ -145,6 +145,7 @@ SB-C::LVAR-MODIFIED-ANNOTATION
SB-DI::BOGUS-DEBUG-FUN SB-DI::BOGUS-DEBUG-FUN
#+sb-simd-pack SB-KERNEL:SIMD-PACK-TYPE #+sb-simd-pack SB-KERNEL:SIMD-PACK-TYPE
#+sb-simd-pack-256 SB-KERNEL:SIMD-PACK-256-TYPE #+sb-simd-pack-256 SB-KERNEL:SIMD-PACK-256-TYPE
#+sb-simd-pack-512 SB-KERNEL:SIMD-PACK-512-TYPE
#+sb-fasteval SB-INTERPRETER::SEXPR #+sb-fasteval SB-INTERPRETER::SEXPR
SB-C::MODULAR-CLASS SB-C::MODULAR-CLASS
SB-DI:DEBUG-BLOCK SB-DI:DEBUG-BLOCK

31
src/compiler/generic/objdef.lisp
View file

@ -451,6 +451,37 @@ during backtrace.
(p1 :c-type "long" :type (unsigned-byte 64)) (p1 :c-type "long" :type (unsigned-byte 64))
(p2 :c-type "long" :type (unsigned-byte 64)) (p2 :c-type "long" :type (unsigned-byte 64))
(p3 :c-type "long" :type (unsigned-byte 64))) (p3 :c-type "long" :type (unsigned-byte 64)))
#+sb-simd-pack-512
(define-primitive-object (simd-pack-512
:lowtag other-pointer-lowtag
:widetag simd-pack-512-widetag)
(tag :ref-trans %simd-pack-512-tag
:attributes (movable flushable)
:type (unsigned-byte 4))
(p0 :c-type "long" :type (unsigned-byte 64))
(p1 :c-type "long" :type (unsigned-byte 64))
(p2 :c-type "long" :type (unsigned-byte 64))
(p3 :c-type "long" :type (unsigned-byte 64))
(p4 :c-type "long" :type (unsigned-byte 64))
(p5 :c-type "long" :type (unsigned-byte 64))
(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
:lowtag other-pointer-lowtag
:widetag simd-pack-512-widetag)
(tag :ref-trans %simd-pack-512-tag
:attributes (movable flushable)
:type (unsigned-byte 4))
(p0 :c-type "long" :type (unsigned-byte 64))
(p1 :c-type "long" :type (unsigned-byte 64))
(p2 :c-type "long" :type (unsigned-byte 64))
(p3 :c-type "long" :type (unsigned-byte 64))
(p4 :c-type "long" :type (unsigned-byte 64))
(p5 :c-type "long" :type (unsigned-byte 64))
(p6 :c-type "long" :type (unsigned-byte 64))
(p7 :c-type "long" :type (unsigned-byte 64)))
;;; Define some slots that precede 'struct thread' so that each may be read ;;; Define some slots that precede 'struct thread' so that each may be read
;;; using a small negative 1-byte displacement. ;;; using a small negative 1-byte displacement.

41
src/compiler/generic/primtype.lisp
View file

@ -194,6 +194,39 @@
simd-pack-256-sb16 simd-pack-256-sb16
simd-pack-256-sb32 simd-pack-256-sb32
simd-pack-256-sb64))) simd-pack-256-sb64)))
#+sb-simd-pack-512
(progn
(!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)
: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)))
(!def-primitive-type simd-pack-512-ub16 (int-avx512-reg descriptor-reg)
: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)))
(!def-primitive-type simd-pack-512-ub64 (int-avx512-reg descriptor-reg)
: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)))
(!def-primitive-type simd-pack-512-sb16 (int-avx512-reg descriptor-reg)
: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)))
(!def-primitive-type simd-pack-512-sb64 (int-avx512-reg descriptor-reg)
: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)))
;;; primitive other-pointer array types ;;; primitive other-pointer array types
(/show0 "primtype.lisp 96") (/show0 "primtype.lisp 96")
@ -500,6 +533,14 @@
(svref +simd-pack-256-primtypes+ (simd-pack-mask->tag mask))) (svref +simd-pack-256-primtypes+ (simd-pack-mask->tag mask)))
t) t)
(any)))) (any))))
#+sb-simd-pack-512
(simd-pack-512-type
(let ((mask (simd-pack-512-type-tag-mask type)))
(if (= (logcount mask) 1)
(values (primitive-type-or-lose
(svref +simd-pack-512-primtypes+ (simd-pack-mask->tag mask)))
t)
(any))))
(cons-type (cons-type
(part-of list)) (part-of list))
(built-in-classoid (built-in-classoid

2
src/compiler/generic/type-vops.lisp
View file

@ -187,6 +187,8 @@
(define-type-vop simd-pack-p (simd-pack-widetag)) (define-type-vop simd-pack-p (simd-pack-widetag))
#+sb-simd-pack-256 #+sb-simd-pack-256
(define-type-vop simd-pack-256-p (simd-pack-256-widetag)) (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))
;;; Not type vops, but generic over all backends ;;; Not type vops, but generic over all backends
(macrolet ((def (name lowtag) (macrolet ((def (name lowtag)

121
src/compiler/generic/vm-fndb.lisp
View file

@ -490,6 +490,127 @@
(values double-float double-float double-float double-float) (values double-float double-float double-float double-float)
(flushable movable foldable))) (flushable movable foldable)))
#+sb-simd-pack-512
(progn
(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)
(unsigned-byte 64) (unsigned-byte 64)
(unsigned-byte 64) (unsigned-byte 64)
(unsigned-byte 64) (unsigned-byte 64))
simd-pack-512
(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)
(flushable movable foldable))
(defknown %make-simd-pack-512-single (single-float single-float single-float single-float
single-float single-float single-float single-float
single-float single-float single-float single-float
single-float single-float single-float single-float)
(simd-pack-512 single-float)
(flushable movable foldable))
(defknown %make-simd-pack-512-ub32 ((unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32)
(unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32)
(unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32)
(unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32))
(simd-pack-512 (unsigned-byte 32))
(flushable movable foldable))
(defknown %make-simd-pack-512-ub64 ((unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64)
(unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64))
(simd-pack-512 (unsigned-byte 64))
(flushable movable foldable))
(defknown (%simd-pack-512-0 %simd-pack-512-1 %simd-pack-512-2 %simd-pack-512-3
%simd-pack-512-4 %simd-pack-512-5 %simd-pack-512-6 %simd-pack-512-7) (simd-pack-512)
(unsigned-byte 64)
(flushable movable foldable))
(defknown %simd-pack-512-ub8s (simd-pack-512)
(values (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8)
(unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8) (unsigned-byte 8))
(flushable movable foldable))
(defknown %simd-pack-512-ub16s (simd-pack-512)
(values (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16)
(unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16)
(unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16)
(unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16)
(unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16)
(unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16)
(unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16)
(unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16) (unsigned-byte 16))
(flushable movable foldable))
(defknown %simd-pack-512-ub32s (simd-pack-512)
(values (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32)
(unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32)
(unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32)
(unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32))
(flushable movable foldable))
(defknown %simd-pack-512-ub64s (simd-pack-512)
(values (unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64)
(unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64))
(flushable movable foldable))
(defknown %simd-pack-512-sb8s (simd-pack-512)
(values (signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8)
(signed-byte 8) (signed-byte 8) (signed-byte 8) (signed-byte 8))
(flushable movable foldable))
(defknown %simd-pack-512-sb16s (simd-pack-512)
(values (signed-byte 16) (signed-byte 16) (signed-byte 16) (signed-byte 16)
(signed-byte 16) (signed-byte 16) (signed-byte 16) (signed-byte 16)
(signed-byte 16) (signed-byte 16) (signed-byte 16) (signed-byte 16)
(signed-byte 16) (signed-byte 16) (signed-byte 16) (signed-byte 16)
(signed-byte 16) (signed-byte 16) (signed-byte 16) (signed-byte 16)
(signed-byte 16) (signed-byte 16) (signed-byte 16) (signed-byte 16)
(signed-byte 16) (signed-byte 16) (signed-byte 16) (signed-byte 16)
(signed-byte 16) (signed-byte 16) (signed-byte 16) (signed-byte 16))
(flushable movable foldable))
(defknown %simd-pack-512-sb32s (simd-pack-512)
(values (signed-byte 32) (signed-byte 32) (signed-byte 32) (signed-byte 32)
(signed-byte 32) (signed-byte 32) (signed-byte 32) (signed-byte 32)
(signed-byte 32) (signed-byte 32) (signed-byte 32) (signed-byte 32)
(signed-byte 32) (signed-byte 32) (signed-byte 32) (signed-byte 32))
(flushable movable foldable))
(defknown %simd-pack-512-sb64s (simd-pack-512)
(values (signed-byte 64) (signed-byte 64) (signed-byte 64) (signed-byte 64)
(signed-byte 64) (signed-byte 64) (signed-byte 64) (signed-byte 64))
(flushable movable foldable))
(defknown %simd-pack-512-singles (simd-pack-512)
(values single-float single-float single-float single-float
single-float single-float single-float single-float
single-float single-float single-float single-float
single-float single-float single-float single-float)
(flushable movable foldable))
(defknown %simd-pack-512-doubles (simd-pack-512)
(values double-float double-float double-float double-float
double-float double-float double-float double-float)
(flushable movable foldable)))
;;;; threading ;;;; threading
(defknown (dynamic-space-free-pointer binding-stack-pointer-sap (defknown (dynamic-space-free-pointer binding-stack-pointer-sap

6
src/compiler/generic/vm-type.lisp
View file

@ -287,7 +287,11 @@
#+sb-simd-pack-256 #+sb-simd-pack-256
((simd-pack-256-type-p type) ((simd-pack-256-type-p type)
(cond ((type= type (specifier-type 'simd-pack-256)) (cond ((type= type (specifier-type 'simd-pack-256))
sb-vm:simd-pack-256-widetag))))) sb-vm:simd-pack-256-widetag)))
#+sb-simd-pack-512
((simd-pack-512-type-p type)
(cond ((type= type (specifier-type 'simd-pack-512))
sb-vm:simd-pack-512-widetag)))))
;; Given TYPES which is a list of types from a union type, decompose into ;; Given TYPES which is a list of types from a union type, decompose into
;; two unions, one being an OR over types representable as widetags ;; two unions, one being an OR over types representable as widetags

2
src/compiler/generic/vm-typetran.lisp
View file

@ -116,6 +116,8 @@
(define-type-predicate simd-pack-p simd-pack) (define-type-predicate simd-pack-p simd-pack)
#+sb-simd-pack-256 #+sb-simd-pack-256
(define-type-predicate simd-pack-256-p simd-pack-256) (define-type-predicate simd-pack-256-p simd-pack-256)
#+sb-simd-pack-512
(define-type-predicate simd-pack-512-p simd-pack-512)
(define-type-predicate weak-pointer-p weak-pointer) (define-type-predicate weak-pointer-p weak-pointer)
(define-type-predicate code-component-p code-component) (define-type-predicate code-component-p code-component)
(define-type-predicate fdefn-p fdefn) (define-type-predicate fdefn-p fdefn)

3
src/compiler/ir1tran.lisp
View file

@ -341,7 +341,8 @@
(or unboxed-array (array nil)) (or unboxed-array (array nil))
system-area-pointer system-area-pointer
#+sb-simd-pack simd-pack #+sb-simd-pack simd-pack
#+sb-simd-pack-256 simd-pack-256)) #+sb-simd-pack-256 simd-pack-256
#+sb-simd-pack-512 simd-pack-512))
;; STANDARD-OBJECT layouts use MAKE-LOAD-FORM, but all other layouts ;; STANDARD-OBJECT layouts use MAKE-LOAD-FORM, but all other layouts
;; have the same status as symbols - composite objects but leaflike. ;; have the same status as symbols - composite objects but leaflike.
(and (typep obj 'layout) (not (layout-for-pcl-obj-p obj))) (and (typep obj 'layout) (not (layout-for-pcl-obj-p obj)))

13
src/compiler/typetran.lisp
View file

@ -1203,6 +1203,16 @@
`(eql (%simd-pack-256-tag ,object) ,(sb-vm::simd-pack-mask->tag mask)) `(eql (%simd-pack-256-tag ,object) ,(sb-vm::simd-pack-mask->tag mask))
`(logbitp (%simd-pack-256-tag ,object) ,mask)))))) `(logbitp (%simd-pack-256-tag ,object) ,mask))))))
#+sb-simd-pack-512
(defun source-transform-simd-pack-512-typep (object type)
(let ((mask (simd-pack-512-type-tag-mask type)))
(if (= mask sb-kernel::+simd-pack-wild+)
`(simd-pack-512-p ,object)
`(and (simd-pack-512-p ,object)
,(if (= (logcount mask) 1)
`(eql (%simd-pack-512-tag ,object) ,(sb-vm::simd-pack-mask->tag mask))
`(logbitp (%simd-pack-512-tag ,object) ,mask))))))
;;; Return the predicate and type from the most specific entry in ;;; Return the predicate and type from the most specific entry in
;;; *TYPE-PREDICATES* that is a supertype of TYPE. ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
(defun find-supertype-predicate (type) (defun find-supertype-predicate (type)
@ -1753,6 +1763,9 @@
#+sb-simd-pack-256 #+sb-simd-pack-256
(simd-pack-256-type (simd-pack-256-type
(source-transform-simd-pack-256-typep object ctype)) (source-transform-simd-pack-256-typep object ctype))
#+sb-simd-pack-512
(simd-pack-512-type
(source-transform-simd-pack-512-typep object ctype))
(t nil))) (t nil)))
`(%typep ,object ',type))) `(%typep ,object ',type)))

38
src/compiler/x86-64/avx512-insts.lisp
View file

@ -46,6 +46,44 @@
(def vmovdqu32 #xf3 #x6f #x7f 0) (def vmovdqu32 #xf3 #x6f #x7f 0)
(def vmovdqu64 #xf3 #x6f #x7f 1)) (def vmovdqu64 #xf3 #x6f #x7f 1))
(macrolet ((def (name prefix)
`(define-instruction ,name (segment dst src &optional src2)
,@(avx2-inst-printer-list 'ymm-ymm/mem-dir prefix #b0001000)
(:emitter
(cond ((ea-p src)
(if (zmm-register-p dst)
(emit-avx512-inst segment src dst ,prefix #x10)
(emit-avx2-inst segment src dst ,prefix #x10 :l 0)))
((and (ea-p dst) (zmm-register-p src))
(emit-avx512-inst segment dst src ,prefix #x11))
((and (integerp src) src2 (register-p src2))
(if (or (zmm-register-p dst) (zmm-register-p src2))
(emit-avx512-inst segment src2 dst ,prefix #x10)
(emit-avx2-inst segment src2 dst ,prefix #x10 :l 0)))
((and src2 (or (zmm-register-p dst)
(zmm-register-p src)
(zmm-register-p src2)))
(emit-avx512-inst segment src dst ,prefix #x10 :vvvv src2))
((or (zmm-register-p dst)
(zmm-register-p src))
(emit-avx512-inst segment src dst ,prefix #x10))
((and src src2 dst (xmm-register-p dst))
(emit-avx2-inst segment src dst ,prefix #x10 :vvvv src2 :l 0))
((xmm-register-p dst)
(emit-avx2-inst segment src dst ,prefix #x10 :l 0))
(t
(aver (xmm-register-p src))
(emit-avx2-inst segment dst src ,prefix #x11 :l 0)))))))
(def vmovsd #xf2)
(def vmovss #xf3))
;;; Ternary logic ;;; Ternary logic
(macrolet ((def (name w) (macrolet ((def (name w)
`(define-instruction ,name (segment dst src1 src2 imm) `(define-instruction ,name (segment dst src1 src2 imm)

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

@ -21,12 +21,12 @@
(import 'sb-assem::&prefix) (import 'sb-assem::&prefix)
;; Imports from SB-VM into this package ;; Imports from SB-VM into this package
#+sb-simd-pack-256 #+sb-simd-pack-256
(import '(sb-vm::int-avx2-reg sb-vm::double-avx2-reg sb-vm::single-avx2-reg)) (import '(sb-vm::ymm-reg sb-vm::int-avx2-reg sb-vm::double-avx2-reg sb-vm::single-avx2-reg))
#+sb-simd-pack-512
(import '(sb-vm::zmm-reg sb-vm::int-avx512-reg sb-vm::double-avx512-reg sb-vm::single-avx512-reg))
(import '(sb-vm::tn-byte-offset sb-vm::tn-reg sb-vm::reg-name (import '(sb-vm::tn-byte-offset sb-vm::tn-reg sb-vm::reg-name
sb-vm::frame-byte-offset sb-vm::rip-tn sb-vm::rbp-tn sb-vm::frame-byte-offset sb-vm::rip-tn sb-vm::rbp-tn
sb-vm::gpr-tn-p sb-vm::stack-tn-p sb-c::tn-reads sb-c::tn-writes sb-vm::gpr-tn-p sb-vm::stack-tn-p sb-c::tn-reads sb-c::tn-writes
sb-vm::ymm-reg sb-vm::zmm-reg
sb-vm::int-avx512-reg sb-vm::double-avx512-reg sb-vm::single-avx512-reg
sb-vm::linkage-addr->name sb-vm::linkage-addr->name
sb-vm::registers sb-vm::float-registers sb-vm::stack))) ; SB names sb-vm::registers sb-vm::float-registers sb-vm::stack))) ; SB names
@ -1030,6 +1030,13 @@
;;; Return true if THING is an XMM register. ;;; Return true if THING is an XMM register.
(defun xmm-register-p (thing) (defun xmm-register-p (thing)
(and (register-p thing) (not (is-gpr-id-p (reg-id thing))))) (and (register-p thing) (not (is-gpr-id-p (reg-id thing)))))
;;; Return true if THING is an YMM register.
(defun ymm-register-p (thing)
(and (register-p thing) (is-ymm-id-p (reg-id thing))))
;;; Return true if THING is an ZMM register.
(defun zmm-register-p (thing)
(and (register-p thing) (is-zmm-id-p (reg-id thing))))
;;; Return true if THING is AL, AX, EAX, or RAX ;;; Return true if THING is AL, AX, EAX, or RAX
(defun accumulator-p (thing) (defun accumulator-p (thing)
@ -1105,14 +1112,14 @@
(ecase regset (ecase regset
(:xmm (:xmm
(svref (load-time-value (svref (load-time-value
(coerce (loop for i from 0 below 16 (coerce (loop for i from 0 below 32
collect (!make-reg (make-fpr-id i :xmm))) collect (!make-reg (make-fpr-id i :xmm)))
'vector) 'vector)
t) t)
number)) number))
(:ymm (:ymm
(svref (load-time-value (svref (load-time-value
(coerce (loop for i from 0 below 16 (coerce (loop for i from 0 below 32
collect (!make-reg (make-fpr-id i :ymm))) collect (!make-reg (make-fpr-id i :ymm)))
'vector) 'vector)
t) t)
@ -3356,7 +3363,11 @@
#+(and sb-simd-pack-256 (not sb-xc-host)) #+(and sb-simd-pack-256 (not sb-xc-host))
(simd-pack-256 (simd-pack-256
(setq constant (setq constant
(sb-vm::%simd-pack-256-inline-constant first))))) (sb-vm::%simd-pack-256-inline-constant first)))
#+(and sb-simd-pack-512 (not sb-xc-host))
(simd-pack-512
(setq constant
(sb-vm::%simd-pack-512-inline-constant first)))))
(destructuring-bind (type value) constant (destructuring-bind (type value) constant
(ecase type (ecase type
((:byte :word :dword :qword) ((:byte :word :dword :qword)

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

@ -43,6 +43,7 @@
((single-avx2-reg double-avx2-reg) ((single-avx2-reg double-avx2-reg)
(aver (xmm-tn-p src)) (aver (xmm-tn-p src))
(inst vmovaps dst src)) (inst vmovaps dst src))
;; fixme512: check if this is correct
#+sb-simd-pack-512 #+sb-simd-pack-512
((zmm-reg int-avx512-reg) ((zmm-reg int-avx512-reg)
(aver (xmm-tn-p src)) (aver (xmm-tn-p src))

6
src/compiler/x86-64/parms.lisp
View file

@ -199,6 +199,7 @@
;;; Bit indices into *CPU-FEATURE-BITS* ;;; Bit indices into *CPU-FEATURE-BITS*
(defconstant cpu-has-ymm-registers 0) (defconstant cpu-has-ymm-registers 0)
(defconstant cpu-has-popcnt 1) (defconstant cpu-has-popcnt 1)
(defconstant cpu-has-zmm-registers 2) ;; fixme512 which bit: 3?
#+sb-simd-pack #+sb-simd-pack
(progn (progn
@ -221,4 +222,9 @@
#(simd-pack-256-single simd-pack-256-double #(simd-pack-256-single simd-pack-256-double
simd-pack-256-ub8 simd-pack-256-ub16 simd-pack-256-ub32 simd-pack-256-ub64 simd-pack-256-ub8 simd-pack-256-ub16 simd-pack-256-ub32 simd-pack-256-ub64
simd-pack-256-sb8 simd-pack-256-sb16 simd-pack-256-sb32 simd-pack-256-sb64) simd-pack-256-sb8 simd-pack-256-sb16 simd-pack-256-sb32 simd-pack-256-sb64)
#'equalp)
(defconstant-eqx +simd-pack-512-primtypes+
#(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)
#'equalp)) #'equalp))

594
src/compiler/x86-64/simd-pack-512.lisp Normal file
View file

@ -0,0 +1,594 @@
;;;; AVX512 intrinsics support for x86-64
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-VM")
;; should this be redefined as ea-for-avx512-stack ?
(defun ea-for-avx512-stack (tn &optional (base rbp-tn))
(ea (frame-byte-offset (+ (tn-offset tn) 7)) base))
(defun float-avx512-p (tn)
(sc-is tn single-avx512-reg single-avx512-stack fp-immediate
double-avx512-reg double-avx512-stack fp-immediate))
(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))
(defun %simd-pack-512-1 (x) (error "Called %SIMD-PACK-512-1 ~S" x))
(defun %simd-pack-512-2 (x) (error "Called %SIMD-PACK-512-2 ~S" x))
(defun %simd-pack-512-3 (x) (error "Called %SIMD-PACK-512-3 ~S" x))
(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)))
(define-move-fun (load-int-avx512-immediate 1) (vop x y)
((fp-immediate) (int-avx512-reg))
(let* ((x (tn-value x))
(p0 (%simd-pack-512-0 x))
(p1 (%simd-pack-512-1 x))
(p2 (%simd-pack-512-2 x))
(p3 (%simd-pack-512-3 x))
(p4 (%simd-pack-512-4 x))
(p5 (%simd-pack-512-5 x))
(p6 (%simd-pack-512-6 x))
(p7 (%simd-pack-512-7 x)))
(cond ((= p0 p1 p2 p3 p4 p5 p6 p7 0)
(inst vpxor y y y))
((= p0 p1 p2 p3 p4 p5 p6 p7 (ldb (byte 64 0) -1))
;; don't think this is recognized as dependency breaking...
(inst vpcmpeqd y y y))
(t
(inst vmovdqu y (register-inline-constant x))))))
(define-move-fun (load-float-avx512-immediate 1) (vop x y)
((fp-immediate fp-immediate)
(single-avx512-reg double-avx512-reg))
(let* ((x (tn-value x))
(p0 (%simd-pack-512-0 x))
(p1 (%simd-pack-512-1 x))
(p2 (%simd-pack-512-2 x))
(p3 (%simd-pack-512-3 x))
(p4 (%simd-pack-512-4 x))
(p5 (%simd-pack-512-5 x))
(p6 (%simd-pack-512-6 x))
(p7 (%simd-pack-512-7 x)))
(cond ((= p0 p1 p2 p3 p4 p5 p6 p7 0)
;; 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 ???
(t
(inst vmovdqu64 y (register-inline-constant x))))))
(define-move-fun (load-int-avx512 2) (vop x y)
((int-avx512-stack) (int-avx512-reg))
(inst vmovdqu64 y (ea-for-avx512-stack x)))
(define-move-fun (load-float-avx512 2) (vop x y)
((single-avx512-stack double-avx512-stack) (single-avx512-reg double-avx512-reg))
(inst vmovups y (ea-for-avx512-stack x)))
(define-move-fun (store-int-avx512 2) (vop x y)
((int-avx512-reg) (int-avx512-stack))
(inst vmovdqu64 (ea-for-avx512-stack y) x))
(define-move-fun (store-float-avx512 2) (vop x y)
((double-avx512-reg single-avx512-reg) (double-avx512-stack single-avx512-stack))
(inst vmovups (ea-for-avx512-stack y) x))
(define-vop (avx512-move)
(:args (x :scs (single-avx512-reg double-avx512-reg int-avx512-reg)
:target y
:load-if (not (location= x y))))
(:results (y :scs (single-avx512-reg double-avx512-reg int-avx512-reg)
:load-if (not (location= x y))))
(:note "AVX512 move")
(:generator 0
(move y x)))
(define-move-vop avx512-move :move
(int-avx512-reg single-avx512-reg double-avx512-reg)
(int-avx512-reg single-avx512-reg double-avx512-reg))
(macrolet ((define-move-from-avx512 (type tag &rest scs)
(let ((name (symbolicate "MOVE-FROM-AVX512/" type)))
`(progn
(define-allocator (,name)
(:args (x :scs ,scs))
(: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)
y simd-pack-512-tag-slot other-pointer-lowtag)
(let ((ea (object-slot-ea
y simd-pack-512-p0-slot other-pointer-lowtag)))
(if (float-avx512-p x)
(inst vmovups ea x)
(inst vmovdqu ea x)))))
(define-move-vop ,name :move
,scs (descriptor-reg))))))
;; see +simd-pack-element-types+
(define-move-from-avx512 simd-pack-512-single 0 single-avx512-reg)
(define-move-from-avx512 simd-pack-512-double 1 double-avx512-reg)
(define-move-from-avx512 simd-pack-512-ub8 2 int-avx512-reg)
(define-move-from-avx512 simd-pack-512-ub16 3 int-avx512-reg)
(define-move-from-avx512 simd-pack-512-ub32 4 int-avx512-reg)
(define-move-from-avx512 simd-pack-512-ub64 5 int-avx512-reg)
(define-move-from-avx512 simd-pack-512-sb8 6 int-avx512-reg)
(define-move-from-avx512 simd-pack-512-sb16 7 int-avx512-reg)
(define-move-from-avx512 simd-pack-512-sb32 8 int-avx512-reg)
(define-move-from-avx512 simd-pack-512-sb64 9 int-avx512-reg))
(define-vop (move-to-avx512)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (int-avx512-reg double-avx512-reg single-avx512-reg)))
(:note "pointer to AVX512 coercion")
(:generator 2
(let ((ea (object-slot-ea x simd-pack-512-p0-slot other-pointer-lowtag)))
(if (float-avx512-p y)
(inst vmovups y ea)
(inst vmovdqu64 y ea)))))
(define-move-vop move-to-avx512 :move
(descriptor-reg)
(int-avx512-reg double-avx512-reg single-avx512-reg))
(define-vop (move-avx512-arg)
(:args (x :scs (int-avx512-reg double-avx512-reg single-avx512-reg) :target y)
(fp :scs (any-reg)
:load-if (not (sc-is y int-avx512-reg double-avx512-reg single-avx512-reg))))
(:results (y))
(:note "AVX512 argument move")
(:generator 4
(sc-case y
((int-avx512-reg double-avx512-reg single-avx512-reg)
(unless (location= x y)
(if (or (float-avx512-p x)
(float-avx512-p y))
(inst vmovups y x)
(inst vmovdqu64 y x))))
((int-avx512-stack double-avx512-stack single-avx512-stack)
(if (float-avx512-p x)
(inst vmovups (ea-for-avx512-stack y fp) x)
(inst vmovdqu64 (ea-for-avx512-stack y fp) x))))))
(define-move-vop move-avx512-arg :move-arg
(int-avx512-reg double-avx512-reg single-avx512-reg descriptor-reg)
(int-avx512-reg double-avx512-reg single-avx512-reg))
(define-move-vop move-arg :move-arg
(int-avx512-reg double-avx512-reg single-avx512-reg)
(descriptor-reg))
(define-vop (%simd-pack-512-0)
(:translate %simd-pack-512-0)
(:args (x :scs (descriptor-reg)))
(:arg-types simd-pack-512)
(:results (dst :scs (unsigned-reg)))
(:result-types unsigned-num)
(:policy :fast-safe)
(:generator 3
(loadw dst x simd-pack-512-p0-slot other-pointer-lowtag)))
(define-vop (%simd-pack-512-1 %simd-pack-512-0)
(:translate %simd-pack-512-1)
(:generator 3
(loadw dst x simd-pack-512-p1-slot other-pointer-lowtag)))
(define-vop (%simd-pack-512-2 %simd-pack-512-0)
(:translate %simd-pack-512-2)
(:generator 3
(loadw dst x simd-pack-512-p2-slot other-pointer-lowtag)))
(define-vop (%simd-pack-512-3 %simd-pack-512-0)
(:translate %simd-pack-512-3)
(:generator 3
(loadw dst x simd-pack-512-p3-slot other-pointer-lowtag)))
(define-vop (%simd-pack-512-4 %simd-pack-512-0)
(:translate %simd-pack-512-4)
(:generator 3
(loadw dst x simd-pack-512-p4-slot other-pointer-lowtag)))
(define-vop (%simd-pack-512-5 %simd-pack-512-0)
(:translate %simd-pack-512-5)
(:generator 3
(loadw dst x simd-pack-512-p5-slot other-pointer-lowtag)))
(define-vop (%simd-pack-512-6 %simd-pack-512-0)
(:translate %simd-pack-512-6)
(:generator 3
(loadw dst x simd-pack-512-p6-slot other-pointer-lowtag)))
(define-vop (%simd-pack-512-7 %simd-pack-512-0)
(:translate %simd-pack-512-7)
(:generator 3
(loadw dst x simd-pack-512-p7-slot other-pointer-lowtag)))
(define-allocator (%make-simd-pack-512)
(:translate %make-simd-pack-512)
(:policy :fast-safe)
(:args (tag :scs (any-reg))
(p0 :scs (unsigned-reg))
(p1 :scs (unsigned-reg))
(p2 :scs (unsigned-reg))
(p3 :scs (unsigned-reg))
(p4 :scs (unsigned-reg))
(p5 :scs (unsigned-reg))
(p6 :scs (unsigned-reg))
(p7 :scs (unsigned-reg)))
(:arg-types tagged-num
unsigned-num unsigned-num unsigned-num unsigned-num
unsigned-num unsigned-num unsigned-num unsigned-num)
(:results (dst :scs (descriptor-reg) :from :load))
(:result-types t)
(:generator 13
(alloc-other simd-pack-512-widetag simd-pack-512-size dst)
;; see +simd-pack-element-types+
(storew tag dst simd-pack-512-tag-slot other-pointer-lowtag)
(storew p0 dst simd-pack-512-p0-slot other-pointer-lowtag)
(storew p1 dst simd-pack-512-p1-slot other-pointer-lowtag)
(storew p2 dst simd-pack-512-p2-slot other-pointer-lowtag)
(storew p3 dst simd-pack-512-p3-slot other-pointer-lowtag)
(storew p4 dst simd-pack-512-p4-slot other-pointer-lowtag)
(storew p5 dst simd-pack-512-p5-slot other-pointer-lowtag)
(storew p6 dst simd-pack-512-p6-slot other-pointer-lowtag)
(storew p7 dst simd-pack-512-p7-slot other-pointer-lowtag)))
(define-vop (%make-simd-pack-512-ub64)
(:translate %make-simd-pack-512-ub64)
(:policy :fast-safe)
(:args (p0 :scs (unsigned-reg))
(p1 :scs (unsigned-reg))
(p2 :scs (unsigned-reg))
(p3 :scs (unsigned-reg))
(p4 :scs (unsigned-reg))
(p5 :scs (unsigned-reg))
(p6 :scs (unsigned-reg))
(p7 :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
unsigned-num unsigned-num unsigned-num unsigned-num)
(:results (dst :scs (int-avx512-reg)))
(:result-types simd-pack-512-ub64)
(:temporary (:scs (int-avx512-reg)) tmp1 tmp2 tmp3)
(:generator 8
;; "xmm views" of zmm regs
(let ((x0 (sb-c:make-random-tn (sb-c:sc-or-lose 'sb-vm::double-reg) (sb-c:tn-offset dst)))
(x1 (sb-c:make-random-tn (sb-c:sc-or-lose 'sb-vm::double-reg) (sb-c:tn-offset tmp1)))
(x2 (sb-c:make-random-tn (sb-c:sc-or-lose 'sb-vm::double-reg) (sb-c:tn-offset tmp2)))
(x3 (sb-c:make-random-tn (sb-c:sc-or-lose 'sb-vm::double-reg) (sb-c:tn-offset tmp3))))
(inst vmovq x0 p0)
(inst vpinsrq x0 x0 p1 1)
(inst vmovq x1 p2)
(inst vpinsrq x1 x1 p3 1)
(inst vmovq x2 p4)
(inst vpinsrq x2 x2 p5 1)
(inst vmovq x3 p6)
(inst vpinsrq x3 x3 p7 1)
(inst vinserti64x2 dst dst x1 1)
(inst vinserti64x2 tmp2 tmp2 x3 1)
(inst vinserti64x4 dst dst tmp2 1))))
(defmacro simd-pack-512-dispatch (pack &body body)
(check-type pack symbol)
`(let ((,pack ,pack))
(etypecase ,pack
,@(map 'list (lambda (eltype)
`((simd-pack-512 ,eltype) ,@body))
+simd-pack-element-types+))))
#-sb-xc-host
(macrolet ((unpack-unsigned (pack bits)
`(simd-pack-512-dispatch ,pack
(let ((a (%simd-pack-512-0 ,pack))
(b (%simd-pack-512-1 ,pack))
(c (%simd-pack-512-2 ,pack))
(d (%simd-pack-512-3 ,pack))
(e (%simd-pack-512-4 ,pack))
(f (%simd-pack-512-5 ,pack))
(g (%simd-pack-512-6 ,pack))
(h (%simd-pack-512-7 ,pack)))
(values
,@(loop for pos by bits below 64 collect
`(unpack-unsigned-1 ,bits ,pos a))
,@(loop for pos by bits below 64 collect
`(unpack-unsigned-1 ,bits ,pos b))
,@(loop for pos by bits below 64 collect
`(unpack-unsigned-1 ,bits ,pos c))
,@(loop for pos by bits below 64 collect
`(unpack-unsigned-1 ,bits ,pos d))
,@(loop for pos by bits below 64 collect
`(unpack-unsigned-1 ,bits ,pos e))
,@(loop for pos by bits below 64 collect
`(unpack-unsigned-1 ,bits ,pos f))
,@(loop for pos by bits below 64 collect
`(unpack-unsigned-1 ,bits ,pos g))
,@(loop for pos by bits below 64 collect
`(unpack-unsigned-1 ,bits ,pos h))))))
(unpack-unsigned-1 (bits position ub64)
`(ldb (byte ,bits ,position) ,ub64)))
(declaim (inline %simd-pack-512-ub8s))
(defun %simd-pack-512-ub8s (pack)
(declare (type simd-pack-512 pack))
(unpack-unsigned pack 8))
(declaim (inline %simd-pack-512-ub16s))
(defun %simd-pack-512-ub16s (pack)
(declare (type simd-pack-512 pack))
(unpack-unsigned pack 16))
(declaim (inline %simd-pack-512-ub32s))
(defun %simd-pack-512-ub32s (pack)
(declare (type simd-pack-512 pack))
(unpack-unsigned pack 32))
(declaim (inline %simd-pack-512-ub64s))
(defun %simd-pack-512-ub64s (pack)
(declare (type simd-pack-512 pack))
(unpack-unsigned pack 64)))
#-sb-xc-host
(macrolet ((unpack-signed (pack bits)
`(simd-pack-512-dispatch ,pack
(let ((a (%simd-pack-512-0 ,pack))
(b (%simd-pack-512-1 ,pack))
(c (%simd-pack-512-2 ,pack))
(d (%simd-pack-512-3 ,pack))
(e (%simd-pack-512-4 ,pack))
(f (%simd-pack-512-5 ,pack))
(g (%simd-pack-512-6 ,pack))
(h (%simd-pack-512-7 ,pack)))
(values
,@(loop for pos by bits below 64 collect
`(unpack-signed-1 ,bits ,pos a))
,@(loop for pos by bits below 64 collect
`(unpack-signed-1 ,bits ,pos b))
,@(loop for pos by bits below 64 collect
`(unpack-signed-1 ,bits ,pos c))
,@(loop for pos by bits below 64 collect
`(unpack-signed-1 ,bits ,pos d))
,@(loop for pos by bits below 64 collect
`(unpack-signed-1 ,bits ,pos e))
,@(loop for pos by bits below 64 collect
`(unpack-signed-1 ,bits ,pos f))
,@(loop for pos by bits below 64 collect
`(unpack-signed-1 ,bits ,pos g))
,@(loop for pos by bits below 64 collect
`(unpack-signed-1 ,bits ,pos h))))))
(unpack-signed-1 (bits position ub64)
`(- (mod (+ (ldb (byte ,bits ,position) ,ub64)
,(expt 2 (1- bits)))
,(expt 2 bits))
,(expt 2 (1- bits)))))
(declaim (inline %simd-pack-512-sb8s))
(defun %simd-pack-512-sb8s (pack)
(declare (type simd-pack-512 pack))
(unpack-signed pack 8))
(declaim (inline %simd-pack-512-sb16s))
(defun %simd-pack-512-sb16s (pack)
(declare (type simd-pack-512 pack))
(unpack-signed pack 16))
(declaim (inline %simd-pack-512-sb32s))
(defun %simd-pack-512-sb32s (pack)
(declare (type simd-pack-512 pack))
(unpack-signed pack 32))
(declaim (inline %simd-pack-512-sb64s))
(defun %simd-pack-512-sb64s (pack)
(declare (type simd-pack-512 pack))
(unpack-signed pack 64)))
#-sb-xc-host
(progn
(defun %make-simd-pack-512-ub32 (p0 p1 p2 p3 p4 p5 p6 p7 p8
p9 p10 p11 p12 p13 p14 p15)
(declare (type (unsigned-byte 32) p0 p1 p2 p3 p4 p5 p6 p7 p8
p9 p10 p11 p12 p13 p14 p15))
(%make-simd-pack-512
#.(position '(unsigned-byte 32) +simd-pack-element-types+ :test #'equal)
(logior p0 (ash p1 32))
(logior p2 (ash p3 32))
(logior p4 (ash p5 32))
(logior p6 (ash p7 32))
(logior p8 (ash p9 32))
(logior p10 (ash p11 32))
(logior p12 (ash p13 32))
(logior p14 (ash p15 32)))))
(define-vop (%make-simd-pack-512-double)
(:translate %make-simd-pack-512-double)
(:policy :fast-safe)
(:args (p0 :scs (double-reg) :target dst)
(p1 :scs (double-reg))
(p2 :scs (double-reg))
(p3 :scs (double-reg))
(p4 :scs (double-reg))
(p5 :scs (double-reg))
(p6 :scs (double-reg))
(p7 :scs (double-reg)))
(:arg-types double-float double-float double-float double-float
double-float double-float double-float double-float)
(:temporary (:scs (double-avx512-reg)) tmp1 tmp2 tmp3)
(:results (dst :scs (double-avx512-reg) :from (:argument 0)))
(:result-types simd-pack-512-double)
(:generator 4
(let ((x0 (sb-c:make-random-tn (sb-c:sc-or-lose 'sb-vm::double-reg) (sb-c:tn-offset dst)))
(x1 (sb-c:make-random-tn (sb-c:sc-or-lose 'sb-vm::double-reg) (sb-c:tn-offset tmp1)))
(x2 (sb-c:make-random-tn (sb-c:sc-or-lose 'sb-vm::double-reg) (sb-c:tn-offset tmp2)))
(x3 (sb-c:make-random-tn (sb-c:sc-or-lose 'sb-vm::double-reg) (sb-c:tn-offset tmp3))))
(inst vunpcklpd x0 p0 p1)
(inst vunpcklpd x1 p2 p3)
(inst vunpcklpd x2 p4 p5)
(inst vunpcklpd x3 p6 p7)
(inst vinsertf64x2 dst dst x1 1)
(inst vinsertf64x2 tmp2 tmp2 x3 1)
(inst vinsertf64x4 dst dst tmp2 1))))
(define-vop (%make-simd-pack-512-single)
(:translate %make-simd-pack-512-single)
(:policy :fast-safe)
(:args (p0 :scs (single-reg) :target dst)
(p1 :scs (single-reg))
(p2 :scs (single-reg))
(p3 :scs (single-reg))
(p4 :scs (single-reg))
(p5 :scs (single-reg))
(p6 :scs (single-reg))
(p7 :scs (single-reg))
(p8 :scs (single-reg))
(p9 :scs (single-reg))
(p10 :scs (single-reg))
(p11 :scs (single-reg))
(p12 :scs (single-reg))
(p13 :scs (single-reg))
(p14 :scs (single-reg))
(p15 :scs (single-reg)))
(:arg-types single-float single-float single-float single-float
single-float single-float single-float single-float
single-float single-float single-float single-float
single-float single-float single-float single-float)
(:results (dst :scs (single-avx512-reg)))
(:result-types simd-pack-512-single)
;; (:temporary (:sc single-avx512-reg) t0 t1 t2 t3)
;; temporaries explicitly in float16, float17, float18, and float19 regs
;; avoids allocator putting temps in the lower zmm 16-regs, so we don't
;; need a new sc class, which is a scarce resource in SBCL (only 60)
(:temporary (:sc single-avx512-reg :offset 16) t0)
(:temporary (:sc single-avx512-reg :offset 17) t1)
(:temporary (:sc single-avx512-reg :offset 18) t2)
(:temporary (:sc single-avx512-reg :offset 19) t3)
(:generator 5
(inst vunpcklps t0 p0 p1)
(inst vunpcklps t1 p2 p3)
(inst vshufps dst t0 t1 #x44)
(inst vunpcklps t2 p4 p5)
(inst vunpcklps t3 p6 p7)
(inst vshufps t0 t2 t3 #x44)
(inst vinsertf32x4 dst dst t0 1)
(inst vunpcklps t2 p8 p9)
(inst vunpcklps t3 p10 p11)
(inst vshufps t0 t2 t3 #x44)
(inst vinsertf32x4 dst dst t0 2)
(inst vunpcklps t2 p12 p13)
(inst vunpcklps t3 p14 p15)
(inst vshufps t0 t2 t3 #x44)
(inst vinsertf32x4 dst dst t0 3)))
(defknown %simd-pack-512-single-item
(simd-pack-512 (integer 0 15)) single-float (flushable))
(define-vop (%simd-pack-512-single-item)
(:translate %simd-pack-512-single-item)
(:args (x :scs (int-avx512-reg double-avx512-reg single-avx512-reg)
:target dst))
(:info index)
(:arg-types simd-pack-512 (:constant t))
(:results (dst :scs (single-reg)))
(:result-types single-float)
(:temporary (:sc single-reg :from (:argument 0)) tmp)
(:policy :fast-safe)
(:generator 3
(multiple-value-bind (lane idx) (floor index 4)
(inst vextractf32x4 tmp x lane)
(if (zerop idx)
(inst vmovss dst tmp)
(inst vshufps dst tmp tmp idx)))))
(defknown %simd-pack-512-double-item
(simd-pack-512 (integer 0 7)) double-float (flushable))
(define-vop (%simd-pack-512-double-item)
(:translate %simd-pack-512-double-item)
(:args (x :scs (int-avx512-reg double-avx512-reg single-avx512-reg)
:target dst))
(:info index)
(:arg-types simd-pack-512 (:constant t))
(:results (dst :scs (double-reg)))
(:result-types double-float)
(:temporary (:sc double-reg :from (:argument 0)) tmp)
(:policy :fast-safe)
(:generator 3
(multiple-value-bind (lane idx) (floor index 2)
(inst vextractf64x2 tmp x lane)
(if (zerop idx)
(inst vmovsd dst tmp)
(inst vpsrldq dst tmp 8)))))
#-sb-xc-host
(progn
(declaim (inline %simd-pack-512-singles))
(defun %simd-pack-512-singles (pack)
(declare (type simd-pack-512 pack))
(simd-pack-512-dispatch pack
(values (%simd-pack-512-single-item pack 0)
(%simd-pack-512-single-item pack 1)
(%simd-pack-512-single-item pack 2)
(%simd-pack-512-single-item pack 3)
(%simd-pack-512-single-item pack 4)
(%simd-pack-512-single-item pack 5)
(%simd-pack-512-single-item pack 6)
(%simd-pack-512-single-item pack 7)
(%simd-pack-512-single-item pack 8)
(%simd-pack-512-single-item pack 9)
(%simd-pack-512-single-item pack 10)
(%simd-pack-512-single-item pack 11)
(%simd-pack-512-single-item pack 12)
(%simd-pack-512-single-item pack 13)
(%simd-pack-512-single-item pack 14)
(%simd-pack-512-single-item pack 15)))))
#-sb-xc-host
(progn
(declaim (inline %simd-pack-512-doubles))
(defun %simd-pack-512-doubles (pack)
(declare (type simd-pack-512 pack))
(simd-pack-512-dispatch pack
(values (%simd-pack-512-double-item pack 0)
(%simd-pack-512-double-item pack 1)
(%simd-pack-512-double-item pack 2)
(%simd-pack-512-double-item pack 3)
(%simd-pack-512-double-item pack 4)
(%simd-pack-512-double-item pack 5)
(%simd-pack-512-double-item pack 6)
(%simd-pack-512-double-item pack 7))))
(defun %simd-pack-512-inline-constant (pack)
(list :avx512 (logior (%simd-pack-512-0 pack)
(ash (%simd-pack-512-1 pack) 64)
(ash (%simd-pack-512-2 pack) 128)
(ash (%simd-pack-512-3 pack) 192)
(ash (%simd-pack-512-4 pack) 256)
(ash (%simd-pack-512-5 pack) 320)
(ash (%simd-pack-512-6 pack) 384)
(ash (%simd-pack-512-7 pack) 448)))))

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

@ -376,6 +376,7 @@
:constant-scs (fp-immediate) :constant-scs (fp-immediate)
:save-p t :save-p t
:alternate-scs (single-sse-stack)) :alternate-scs (single-sse-stack))
#+sb-simd-pack-256
(ymm-reg float-registers :locations #.*float-regs*) (ymm-reg float-registers :locations #.*float-regs*)
;; These next 3 should probably be named to YMM-{INT,SINGLE,DOUBLE}-REG ;; These next 3 should probably be named to YMM-{INT,SINGLE,DOUBLE}-REG
;; but I think there are 3rd-party libraries that expect these names. ;; but I think there are 3rd-party libraries that expect these names.
@ -398,6 +399,7 @@
:save-p t :save-p t
:alternate-scs (single-avx2-stack)) :alternate-scs (single-avx2-stack))
;; ZMM SCs use all 32 registers (16-31 require EVEX encoding) ;; ZMM SCs use all 32 registers (16-31 require EVEX encoding)
#+sb-simd-pack-512
(zmm-reg float-registers :locations #.*zmm-regs*) (zmm-reg float-registers :locations #.*zmm-regs*)
#+sb-simd-pack-512 #+sb-simd-pack-512
(int-avx512-reg float-registers (int-avx512-reg float-registers
@ -438,9 +440,10 @@
int-sse-stack single-sse-stack double-sse-stack)) int-sse-stack single-sse-stack double-sse-stack))
#+sb-simd-pack-256 #+sb-simd-pack-256
(defparameter *hword-sc-names* '(ymm-reg int-avx2-reg single-avx2-reg double-avx2-reg (defparameter *hword-sc-names* '(ymm-reg int-avx2-reg single-avx2-reg double-avx2-reg
int-avx2-stack single-avx2-stack double-avx2-stack)) int-avx2-stack single-avx2-stack
(defparameter *zword-sc-names* '(zmm-reg double-avx2-stack))
#+sb-simd-pack-512 int-avx512-reg #+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 single-avx512-reg
#+sb-simd-pack-512 double-avx512-reg #+sb-simd-pack-512 double-avx512-reg
#+sb-simd-pack-512 int-avx512-stack #+sb-simd-pack-512 int-avx512-stack
@ -451,11 +454,12 @@
. #.(mapcar (lambda (class-spec) . #.(mapcar (lambda (class-spec)
(let ((size (let ((size
(case (car class-spec) (case (car class-spec)
(#.*zword-sc-names* :zword)
#+sb-simd-pack #+sb-simd-pack
(#.*oword-sc-names* :oword) (#.*oword-sc-names* :oword)
#+sb-simd-pack-256 #+sb-simd-pack-256
(#.*hword-sc-names* :hword) (#.*hword-sc-names* :hword)
#+sb-simd-pack-512
(#.*zword-sc-names* :zword)
(#.*qword-sc-names* :qword) (#.*qword-sc-names* :qword)
(#.*float-sc-names* :float) (#.*float-sc-names* :float)
(#.*double-sc-names* :double) (#.*double-sc-names* :double)
@ -501,6 +505,10 @@
(defun xmm-tn-p (thing) (defun xmm-tn-p (thing)
(and (tn-p thing) (and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'float-registers))) (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)
(sc-or-lose 'int-avx512-reg))))
;;; Return true if THING is on the stack (in whatever storage class). ;;; Return true if THING is on the stack (in whatever storage class).
(defun stack-tn-p (thing) (defun stack-tn-p (thing)
(and (tn-p thing) (and (tn-p thing)
@ -541,7 +549,8 @@
#+compact-instance-header (layout immediate-sc-number) #+compact-instance-header (layout immediate-sc-number)
((or float (complex float) ((or float (complex float)
#+(and sb-simd-pack (not sb-xc-host)) simd-pack #+(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-256 (not sb-xc-host)) simd-pack-256
#+(and sb-simd-pack-512 (not sb-xc-host)) simd-pack-512)
fp-immediate-sc-number) fp-immediate-sc-number)
;; This case has to follow the numeric cases because proxy floating-point numbers ;; 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 ;; are host structs. Or we could implement and use something like SB-XC:TYPECASE

3
src/interpreter/checkfuns.lisp
View file

@ -58,7 +58,8 @@
((or named-type numeric-union-type member-type classoid ((or named-type numeric-union-type member-type classoid
character-set-type unknown-type hairy-type character-set-type unknown-type hairy-type
alien-type-type #+sb-simd-pack simd-pack-type alien-type-type #+sb-simd-pack simd-pack-type
#+sb-simd-pack-256 simd-pack-256-type) #+sb-simd-pack-256 simd-pack-256-type
#+sb-simd-pack-512 simd-pack-512-type)
type) type)
(fun-designator-type (specifier-type '(or function symbol))) (fun-designator-type (specifier-type '(or function symbol)))
(fun-type (specifier-type 'function)) (fun-type (specifier-type 'function))

3
src/runtime/stringspace.c
View file

@ -104,6 +104,9 @@ static int readonly_unboxed_obj_p(lispobj* obj)
#endif #endif
#ifdef SIMD_PACK_256_WIDETAG #ifdef SIMD_PACK_256_WIDETAG
case SIMD_PACK_256_WIDETAG: case SIMD_PACK_256_WIDETAG:
#endif
#ifdef SIMD_PACK_512_WIDETAG
case SIMD_PACK_512_WIDETAG:
#endif #endif
return 1; return 1;
case RATIO_WIDETAG: case COMPLEX_RATIONAL_WIDETAG: case RATIO_WIDETAG: case COMPLEX_RATIONAL_WIDETAG:

7
src/runtime/x86-64-arch.c
View file

@ -43,7 +43,7 @@
#define UD2_INST 0x0b0f #define UD2_INST 0x0b0f
#define BREAKPOINT_WIDTH 1 #define BREAKPOINT_WIDTH 1
int avx_supported = 0, avx2_supported = 0; int avx_supported = 0, avx2_supported = 0, avx512_supported = 0;
static void cpuid(unsigned info, unsigned subinfo, static void cpuid(unsigned info, unsigned subinfo,
unsigned *eax, unsigned *ebx, unsigned *ecx, unsigned *edx) unsigned *eax, unsigned *ebx, unsigned *ecx, unsigned *edx)
@ -126,6 +126,9 @@ void tune_asm_routines_for_microarch(void)
xgetbv(&eax, &edx); xgetbv(&eax, &edx);
if ((eax & 0x06) == 0x06) { // YMM and XMM if ((eax & 0x06) == 0x06) { // YMM and XMM
avx_supported = 1; avx_supported = 1;
if ((eax & 5) == 5 && (eax & 7) == 7) { // ZMM
avx512_supported = 1;
}
cpuid(7, 0, &eax, &ebx, &ecx, &edx); cpuid(7, 0, &eax, &ebx, &ecx, &edx);
if (ebx & 0x20) { if (ebx & 0x20) {
avx2_supported = 1; avx2_supported = 1;
@ -136,6 +139,8 @@ void tune_asm_routines_for_microarch(void)
int our_cpu_feature_bits = 0; int our_cpu_feature_bits = 0;
// avx2_supported gets copied into bit 1 of cpu_feature_bits // avx2_supported gets copied into bit 1 of cpu_feature_bits
if (avx2_supported) our_cpu_feature_bits |= 1; if (avx2_supported) our_cpu_feature_bits |= 1;
// avx512 supported in bit 3
if (avx512_supported) our_cpu_feature_bits |= 4;
// POPCNT = ECX bit 23, which gets copied into bit 2 in cpu_feature_bits // POPCNT = ECX bit 23, which gets copied into bit 2 in cpu_feature_bits
if (cpuid_fn1_ecx & (1<<23)) our_cpu_feature_bits |= 2; if (cpuid_fn1_ecx & (1<<23)) our_cpu_feature_bits |= 2;
consts->cpu_feature_bits = our_cpu_feature_bits; consts->cpu_feature_bits = our_cpu_feature_bits;

77
src/runtime/x86-64-linux-os.c
View file

@ -233,6 +233,83 @@ os_context_ymm_register_addr(os_context_t *context, int offset)
#endif #endif
} }
#define _YMM 2
#define _KMM 5
#define _ZMM 6
#define _ZMMHI 7
/**
* Resolves the byte offset of an extended xstate.
*/
static int32_t _xfeature_offset(uint64_t xcomp_bv, int xfeature) {
// If bit 63 is 0, the kernel is running in legacy UNCOMPACTED mode
if ((xcomp_bv & (1ull << 63)) == 0) {
switch (xfeature) {
case _YMM: return 576;
case _KMM: return 1088;
case _ZMM: return 1152;
case _ZMMHI: return 2112;
default: return -1;
}
}
// Compacted mode boundary validation
if ((xcomp_bv & (1ull << xfeature)) == 0)
return -2; // not currently allocated or tracked
// Packed streams start immediately after the 64-byte XSAVE header
int32_t offset = 512 + 64;
for (int i = 2; i < xfeature; i++) {
if (xcomp_bv & (1ull << i)) {
if (i == _ZMM || i == _ZMMHI)
offset = ALIGN_UP(offset, 64);
switch (i) {
case _YMM: offset += 256; break; // 16 bytes * 16 registers
case _KMM: offset += 64; break; // 8 bytes * 8 registers
case _ZMM: offset += 512; break; // 32 bytes * 16 registers
case _ZMMHI: offset += 1024; break; // 64 bytes * 16 registers
default: break;
}
}
}
if (xfeature == _ZMM || xfeature == _ZMMHI)
offset = ALIGN_UP(offset, 64);
return offset;
}
uint32_t *
os_context_zmm_register_addr(os_context_t *context, int reg)
{
if (!context || !context->uc_mcontext.fpregs)
return NULL;
uint8_t *xstate_base = (uint8_t *)context->uc_mcontext.fpregs;
/* Read the tracking vector from the XSAVE header (offset 520) */
uint64_t xcomp_bv = *(uint64_t *)(xstate_base + 512 + 8);
/* pointer to the upper 256 bits (Bits 256-511) */
if (reg >= 0 && reg < 16) {
int32_t offset = _xfeature_offset(xcomp_bv, _ZMM);
if (offset < 0) return NULL;
return (uint32_t *)(xstate_base + offset + (reg * 32));
}
/* ZMM16 to ZMM31 - 512-bit linear layout (Bits 0-511) */
else if (reg > 15 && reg < 32) {
int32_t offset = _xfeature_offset(xcomp_bv, _ZMMHI);
if (offset < 0) return NULL;
return (uint32_t *)(xstate_base + offset + ((reg - 16) * 64));
}
return NULL;
}
sigset_t * sigset_t *
os_context_sigmask_addr(os_context_t *context) os_context_sigmask_addr(os_context_t *context)
{ {

285
tests/simd-pack-512.pure.lisp Normal file
View file

@ -0,0 +1,285 @@
;;;; Potentially side-effectful tests of the simd-pack 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.
#-sb-simd-pack-512 (invoke-restart 'run-tests::skip-file)
(when (zerop (sb-alien:extern-alien "avx512_supported" int))
(format t "~&INFO: simd-pack-512 not supported")
(invoke-restart 'run-tests::skip-file))
(defun make-constant-packs ()
(values (sb-ext:%make-simd-pack-512-ub64 1 2 3 4 5 6 7 8)
(sb-ext:%make-simd-pack-512-ub32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(sb-ext:%make-simd-pack-512-ub64 (ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1))
(sb-ext:%make-simd-pack-512-single 1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0
1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0)
(sb-ext:%make-simd-pack-512-single 0f0 0f0 0f0 0f0 0f0 0f0 0f0 0f0
0f0 0f0 0f0 0f0 0f0 0f0 0f0 0f0)
(sb-ext:%make-simd-pack-512-single (sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1)
(sb-kernel:make-single-float -1))
(sb-ext:%make-simd-pack-512-double 1d0 2d0 3d0 4d0 5d0 6d0 7d0 8d0)
(sb-ext:%make-simd-pack-512-double 0d0 0d0 0d0 0d0 0d0 0d0 0d0 0d0)
(sb-ext:%make-simd-pack-512-double (sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1))
(sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1))
(sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1))
(sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1))
(sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1))
(sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1))
(sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1))
(sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1)))))
(with-test (:name :compile-simd-pack-512-512)
(multiple-value-bind (i i0 i-1
f f0 f-1
d d0 d-1)
(make-constant-packs)
(loop for (p0 p1 p2 p3 p4 p5 p6 p7) in (list '(1 2 3 4 5 6 7 8) '(0 0 0 0 0 0 0 0)
(list (ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)
(ldb (byte 64 0) -1)))
for pack in (list i i0 i-1)
do (print (list p0 p1 p2 p3 p4 p5 p6 p7))
(assert (eql p0 (sb-kernel:%simd-pack-512-0 pack)))
(assert (eql p1 (sb-kernel:%simd-pack-512-1 pack)))
(assert (eql p2 (sb-kernel:%simd-pack-512-2 pack)))
(assert (eql p3 (sb-kernel:%simd-pack-512-3 pack)))
(assert (eql p4 (sb-kernel:%simd-pack-512-4 pack)))
(assert (eql p5 (sb-kernel:%simd-pack-512-5 pack)))
(assert (eql p6 (sb-kernel:%simd-pack-512-6 pack)))
(assert (eql p7 (sb-kernel:%simd-pack-512-7 pack))))
(loop for expected in (list '(1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0
1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0)
'(0f0 0f0 0f0 0f0 0f0 0f0 0f0 0f0
0f0 0f0 0f0 0f0 0f0 0f0 0f0 0f0)
(make-list
16 :initial-element (sb-kernel:make-single-float -1)))
for pack in (list f f0 f-1)
do (assert (every #'eql expected
(multiple-value-list (sb-ext:%simd-pack-512-singles pack)))))
(loop for expected in (list '(1d0 2d0 3d0 4d0 5d0 6d0 7d0 8d0)
'(0d0 0d0 0d0 0d0 0d0 0d0 0d0 0d0)
(make-list
8 :initial-element (sb-kernel:make-double-float
-1 (ldb (byte 32 0) -1))))
for pack in (list d d0 d-1)
do (assert (every #'eql expected
(multiple-value-list (sb-ext:%simd-pack-512-doubles pack)))))
))
(with-test (:name (simd-pack-512 print :smoke))
(let ((packs (multiple-value-list (make-constant-packs))))
(flet ((print-them (expect)
(dolist (pack packs)
(flet ((do-it ()
(with-output-to-string (stream)
(write pack :stream stream :pretty t :escape nil))))
(case expect
(print-not-readable
(assert-error (do-it) print-not-readable))
(t
(do-it)))))))
;; Default
(print-them t)
;; Readably
(let ((*print-readably* t)
(*read-eval* t))
(print-them t))
;; Want readably but can't without *READ-EVAL*.
(let ((*print-readably* t)
(*read-eval* nil))
(print-them 'print-not-readable)))))
(defvar *tmp-filename* (scratch-file-name))
(defvar *pack*)
(with-test (:name :load-simd-pack-512-int)
(with-open-file (s *tmp-filename*
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print '(setq *pack* (sb-ext:%make-simd-pack-512-ub64 2 4 8 16 2 4 8 16)) s))
(let (tmp-fasl)
(unwind-protect
(progn
(setq tmp-fasl (compile-file *tmp-filename*))
(let ((*pack* nil))
(load tmp-fasl)
(assert (typep *pack* '(sb-ext:simd-pack-512 (unsigned-byte 64))))
(assert (= 2 (sb-kernel:%simd-pack-512-0 *pack*)))
(assert (= 4 (sb-kernel:%simd-pack-512-1 *pack*)))
(assert (= 8 (sb-kernel:%simd-pack-512-2 *pack*)))
(assert (= 16 (sb-kernel:%simd-pack-512-3 *pack*)))
(assert (= 2 (sb-kernel:%simd-pack-512-4 *pack*)))
(assert (= 4 (sb-kernel:%simd-pack-512-5 *pack*)))
(assert (= 8 (sb-kernel:%simd-pack-512-6 *pack*)))
(assert (= 16 (sb-kernel:%simd-pack-512-7 *pack*)))))
(when tmp-fasl (delete-file tmp-fasl))
(delete-file *tmp-filename*))))
(with-test (:name :load-simd-pack-512-single)
(with-open-file (s *tmp-filename*
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print '(setq *pack* (sb-ext:%make-simd-pack-512-single 1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0
1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0)) s))
(let (tmp-fasl)
(unwind-protect
(progn
(setq tmp-fasl (compile-file *tmp-filename*))
(let ((*pack* nil))
(load tmp-fasl)
(assert (typep *pack* '(sb-ext:simd-pack-512 single-float)))
(assert (equal (multiple-value-list (sb-ext:%simd-pack-512-singles *pack*))
'(1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0 1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0)))))
(when tmp-fasl (delete-file tmp-fasl))
(delete-file *tmp-filename*))))
(with-test (:name :load-simd-pack-512-double)
(with-open-file (s *tmp-filename*
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(print '(setq *pack* (sb-ext:%make-simd-pack-512-double 1d0 2d0 3d0 4d0 5d0 6d0 7d0 8d0)) s))
(let (tmp-fasl)
(unwind-protect
(progn
(setq tmp-fasl (compile-file *tmp-filename*))
(let ((*pack* nil))
(load tmp-fasl)
(assert (typep *pack* '(sb-ext:simd-pack-512 double-float)))
(assert (equal (multiple-value-list (sb-ext:%simd-pack-512-doubles *pack*))
'(1d0 2d0 3d0 4d0 5d0 6d0 7d0 8d0)))))
(when tmp-fasl (delete-file tmp-fasl))
(delete-file *tmp-filename*))))
(with-test (:name :spilling)
(checked-compile-and-assert
()
`(lambda (x y)
(declare ((sb-ext:simd-pack-512 (unsigned-byte 64)) x))
(eval y)
(list (sb-kernel:%simd-pack-512-0 x)
(sb-kernel:%simd-pack-512-1 x)
(sb-kernel:%simd-pack-512-2 x)
(sb-kernel:%simd-pack-512-3 x)
(sb-kernel:%simd-pack-512-4 x)
(sb-kernel:%simd-pack-512-5 x)
(sb-kernel:%simd-pack-512-6 x)
(sb-kernel:%simd-pack-512-7 x) y))
(((sb-ext:%make-simd-pack-512-ub64 1 2 3 4 5 6 7 8) 0) '(1 2 3 4 5 6 7 8 0) :test #'equal)))
(with-test (:name (simd-pack-512 subtypep :smoke))
(assert-tri-eq t t (subtypep '(simd-pack-512 (unsigned-byte 8)) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 (unsigned-byte 16)) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 (unsigned-byte 32)) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 (unsigned-byte 64)) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 (signed-byte 8)) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 (signed-byte 16)) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 (signed-byte 32)) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 (signed-byte 64)) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 single-float) 'simd-pack-512))
(assert-tri-eq t t (subtypep '(simd-pack-512 double-float) 'simd-pack-512))
(assert-tri-eq nil t (subtypep 'simd-pack-512 '(simd-pack-512 (unsigned-byte 64))))
(assert-tri-eq nil t (subtypep 'simd-pack-512 '(simd-pack-512 single-float)))
(assert-tri-eq nil t (subtypep 'simd-pack-512 '(simd-pack-512 double-float)))
(assert-tri-eq t t (subtypep '(simd-pack-512 (unsigned-byte 64))
'(or (simd-pack-512 (unsigned-byte 64)) (simd-pack-512 single-float))))
(assert-tri-eq t t (subtypep '(simd-pack-512 (unsigned-byte 64))
'(or (simd-pack-512 (unsigned-byte 64)) (simd-pack-512 double-float))))
(assert-tri-eq nil t (subtypep '(simd-pack-512 (unsigned-byte 64))
'(or (simd-pack-512 single-float) (simd-pack-512 double-float))))
(assert-tri-eq nil t (subtypep '(or (simd-pack-512 (unsigned-byte 64)) (simd-pack-512 single-float))
'(simd-pack-512 (unsigned-byte 64))))
(assert-tri-eq nil t (subtypep '(or (simd-pack-512 (unsigned-byte 64)) (simd-pack-512 double-float))
'(simd-pack-512 (unsigned-byte 64))))
(assert-tri-eq nil t (subtypep '(or (simd-pack-512 single-float) (simd-pack-512 double-float))
'(simd-pack-512 (unsigned-byte 64)))))
(with-test (:name (simd-pack-512 :ctype-unparse :smoke))
(flet ((unparsed (s) (sb-kernel:type-specifier (sb-kernel:specifier-type s))))
(assert (equal (unparsed 'simd-pack-512) 'simd-pack-512))
(assert (equal (unparsed '(simd-pack-512 (unsigned-byte 8))) '(simd-pack-512 (unsigned-byte 8))))
(assert (equal (unparsed '(simd-pack-512 (unsigned-byte 16))) '(simd-pack-512 (unsigned-byte 16))))
(assert (equal (unparsed '(simd-pack-512 (unsigned-byte 32))) '(simd-pack-512 (unsigned-byte 32))))
(assert (equal (unparsed '(simd-pack-512 (unsigned-byte 64))) '(simd-pack-512 (unsigned-byte 64))))
(assert (equal (unparsed '(simd-pack-512 (signed-byte 8))) '(simd-pack-512 (signed-byte 8))))
(assert (equal (unparsed '(simd-pack-512 (signed-byte 16))) '(simd-pack-512 (signed-byte 16))))
(assert (equal (unparsed '(simd-pack-512 (signed-byte 32))) '(simd-pack-512 (signed-byte 32))))
(assert (equal (unparsed '(simd-pack-512 (signed-byte 64))) '(simd-pack-512 (signed-byte 64))))
(assert (equal (unparsed '(simd-pack-512 single-float)) '(simd-pack-512 single-float)))
(assert (equal (unparsed '(simd-pack-512 double-float)) '(simd-pack-512 double-float)))
(assert (equal (unparsed '(or (simd-pack-512 (unsigned-byte 64)) (simd-pack-512 double-float)))
;; depends on *SIMD-PACK-ELEMENT-TYPES* order
'(or (simd-pack-512 double-float) (simd-pack-512 (unsigned-byte 64)))))
(assert (equal (unparsed '(or
(simd-pack-512 (unsigned-byte 8))
(simd-pack-512 (unsigned-byte 16))
(simd-pack-512 (unsigned-byte 32))
(simd-pack-512 (unsigned-byte 64))
(simd-pack-512 (signed-byte 8))
(simd-pack-512 (signed-byte 16))
(simd-pack-512 (signed-byte 32))
(simd-pack-512 (signed-byte 64))
(simd-pack-512 single-float)
(simd-pack-512 double-float)))
'simd-pack-512))))
(with-test (:name :simd-pack-512-type-errors)
;; Bignum overflow
(assert-error (sb-ext:%make-simd-pack-512-ub64
(1+ (ldb (byte 64 0) -1)) 0 0 0 0 0 0 0)
type-error)
;; Float mismatch
(assert-error (sb-ext:%make-simd-pack-512-single
1d0 0f0 0f0 0f0 0f0 0f0 0f0 0f0
0f0 0f0 0f0 0f0 0f0 0f0 0f0 0f0)
type-error))