From 1d61dea7ec205fac3cbf84bb0c0b164ec88a841b Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Wed, 5 Dec 2018 22:28:05 +0300 Subject: [PATCH] Add SIMD-PACK-256. --- NEWS | 4 + build-order.lisp-expr | 2 + make-config.sh | 2 +- package-data-list.lisp-expr | 58 +++- src/code/class.lisp | 6 + src/code/cross-type.lisp | 2 +- src/code/early-type.lisp | 25 +- src/code/fop.lisp | 15 +- src/code/late-type.lisp | 58 ++++ src/code/pred.lisp | 3 +- src/code/print.lisp | 36 +++ src/code/room.lisp | 5 +- src/code/stubs.lisp | 10 + src/code/target-type.lisp | 15 +- src/code/typep.lisp | 18 +- src/compiler/dump.lisp | 10 + src/compiler/early-assem.lisp | 4 +- src/compiler/generic/early-objdef.lisp | 7 +- src/compiler/generic/interr.lisp | 1 + src/compiler/generic/late-objdef.lisp | 1 + src/compiler/generic/late-type-vops.lisp | 2 + src/compiler/generic/objdef.lisp | 213 +++++++------ src/compiler/generic/primtype.lisp | 22 ++ src/compiler/generic/vm-fndb.lisp | 44 ++- src/compiler/generic/vm-typetran.lisp | 2 + src/compiler/ir1tran.lisp | 3 +- src/compiler/typetran.lisp | 16 + src/compiler/x86-64/avx2-insts.lisp | 32 +- src/compiler/x86-64/insts.lisp | 41 ++- src/compiler/x86-64/macros.lisp | 8 + src/compiler/x86-64/simd-pack-256.lisp | 375 +++++++++++++++++++++++ src/compiler/x86-64/vm.lisp | 57 +++- src/interpreter/checkfuns.lisp | 3 +- src/runtime/coreparse.c | 3 + tests/load.impure.lisp | 58 ---- tests/simd-pack-256.impure.lisp | 172 +++++++++++ tests/simd-pack.impure.lisp | 61 +++- 37 files changed, 1157 insertions(+), 237 deletions(-) create mode 100644 src/compiler/x86-64/simd-pack-256.lisp create mode 100644 tests/simd-pack-256.impure.lisp diff --git a/NEWS b/NEWS index fa852455b..56e25711e 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes relative to sbcl-1.4.14: + * enhancement: added AVX2 instructions on x86-64, which can be used with + SB-SIMD-PACK. + changes in sbcl-1.4.14 relative to sbcl-1.4.13: * enhancement: attempting to build on openbsd 6.0 or newer without the wxallowed mount option now results in a more useful error message. diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 9135e4c96..7f6a36d0b 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -506,6 +506,8 @@ ("src/compiler/target/float") #!+sb-simd-pack ("src/compiler/target/simd-pack") + #!+sb-simd-pack-256 + ("src/compiler/target/simd-pack-256") ("src/compiler/target/sap") ("src/compiler/target/system") ("src/compiler/target/char") diff --git a/make-config.sh b/make-config.sh index 90b62c772..b52e86334 100755 --- a/make-config.sh +++ b/make-config.sh @@ -688,7 +688,7 @@ elif [ "$sbcl_arch" = "x86-64" ]; then printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf printf ' :alien-callbacks :cycle-counter' >> $ltf printf ' :float-eql-vops :integer-eql-vop' >> $ltf - printf ' :sb-simd-pack :avx2' >> $ltf + printf ' :sb-simd-pack :sb-simd-pack-256 :avx2' >> $ltf printf ' :undefined-fun-restarts :call-symbol' >> $ltf case "$sbcl_os" in linux | darwin | *bsd) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 1fd84a315..c45df95ad 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -942,16 +942,28 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "SCHEDULE-TIMER" "UNSCHEDULE-TIMER" "LIST-ALL-TIMERS" ;; SIMD pack - #!+sb-simd-pack("SIMD-PACK" - "SIMD-PACK-P" - "%MAKE-SIMD-PACK-UB32" - "%MAKE-SIMD-PACK-UB64" - "%MAKE-SIMD-PACK-DOUBLE" - "%MAKE-SIMD-PACK-SINGLE" - "%SIMD-PACK-UB32S" - "%SIMD-PACK-UB64S" - "%SIMD-PACK-DOUBLES" - "%SIMD-PACK-SINGLES") + #!+sb-simd-pack + ("SIMD-PACK" + "SIMD-PACK-P" + "%MAKE-SIMD-PACK-UB32" + "%MAKE-SIMD-PACK-UB64" + "%MAKE-SIMD-PACK-DOUBLE" + "%MAKE-SIMD-PACK-SINGLE" + "%SIMD-PACK-UB32S" + "%SIMD-PACK-UB64S" + "%SIMD-PACK-DOUBLES" + "%SIMD-PACK-SINGLES") + #!+sb-simd-pack-256 + ("SIMD-PACK-256" + "SIMD-PACK-256-P" + "%MAKE-SIMD-PACK-256-UB32" + "%MAKE-SIMD-PACK-256-UB64" + "%MAKE-SIMD-PACK-256-DOUBLE" + "%MAKE-SIMD-PACK-256-SINGLE" + "%SIMD-PACK-256-UB32S" + "%SIMD-PACK-256-UB64S" + "%SIMD-PACK-256-DOUBLES" + "%SIMD-PACK-256-SINGLES") ;; versioning utility "ASSERT-VERSION->=" @@ -1593,6 +1605,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%MAKE-LIST" "%MAKE-RATIO" #!+sb-simd-pack "%MAKE-SIMD-PACK" + #!+sb-simd-pack-256 "%MAKE-SIMD-PACK-256" "%MAKE-STRUCTURE-INSTANCE" "%MAKE-STRUCTURE-INSTANCE-ALLOCATOR" "%MAP" "%MAP-FOR-EFFECT-ARITY-1" @@ -1650,9 +1663,14 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%SET-SYMBOL-HASH" "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT" "%SINH" "%SQRT" "%SXHASH-STRING" "%SXHASH-SIMPLE-STRING" - #!+sb-simd-pack("%SIMD-PACK-TAG" - "%SIMD-PACK-LOW" - "%SIMD-PACK-HIGH") + #!+sb-simd-pack + ("%SIMD-PACK-TAG" + "%SIMD-PACK-LOW" + "%SIMD-PACK-HIGH") + #!+sb-simd-pack-256 + ("%SIMD-PACK-256-TAG" + "%SIMD-PACK-256-0" "%SIMD-PACK-256-1" + "%SIMD-PACK-256-2" "%SIMD-PACK-256-3") "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH" "THE*" "%UNARY-ROUND" @@ -1891,6 +1909,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR" #!+sb-simd-pack "OBJECT-NOT-SIMD-PACK-ERROR" + #!+sb-simd-pack-256 + "OBJECT-NOT-SIMD-PACK-256-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-ERROR" @@ -2003,6 +2023,11 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "SIMD-PACK-TYPE" "SIMD-PACK-TYPE-ELEMENT-TYPE" "*SIMD-PACK-ELEMENT-TYPES*") + #!+sb-simd-pack-256("SIMD-PACK-256-SINGLE" + "SIMD-PACK-256-DOUBLE" + "SIMD-PACK-256-INT" + "SIMD-PACK-256-TYPE" + "SIMD-PACK-256-TYPE-ELEMENT-TYPE") "STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR" "STRING-FILL*" "STRUCTURE-CTOR-LAMBDA-PARTS" @@ -3091,6 +3116,13 @@ structure representations" "SIMD-PACK-LO-VALUE-SLOT" "SIMD-PACK-SIZE" "SIMD-PACK-WIDETAG") + #!+sb-simd-pack-256("SIMD-PACK-256-TAG-SLOT" + "SIMD-PACK-256-P0-SLOT" + "SIMD-PACK-256-P1-SLOT" + "SIMD-PACK-256-P2-SLOT" + "SIMD-PACK-256-P3-SLOT" + "SIMD-PACK-256-SIZE" + "SIMD-PACK-256-WIDETAG") #!-64-bit ("COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT") #!+64-bit diff --git a/src/code/class.lisp b/src/code/class.lisp index af0c23786..ff777f5f1 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -939,6 +939,12 @@ between the ~A definition and the ~A definition" :translation simd-pack :codes (#.sb-vm:simd-pack-widetag) :prototype-form (%make-simd-pack-ub64 42 42)) + #!+sb-simd-pack-256 + (simd-pack-256 + :translation simd-pack-256 + :codes (#.sb-vm:simd-pack-256-widetag) + :prototype-form ;; (%make-simd-pack-256-ub64 42 42 42 42) + (%make-simd-pack-ub64 42 42)) (real :translation real :inherits (number)) (float :translation float diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 55ef2c941..4594e7d11 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -112,7 +112,7 @@ sb-format::fmt-control #!+sb-eval sb!eval:interpreted-function #!+sb-fasteval sb!interpreter:interpreted-function - weak-pointer simd-pack)) + weak-pointer simd-pack simd-pack-256)) (setf (get symbol :cross-typep-hint) :certainly-nil)) ;;; The set of objects for which it's accurate to use the host's type system diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index a089692dc..ea85f44bd 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -721,6 +721,15 @@ :type (cons #||(member #.*simd-pack-element-types*) ||#) :read-only t)) +#!+sb-simd-pack-256 +(defstruct (simd-pack-256-type + (:include ctype (class-info (type-class-or-lose 'simd-pack-256))) + (:constructor %make-simd-pack-256-type (element-type)) + (:copier nil)) + (element-type (missing-arg) + :type (cons #||(member #.*simd-pack-element-types*) ||#) + :read-only t)) + #!+sb-simd-pack (defun make-simd-pack-type (element-type) (aver (neq element-type *wild-type*)) @@ -735,6 +744,19 @@ (when (csubtypep element-type (specifier-type pack-type)) (return (list pack-type))))))) +#!+sb-simd-pack-256 +(defun make-simd-pack-256-type (element-type) + (aver (neq element-type *wild-type*)) + (if (eq element-type *empty-type*) + *empty-type* + (%make-simd-pack-256-type + (dolist (pack-type *simd-pack-element-types* + (error "~S element type must be a subtype of ~ + ~{~/sb-impl:print-type-specifier/~#[~;, or ~ + ~:;, ~]~}." + 'simd-pack-256 *simd-pack-element-types*)) + (when (csubtypep element-type (specifier-type pack-type)) + (return (list pack-type))))))) ;;;; type utilities @@ -1017,7 +1039,8 @@ expansion happened." (built-in-classoid t) (classoid nil) ;; HAIRY is just an s-expression, so it's dumpable. Same for simd-pack - ((or named-type character-set-type hairy-type #!+sb-simd-pack simd-pack-type) + ((or named-type character-set-type hairy-type #!+sb-simd-pack simd-pack-type + #!+sb-simd-pack-256 simd-pack-256-type) t)))) (setf (get '!specifier-type :sb-cold-funcall-handler/for-value) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 965556e79..116334ab6 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -357,9 +357,18 @@ #!+sb-simd-pack (!define-fop 88 :not-host (fop-simd-pack) (with-fast-read-byte ((unsigned-byte 8) (fasl-input-stream)) - (%make-simd-pack (fast-read-s-integer 8) - (fast-read-u-integer 8) - (fast-read-u-integer 8)))) + (let ((tag (fast-read-s-integer 8))) + (cond #!+sb-simd-pack-256 + ((logbitp 2 tag) + (%make-simd-pack-256 (logand tag #b11) + (fast-read-u-integer 8) + (fast-read-u-integer 8) + (fast-read-u-integer 8) + (fast-read-u-integer 8))) + (t + (%make-simd-pack tag + (fast-read-u-integer 8) + (fast-read-u-integer 8))))))) ;;;; loading lists diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 13031c4d2..960c6fe70 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -3810,6 +3810,64 @@ used for a COMPLEX component.~:@>" *empty-type*))) (!define-superclasses simd-pack ((simd-pack)) !cold-init-forms)) + +#!+sb-simd-pack-256 +(progn + (!define-type-class simd-pack-256 :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-256 (&optional (element-type-spec '*)) + (if (eql element-type-spec '*) + (%make-simd-pack-256-type *simd-pack-element-types*) + (make-simd-pack-256-type (single-value-specifier-type element-type-spec)))) + + (!define-type-method (simd-pack-256 :negate) (type) + (let ((remaining (set-difference *simd-pack-element-types* + (simd-pack-256-type-element-type type))) + (not-simd-pack-256 (make-negation-type (specifier-type 'simd-pack-256)))) + (if remaining + (type-union not-simd-pack-256 (%make-simd-pack-256-type remaining)) + not-simd-pack-256))) + + (!define-type-method (simd-pack-256 :unparse) (type) + (let ((eltypes (simd-pack-256-type-element-type type))) + (cond ((equal eltypes *simd-pack-element-types*) + 'simd-pack-256) + ((= 1 (length eltypes)) + `(simd-pack-256 ,(first eltypes))) + (t + `(or ,@(mapcar (lambda (eltype) + `(simd-pack-256 ,eltype)) + eltypes)))))) + + (!define-type-method (simd-pack-256 :simple-=) (type1 type2) + (declare (type simd-pack-256-type type1 type2)) + (values + (null (set-exclusive-or (simd-pack-256-type-element-type type1) + (simd-pack-256-type-element-type type2))) + t)) + + (!define-type-method (simd-pack-256 :simple-subtypep) (type1 type2) + (declare (type simd-pack-256-type type1 type2)) + (subsetp (simd-pack-256-type-element-type type1) + (simd-pack-256-type-element-type type2))) + + (!define-type-method (simd-pack-256 :simple-union2) (type1 type2) + (declare (type simd-pack-256-type type1 type2)) + (%make-simd-pack-256-type (union (simd-pack-256-type-element-type type1) + (simd-pack-256-type-element-type type2)))) + + (!define-type-method (simd-pack-256 :simple-intersection2) (type1 type2) + (declare (type simd-pack-256-type type1 type2)) + (let ((intersection (intersection (simd-pack-256-type-element-type type1) + (simd-pack-256-type-element-type type2)))) + (if intersection + (%make-simd-pack-256-type intersection) + *empty-type*))) + + (!define-superclasses simd-pack-256 ((simd-pack-256)) !cold-init-forms)) ;;;; utilities shared between cross-compiler and target system diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 40db65a77..6cbffe351 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -142,6 +142,7 @@ (def-type-predicate-wrapper short-float-p) (def-type-predicate-wrapper single-float-p) #!+sb-simd-pack (def-type-predicate-wrapper simd-pack-p) + #!+sb-simd-pack-256 (def-type-predicate-wrapper simd-pack-256-p) (def-type-predicate-wrapper %instancep) (def-type-predicate-wrapper funcallable-instance-p) (def-type-predicate-wrapper symbolp) @@ -248,7 +249,7 @@ ((eq object nil) 'null) ((eq (symbol-package object) *keyword-package*) 'keyword) (t 'symbol))) - ((or array complex #!+sb-simd-pack simd-pack) + ((or array complex #!+sb-simd-pack simd-pack #!+sb-simd-pack-256 simd-pack-256) (let ((sb-kernel::*unparse-allow-negation* nil)) (declare (special sb-kernel::*unparse-allow-negation*)) ; forward ref (type-specifier (ctype-of object)))) diff --git a/src/code/print.lisp b/src/code/print.lisp index 47e95557c..9072e5f07 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1699,6 +1699,42 @@ variable: an unreadable object representing the error is printed instead.") 'simd-pack (split-num low 0) (split-num low 32) (split-num high 0) (split-num high 32)))))))))) + +#!+sb-simd-pack-256 +(defmethod print-object ((pack simd-pack-256) stream) + (cond ((and *print-readably* *read-eval*) + (multiple-value-bind (format maker extractor) + (etypecase pack + ((simd-pack-256 double-float) + (values "#.(~@{~S~^ ~})" + '%make-simd-pack-256-double #'%simd-pack-256-doubles)) + ((simd-pack-256 single-float) + (values "#.(~@{~S~^ ~})" + '%make-simd-pack-256-single #'%simd-pack-256-singles)) + (t + (values "#.(~S~@{ #X~16,'0X~})" + '%make-simd-pack-256-ub64 #'%simd-pack-256-ub64s))) + (multiple-value-call + #'format stream format maker (funcall extractor pack)))) + (*print-readably* + (print-not-readable-error pack stream)) + (t + (print-unreadable-object (pack stream) + (etypecase pack + ((simd-pack-256 double-float) + (multiple-value-call #'format stream "~S~@{ ~,13E~}" + 'simd-pack-256 + (%simd-pack-256-doubles pack))) + ((simd-pack-256 single-float) + (multiple-value-call #'format stream "~S~@{ ~,7E~}" + 'simd-pack-256 + (%simd-pack-256-singles pack))) + (t + (multiple-value-bind (p0 p1 p2 p3) + (%simd-pack-256-ub64s pack) + (format stream "~S~@{ ~16,'0X~}" + 'simd-pack-256 + p0 p1 p2 p3)))))))) ;;;; functions diff --git a/src/code/room.lisp b/src/code/room.lisp index 744c7d093..cdd04625b 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -1130,8 +1130,9 @@ We could try a few things to mitigate this: ;; and/or visit the slots of each simple-fun but not the fun per se. ) ,.(make-case '(or float (complex float) bignum - #+sb-simd-pack simd-pack - system-area-pointer)) ; nothing to do + #+sb-simd-pack simd-pack + #+sb-simd-pack-256 simd-pack-256 + system-area-pointer)) ; nothing to do ,.(make-case 'weak-pointer `(weak-pointer-value ,obj)) ,.(make-case 'ratio `(%numerator ,obj) `(%denominator ,obj)) ;; Visitor won't be invoked on (COMPLEX float) diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp index 7aa00e9b5..b6242a903 100644 --- a/src/code/stubs.lisp +++ b/src/code/stubs.lisp @@ -115,6 +115,16 @@ (%simd-pack-tag) (%simd-pack-low) (%simd-pack-high)) + #+sb-simd-pack-256 + (def* (%make-simd-pack-256 (tag p0 p1 p2 p3)) + (%make-simd-pack-256-single (a b c d e f g h)) + (%make-simd-pack-256-double (a b c d)) + (%make-simd-pack-256-ub64 (a b c d)) + (%simd-pack-256-tag) + (%simd-pack-256-0) + (%simd-pack-256-1) + (%simd-pack-256-2) + (%simd-pack-256-3)) #+sb-thread (def sb-vm::current-thread-offset-sap) (def current-sp ()) (def current-fp ()) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 925202bc8..e0dc8f150 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -34,7 +34,8 @@ member-type character-set-type built-in-classoid - #!+sb-simd-pack simd-pack-type) + #!+sb-simd-pack simd-pack-type + #!+sb-simd-pack-256 simd-pack-256-type) (values (%%typep obj type) t)) (array-type @@ -174,6 +175,18 @@ (if (<= 0 tag #.(1- (length *simd-pack-element-types*))) (1+ tag) 0)))) + #!+sb-simd-pack-256 + (simd-pack-256 + (let ((tag (%simd-pack-256-tag x))) + (svref (load-time-value + (coerce (cons (specifier-type 'simd-pack-256) + (mapcar (lambda (x) (specifier-type `(simd-pack-256 ,x))) + *simd-pack-element-types*)) + 'vector) + t) + (if (<= 0 tag #.(1- (length *simd-pack-element-types*))) + (1+ tag) + 0)))) (t (classoid-of x))))) diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 639393e49..b4807b810 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -152,14 +152,20 @@ (let* ((tag (%simd-pack-tag object)) (name (nth tag *simd-pack-element-types*))) (not (not (member name (simd-pack-type-element-type type))))))) + #!+sb-simd-pack-256 + (simd-pack-256-type + (and (simd-pack-256-p object) + (let* ((tag (%simd-pack-256-tag object)) + (name (nth tag *simd-pack-element-types*))) + (not (not (member name (simd-pack-256-type-element-type type))))))) (character-set-type (and (characterp object) - (let ((code (char-code object)) - (pairs (character-set-type-pairs type))) - (dolist (pair pairs nil) - (destructuring-bind (low . high) pair - (when (<= low code high) - (return t))))))) + (let ((code (char-code object)) + (pairs (character-set-type-pairs type))) + (dolist (pair pairs nil) + (destructuring-bind (low . high) pair + (when (<= low code high) + (return t))))))) (unknown-type ;; dunno how to do this ANSIly -- WHN 19990413 #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host") diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index ddd06f914..ea1577e51 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -373,6 +373,16 @@ (dump-integer-as-n-bytes (%simd-pack-low x) 8 file) (dump-integer-as-n-bytes (%simd-pack-high x) 8 file)) (equal-save-object x file)) + #!+(and (not (host-feature sb-xc-host)) sb-simd-pack-256) + (simd-pack-256 + (unless (equal-check-table x file) + (dump-fop 'fop-simd-pack file) + (dump-integer-as-n-bytes (logior (%simd-pack-256-tag x) 4) 8 file) + (dump-integer-as-n-bytes (%simd-pack-256-0 x) 8 file) + (dump-integer-as-n-bytes (%simd-pack-256-1 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)) + (equal-save-object x file)) (t ;; This probably never happens, since bad things tend to ;; be detected during IR1 conversion. diff --git a/src/compiler/early-assem.lisp b/src/compiler/early-assem.lisp index e675842d8..5080652d1 100644 --- a/src/compiler/early-assem.lisp +++ b/src/compiler/early-assem.lisp @@ -44,8 +44,8 @@ ;;; the maximum alignment we can guarantee given the object format. If ;;; the loader only loads objects 8-byte aligned, we can't do any -;;; better then that ourselves. -(defconstant max-alignment sb-vm:n-lowtag-bits) +;;; better than that ourselves. +(defconstant max-alignment 5) (deftype alignment () `(integer 0 ,max-alignment)) diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp index 0d9cb5f26..1b0bab783 100644 --- a/src/compiler/generic/early-objdef.lisp +++ b/src/compiler/generic/early-objdef.lisp @@ -208,8 +208,11 @@ unused01-widetag ; 5E 5E #!+sb-simd-pack simd-pack-widetag ; 65 65 - filler-widetag ; 62 69 62 69 - unused03-widetag ; 66 6D 66 6D + #!-(and sb-simd-pack avx2) + unused03-widetag ; 62 69 62 69 + #!+(and sb-simd-pack avx2) + simd-pack-256-widetag ; 62 69 62 69 + filler-widetag ; 66 6D 66 6D unused04-widetag ; 6A 71 6A 71 unused05-widetag ; 6E 75 6E 75 unused06-widetag ; 72 79 72 79 diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp index 457fcc712..c6ce11a22 100644 --- a/src/compiler/generic/interr.lisp +++ b/src/compiler/generic/interr.lisp @@ -152,6 +152,7 @@ ((complex double-float) object-not-complex-double-float) #!+long-float ((complex long-float) object-not-complex-long-float) #!+sb-simd-pack simd-pack + #!+sb-simd-pack-256 simd-pack-256 weak-pointer instance #!+sb-unicode diff --git a/src/compiler/generic/late-objdef.lisp b/src/compiler/generic/late-objdef.lisp index 08c46bc5b..1a75d290c 100644 --- a/src/compiler/generic/late-objdef.lisp +++ b/src/compiler/generic/late-objdef.lisp @@ -82,6 +82,7 @@ (no-tls-value-marker "immediate") #!+sb-simd-pack (simd-pack "unboxed") + #!+sb-simd-pack-256 (simd-pack-256 "unboxed") (filler "unboxed") (simple-array "boxed") diff --git a/src/compiler/generic/late-type-vops.lisp b/src/compiler/generic/late-type-vops.lisp index 9af3858e6..565019a69 100644 --- a/src/compiler/generic/late-type-vops.lisp +++ b/src/compiler/generic/late-type-vops.lisp @@ -252,6 +252,8 @@ #!+sb-simd-pack (!define-type-vop simd-pack-p (simd-pack-widetag)) +#!+sb-simd-pack-256 +(!define-type-vop simd-pack-256-p (simd-pack-256-widetag)) (!define-type-vop unbound-marker-p (unbound-marker-widetag)) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index c2d5f4673..860e23f92 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -413,117 +413,128 @@ but is in fact a problem for either, in theory. Consider: (lo-value :c-type "long" :type (unsigned-byte 64)) (hi-value :c-type "long" :type (unsigned-byte 64))) +(!define-primitive-object (simd-pack-256 + :lowtag other-pointer-lowtag + :widetag simd-pack-256-widetag) + (tag :ref-trans %simd-pack-256-tag + :attributes (movable flushable) + :type fixnum) + (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))) + ;;; this isn't actually a lisp object at all, it's a c structure that lives ;;; in c-land. However, we need sight of so many parts of it from Lisp that ;;; it makes sense to define it here anyway, so that the GENESIS machinery ;;; can take care of maintaining Lisp and C versions. (!define-primitive-object (thread :size primitive-thread-object-length) - ;; no_tls_value_marker is borrowed very briefly at thread startup to - ;; pass the address of initial-function into new_thread_trampoline. - ;; tls[0] = NO_TLS_VALUE_MARKER_WIDETAG because a the tls index slot - ;; of a symbol is initialized to zero - (no-tls-value-marker) - (os-thread :c-type "os_thread_t") - ;; This is the original address at which the memory was allocated, - ;; which may have different alignment then what we prefer to use. - ;; Kept here so that when the thread dies we can release the whole - ;; memory we reserved. - (os-address :c-type "void *" :pointer t) + ;; no_tls_value_marker is borrowed very briefly at thread startup to + ;; pass the address of initial-function into new_thread_trampoline. + ;; tls[0] = NO_TLS_VALUE_MARKER_WIDETAG because a the tls index slot + ;; of a symbol is initialized to zero + (no-tls-value-marker) + (os-thread :c-type "os_thread_t") + ;; This is the original address at which the memory was allocated, + ;; which may have different alignment then what we prefer to use. + ;; Kept here so that when the thread dies we can release the whole + ;; memory we reserved. + (os-address :c-type "void *" :pointer t) - ;; Keep these next six slots (alloc-region being figured in as 1 slot) - ;; near the beginning of the structure so that x86[-64] assembly code - ;; can use single-byte displacements from thread-base-tn. - ;; Doing so reduces code size for allocation sequences and special variable - ;; manipulations by fixing their TLS offsets to be < 2^7, the largest - ;; aligned displacement fitting in a signed byte. - ;; - ;; Information for constructing deterministic consing profile. - (profile-data :c-type "uword_t *" :pointer t) - #!+gencgc (alloc-region :c-type "struct alloc_region" :length 4) - #!+sb-thread (pseudo-atomic-bits #!+(or x86 x86-64) :special #!+(or x86 x86-64) *pseudo-atomic-bits*) - ;; next two not used in C, but this wires the TLS offsets to small values - #!+(and x86-64 sb-thread) - (current-catch-block :special *current-catch-block*) - #!+(and x86-64 sb-thread) - (current-unwind-protect-block :special *current-unwind-protect-block*) - (alien-stack-pointer :c-type "lispobj *" :pointer t - :special *alien-stack-pointer*) - (binding-stack-pointer :c-type "lispobj *" :pointer t - :special *binding-stack-pointer*) - (stepping) - ;; END of slots to keep near the beginning. + ;; Keep these next six slots (alloc-region being figured in as 1 slot) + ;; near the beginning of the structure so that x86[-64] assembly code + ;; can use single-byte displacements from thread-base-tn. + ;; Doing so reduces code size for allocation sequences and special variable + ;; manipulations by fixing their TLS offsets to be < 2^7, the largest + ;; aligned displacement fitting in a signed byte. + ;; + ;; Information for constructing deterministic consing profile. + (profile-data :c-type "uword_t *" :pointer t) + #!+gencgc (alloc-region :c-type "struct alloc_region" :length 4) + #!+sb-thread (pseudo-atomic-bits #!+(or x86 x86-64) :special #!+(or x86 x86-64) *pseudo-atomic-bits*) + ;; next two not used in C, but this wires the TLS offsets to small values + #!+(and x86-64 sb-thread) + (current-catch-block :special *current-catch-block*) + #!+(and x86-64 sb-thread) + (current-unwind-protect-block :special *current-unwind-protect-block*) + (alien-stack-pointer :c-type "lispobj *" :pointer t + :special *alien-stack-pointer*) + (binding-stack-pointer :c-type "lispobj *" :pointer t + :special *binding-stack-pointer*) + (stepping) + ;; END of slots to keep near the beginning. - ;; TODO: these slots should be accessible using (SIGNED-BYTE 8) displacement - ;; from the thread base. We've nearly exhausted small positive indices - ;; so the slots will have to precede 'struct thread' in memory. - (varyobj-space-addr) - (varyobj-card-count) - (varyobj-card-marks) - (dynspace-addr) - (dynspace-card-count) - (dynspace-pte-base) + ;; TODO: these slots should be accessible using (SIGNED-BYTE 8) displacement + ;; from the thread base. We've nearly exhausted small positive indices + ;; so the slots will have to precede 'struct thread' in memory. + (varyobj-space-addr) + (varyobj-card-count) + (varyobj-card-marks) + (dynspace-addr) + (dynspace-card-count) + (dynspace-pte-base) - ;; These aren't accessed (much) from Lisp, so don't really care - ;; if it takes a 4-byte displacement. - (alien-stack-start :c-type "lispobj *" :pointer t) - (binding-stack-start :c-type "lispobj *" :pointer t - :special *binding-stack-start*) + ;; These aren't accessed (much) from Lisp, so don't really care + ;; if it takes a 4-byte displacement. + (alien-stack-start :c-type "lispobj *" :pointer t) + (binding-stack-start :c-type "lispobj *" :pointer t + :special *binding-stack-start*) - #!+(and sb-thread (not sb-safepoint)) - (state-sem :c-type "os_sem_t *" :pointer t) - #!+(and sb-thread (not sb-safepoint)) - (state-not-running-sem :c-type "os_sem_t *" :pointer t) - #!+(and sb-thread (not sb-safepoint)) - (state-not-running-waitcount :c-type "int" :length 1) - #!+(and sb-thread (not sb-safepoint)) - (state-not-stopped-sem :c-type "os_sem_t *" :pointer t) - #!+(and sb-thread (not sb-safepoint)) - (state-not-stopped-waitcount :c-type "int" :length 1) - (control-stack-start :c-type "lispobj *" :pointer t - :special *control-stack-start*) - (control-stack-end :c-type "lispobj *" :pointer t - :special *control-stack-end*) - (control-stack-guard-page-protected) - #!+win32 (private-events :c-type "struct private_events" :length 2) - (this :c-type "struct thread *" :pointer t) - (prev :c-type "struct thread *" :pointer t) - (next :c-type "struct thread *" :pointer t) - ;; starting, running, suspended, dead - (state :c-type "lispobj") + #!+(and sb-thread (not sb-safepoint)) + (state-sem :c-type "os_sem_t *" :pointer t) + #!+(and sb-thread (not sb-safepoint)) + (state-not-running-sem :c-type "os_sem_t *" :pointer t) + #!+(and sb-thread (not sb-safepoint)) + (state-not-running-waitcount :c-type "int" :length 1) + #!+(and sb-thread (not sb-safepoint)) + (state-not-stopped-sem :c-type "os_sem_t *" :pointer t) + #!+(and sb-thread (not sb-safepoint)) + (state-not-stopped-waitcount :c-type "int" :length 1) + (control-stack-start :c-type "lispobj *" :pointer t + :special *control-stack-start*) + (control-stack-end :c-type "lispobj *" :pointer t + :special *control-stack-end*) + (control-stack-guard-page-protected) + #!+win32 (private-events :c-type "struct private_events" :length 2) + (this :c-type "struct thread *" :pointer t) + (prev :c-type "struct thread *" :pointer t) + (next :c-type "struct thread *" :pointer t) + ;; starting, running, suspended, dead + (state :c-type "lispobj") - #!+x86 (tls-cookie) ; LDT index - (interrupt-data :c-type "struct interrupt_data *" - :pointer t) - ;; For various reasons related to pseudo-atomic and interrupt - ;; handling, we need to know if the machine context is in Lisp code - ;; or not. On non-threaded targets, this is a global variable in - ;; the runtime, but it's clearly a per-thread value. - #!+sb-thread - (foreign-function-call-active :c-type "boolean") - ;; Same as above for the location of the current control stack frame. - #!+(and sb-thread (not (or x86 x86-64))) - (control-frame-pointer :c-type "lispobj *") - ;; Same as above for the location of the current control stack - ;; pointer. This is also used on threaded x86oids to allow LDB to - ;; print an approximation of the CSP as needed. - #!+sb-thread - (control-stack-pointer :c-type "lispobj *") - #!+mach-exception-handler - (mach-port-name :c-type "mach_port_name_t") - ;; Context base pointer for running on top of system libraries built using - ;; -fomit-frame-pointer. Currently truly required and implemented only - ;; for (and win32 x86-64), but could be generalized to other platforms if - ;; needed: - #!+win32 (carried-base-pointer :c-type "os_context_register_t") - #!+sb-safepoint (csp-around-foreign-call :c-type "lispobj *") - #!+win32 (synchronous-io-handle-and-flag :c-type "HANDLE" :length 1) - #!+(and sb-safepoint-strictly (not win32)) - (sprof-alloc-region :c-type "struct alloc_region" :length 4) - ;; The following slot's existence must NOT be conditional on #+msan - #!+x86-64 (msan-param-tls) ; = &__msan_param_tls - ;; function-layout is needed for closure creation. it's constant, - ;; but we need somewhere to read it from. - #!+(and immobile-space 64-bit sb-thread) (function-layout)) + #!+x86 (tls-cookie) ; LDT index + (interrupt-data :c-type "struct interrupt_data *" + :pointer t) + ;; For various reasons related to pseudo-atomic and interrupt + ;; handling, we need to know if the machine context is in Lisp code + ;; or not. On non-threaded targets, this is a global variable in + ;; the runtime, but it's clearly a per-thread value. + #!+sb-thread + (foreign-function-call-active :c-type "boolean") + ;; Same as above for the location of the current control stack frame. + #!+(and sb-thread (not (or x86 x86-64))) + (control-frame-pointer :c-type "lispobj *") + ;; Same as above for the location of the current control stack + ;; pointer. This is also used on threaded x86oids to allow LDB to + ;; print an approximation of the CSP as needed. + #!+sb-thread + (control-stack-pointer :c-type "lispobj *") + #!+mach-exception-handler + (mach-port-name :c-type "mach_port_name_t") + ;; Context base pointer for running on top of system libraries built using + ;; -fomit-frame-pointer. Currently truly required and implemented only + ;; for (and win32 x86-64), but could be generalized to other platforms if + ;; needed: + #!+win32 (carried-base-pointer :c-type "os_context_register_t") + #!+sb-safepoint (csp-around-foreign-call :c-type "lispobj *") + #!+win32 (synchronous-io-handle-and-flag :c-type "HANDLE" :length 1) + #!+(and sb-safepoint-strictly (not win32)) + (sprof-alloc-region :c-type "struct alloc_region" :length 4) + ;; The following slot's existence must NOT be conditional on #+msan + #!+x86-64 (msan-param-tls) ; = &__msan_param_tls + ;; function-layout is needed for closure creation. it's constant, + ;; but we need somewhere to read it from. + #!+(and immobile-space 64-bit sb-thread) (function-layout)) ;;; Compute the smallest TLS index that will be assigned to a special variable ;;; that does not map onto a thread slot. diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index c1826aac3..1ee031343 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -102,6 +102,16 @@ :type (simd-pack integer)) (!def-primitive-type-alias simd-pack '(:or simd-pack-single simd-pack-double simd-pack-int))) +#!+sb-simd-pack-256 +(progn + (!def-primitive-type simd-pack-256-single (single-avx2-reg descriptor-reg) + :type (simd-pack-256 single-float)) + (!def-primitive-type simd-pack-256-double (double-avx2-reg descriptor-reg) + :type (simd-pack-256 double-float)) + (!def-primitive-type simd-pack-256-int (int-avx2-reg descriptor-reg) + :type (simd-pack-256 integer)) + (!def-primitive-type-alias simd-pack-256 + '(:or simd-pack-256-single simd-pack-256-double simd-pack-256-int))) ;;; primitive other-pointer array types (/show0 "primtype.lisp 96") @@ -386,12 +396,24 @@ (exactly simd-pack-single)) ((member 'double-float eltypes) (exactly simd-pack-double))))) + #!+sb-simd-pack-256 + (simd-pack-256-type + (let ((eltypes (simd-pack-256-type-element-type type))) + (cond ((member 'integer eltypes) + (exactly simd-pack-256-int)) + ((member 'single-float eltypes) + (exactly simd-pack-256-single)) + ((member 'double-float eltypes) + (exactly simd-pack-256-double))))) (built-in-classoid (case (classoid-name type) #!+sb-simd-pack ;; Can't tell what specific type; assume integers. (simd-pack (exactly simd-pack-int)) + #!+sb-simd-pack-256 + (simd-pack-256 + (exactly simd-pack-256-int)) ((complex function system-area-pointer weak-pointer) (values (primitive-type-or-lose (classoid-name type)) t)) (cons-type diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index c6abf8ada..3d05919e3 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -310,12 +310,52 @@ (values double-float double-float) (flushable movable foldable))) +#!+sb-simd-pack-256 +(progn + (defknown simd-pack-256-p (t) boolean (foldable movable flushable)) + (defknown %simd-pack-256-tag (simd-pack-256) fixnum (movable flushable)) + (defknown %make-simd-pack-256 (fixnum (unsigned-byte 64) (unsigned-byte 64) + (unsigned-byte 64) (unsigned-byte 64)) + simd-pack-256 + (flushable movable foldable)) + (defknown %make-simd-pack-256-double (double-float double-float double-float double-float) + (simd-pack-256 double-float) + (flushable movable foldable)) + (defknown %make-simd-pack-256-single (single-float single-float single-float single-float + single-float single-float single-float single-float) + (simd-pack-256 single-float) + (flushable movable foldable)) + (defknown %make-simd-pack-256-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)) + (simd-pack-256 integer) + (flushable movable foldable)) + (defknown %make-simd-pack-256-ub64 ((unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64)) + (simd-pack-256 integer) + (flushable movable foldable)) + (defknown (%simd-pack-256-0 %simd-pack-256-1 %simd-pack-256-2 %simd-pack-256-3) (simd-pack-256) + (unsigned-byte 64) + (flushable movable foldable)) + (defknown %simd-pack-256-ub32s (simd-pack-256) + (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)) + (flushable movable foldable)) + (defknown %simd-pack-256-ub64s (simd-pack-256) + (values (unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64)) + (flushable movable foldable)) + (defknown %simd-pack-256-singles (simd-pack-256) + (values single-float single-float single-float single-float + single-float single-float single-float single-float) + (flushable movable foldable)) + (defknown %simd-pack-256-doubles (simd-pack-256) + (values double-float double-float double-float double-float) + (flushable movable foldable))) + ;;;; threading (defknown (dynamic-space-free-pointer binding-stack-pointer-sap control-stack-pointer-sap) () - system-area-pointer - (flushable)) + system-area-pointer + (flushable)) (defknown ensure-symbol-tls-index (symbol) (and fixnum unsigned-byte)) diff --git a/src/compiler/generic/vm-typetran.lisp b/src/compiler/generic/vm-typetran.lisp index 753222b06..b00653aed 100644 --- a/src/compiler/generic/vm-typetran.lisp +++ b/src/compiler/generic/vm-typetran.lisp @@ -106,6 +106,8 @@ (define-type-predicate signed-byte-64-p (signed-byte 64)) #!+sb-simd-pack (define-type-predicate simd-pack-p simd-pack) +#!+sb-simd-pack-256 +(define-type-predicate simd-pack-256-p simd-pack-256) (define-type-predicate vector-nil-p (vector nil)) (define-type-predicate weak-pointer-p weak-pointer) (define-type-predicate code-component-p code-component) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index a80722232..44642c36c 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -322,7 +322,8 @@ (typep value '(or #-sb-xc-host - (or unboxed-array #!+sb-simd-pack simd-pack) + (or unboxed-array #!+sb-simd-pack simd-pack + #!+sb-simd-pack-256 simd-pack-256) #+sb-xc-host (and array (not (array t))) symbol diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index b4916ad20..83ec6fc7a 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -596,6 +596,19 @@ for index = (position type *simd-pack-element-types*) collect `(eql ,n-tag ,index)))))))) +#!+sb-simd-pack-256 +(defun source-transform-simd-pack-256-typep (object type) + (if (type= type (specifier-type 'simd-pack-256)) + `(simd-pack-256-p ,object) + (let ((n-tag (gensym "TAG"))) + `(and + (simd-pack-256-p ,object) + (let ((,n-tag (%simd-pack-256-tag ,object))) + (or ,@(loop + for type in (simd-pack-256-type-element-type type) + for index = (position type *simd-pack-element-types*) + collect `(eql ,n-tag ,index)))))))) + ;;; Return the predicate and type from the most specific entry in ;;; *TYPE-PREDICATES* that is a supertype of TYPE. (defun find-supertype-predicate (type) @@ -1006,6 +1019,9 @@ #!+sb-simd-pack (simd-pack-type (source-transform-simd-pack-typep object ctype)) + #!+sb-simd-pack-256 + (simd-pack-256-type + (source-transform-simd-pack-256-typep object ctype)) (t nil)) `(%typep ,object ',type)) (values nil t)))) diff --git a/src/compiler/x86-64/avx2-insts.lisp b/src/compiler/x86-64/avx2-insts.lisp index 4a771db52..93a6ded82 100644 --- a/src/compiler/x86-64/avx2-insts.lisp +++ b/src/compiler/x86-64/avx2-insts.lisp @@ -230,8 +230,9 @@ (reg-7-p (cond ((ea-p thing) (let ((base (ea-base thing))) - (when (and base (neq base rip-tn)) - (reg-id (tn-reg base))))) + (if (and base (neq base rip-tn)) + (reg-id (tn-reg base)) + 0))) ((register-p thing) (reg-id thing)) (0))))) @@ -242,11 +243,11 @@ (let ((vvvv (if vvvv (reg-id-num (reg-id vvvv)) 0))) - (if (and (= 0 x w b) - (= opcode-prefix #x0F)) - (emit-two-byte-vex segment r vvvv l prefix) - (emit-three-byte-vex segment r x b opcode-prefix - w vvvv l prefix))))) + (if (and (= 0 x w b) + (= opcode-prefix #x0F)) + (emit-two-byte-vex segment r vvvv l prefix) + (emit-three-byte-vex segment r x b opcode-prefix + w vvvv l prefix))))) (defun emit-avx2-inst (segment thing reg prefix opcode &key (remaining-bytes 0) @@ -637,10 +638,10 @@ `(aver (not (register-p ,(if nds 'src2 'src))))) - (emit-avx2-inst segment dst - ,(if nds - 'src2 - 'src) + (emit-avx2-inst segment ,(if nds + 'src2 + 'src) + dst ,prefix ,opcode-from :opcode-prefix ,opcode-prefix ,@(and nds @@ -651,8 +652,8 @@ ,(when force-to-mem `(aver (not (register-p dst)))) (emit-avx2-inst segment - src - dst ,prefix ,opcode-to + dst src + ,prefix ,opcode-to :opcode-prefix ,opcode-prefix :l ,l)))))))) ;; direction bit? @@ -694,10 +695,10 @@ (flet ((move-ymm<->gpr (segment dst src w) (cond ((xmm-register-p dst) - (emit-avx2-inst segment dst src #x66 #x6e :l 0 :w w)) + (emit-avx2-inst segment src dst #x66 #x6e :l 0 :w w)) (t (aver (xmm-register-p src)) - (emit-avx2-inst segment src dst #x66 #x7e :l 0 :w w))))) + (emit-avx2-inst segment dst src #x66 #x7e :l 0 :w w))))) (define-instruction vmovd (segment dst src) (:emitter (move-ymm<->gpr segment dst src 0)) . #.(append (avx2-inst-printer-list 'ymm-ymm/mem #x66 #x6e @@ -738,7 +739,6 @@ :more-fields `((imm nil :type 'imm-byte)) :printer `(:name :tab reg ", " vvvv ", " reg/mem ", " imm)) (:emitter - (aver (and (xmm-register-p dst) (xmm-register-p src) (not (xmm-register-p src2)))) (emit-avx2-inst segment src2 dst ,prefix ,op :opcode-prefix ,op-prefix :vvvv src diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp index 3563e5ea6..111c7f93d 100644 --- a/src/compiler/x86-64/insts.lisp +++ b/src/compiler/x86-64/insts.lisp @@ -19,6 +19,8 @@ ea-p ea-base ea-index size-nbyte ea make-ea ea-disp rip-relative-ea) "SB-VM") ;; Imports from SB-VM into this package + #!+sb-simd-pack-256 + (import '(sb-vm::int-avx2-reg sb-vm::double-avx2-reg sb-vm::single-avx2-reg)) (import '(sb-vm::tn-reg sb-vm::reg-name sb-vm::frame-byte-offset sb-vm::rip-tn sb-vm::rbp-tn #!+avx2 sb-vm::avx2-reg @@ -75,7 +77,8 @@ (:word 2) (:dword 4) (:qword 8) - (:oword 16))) + (:oword 16) + (:hword 32))) (defun is-size-p (arg) (member arg '(:byte :word :dword :qword))) @@ -1222,7 +1225,11 @@ ((eq (sb-name (sc-sb (tn-sc operand))) 'registers) (tn-reg operand)) #!+avx2 - ((eq (sc-name (tn-sc operand)) 'avx2-reg) + ((memq (sc-name (tn-sc operand)) + '(avx2-reg + int-avx2-reg + double-avx2-reg + single-avx2-reg)) (get-avx2 (tn-offset operand))) ((eq (sb-name (sc-sb (tn-sc operand))) 'float-registers) (get-fpr (tn-offset operand))) @@ -3376,7 +3383,14 @@ (simd-pack (setq constant (list :sse (logior (%simd-pack-low first) - (ash (%simd-pack-high first) 64)))))))) + (ash (%simd-pack-high first) 64))))) + #!+sb-simd-pack-256 + (simd-pack-256 + (setq constant + (list :avx2 (logior (%simd-pack-256-0 first) + (ash (%simd-pack-256-1 first) 64) + (ash (%simd-pack-256-2 first) 128) + (ash (%simd-pack-256-3 first) 192)))))))) (destructuring-bind (type value) constant (ecase type ((:byte :word :dword :qword) @@ -3406,16 +3420,19 @@ (single-float-bits (realpart value))))))) ((:oword :sse) (aver (integerp value)) - (cons :oword value)) + (cons :oword value)) + ((:hword :avx2) + (aver (integerp value)) + (cons :hword value)) ((:complex-double-float) - (aver (typep value '(complex double-float))) - (cons :oword - (logior (ash (double-float-high-bits (imagpart value)) 96) - (ash (double-float-low-bits (imagpart value)) 64) - (ash (ldb (byte 32 0) - (double-float-high-bits (realpart value))) - 32) - (double-float-low-bits (realpart value)))))))) + (aver (typep value '(complex double-float))) + (cons :oword + (logior (ash (double-float-high-bits (imagpart value)) 96) + (ash (double-float-low-bits (imagpart value)) 64) + (ash (ldb (byte 32 0) + (double-float-high-bits (realpart value))) + 32) + (double-float-low-bits (realpart value)))))))) (defun inline-constant-value (constant) (declare (ignore constant)) ; weird! diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index 17e83a9f4..d7a374d20 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -52,6 +52,14 @@ ((single-sse-reg double-sse-reg) (aver (xmm-tn-p src)) (inst movaps dst src)) + #!+sb-simd-pack-256 + ((int-avx2-reg avx2-reg) + (aver (xmm-tn-p src)) + (inst vmovdqa dst src)) + #!+sb-simd-pack-256 + ((single-avx2-reg double-avx2-reg) + (aver (xmm-tn-p src)) + (inst vmovaps dst src)) (t (inst mov dst src))))) diff --git a/src/compiler/x86-64/simd-pack-256.lisp b/src/compiler/x86-64/simd-pack-256.lisp new file mode 100644 index 000000000..e6bdc560c --- /dev/null +++ b/src/compiler/x86-64/simd-pack-256.lisp @@ -0,0 +1,375 @@ +;;;; AVX2 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") + +(defun float-avx2-p (tn) + (sc-is tn single-avx2-reg single-avx2-stack single-avx2-immediate + double-avx2-reg double-avx2-stack double-avx2-immediate)) +(defun int-avx2-p (tn) + (sc-is tn int-avx2-reg int-avx2-stack int-avx2-immediate)) + +#+sb-xc-host +(progn ; the host compiler will complain about absence of these + (defun %simd-pack-256-0 (x) (error "Called %SIMD-PACK-256-0 ~S" x)) + (defun %simd-pack-256-1 (x) (error "Called %SIMD-PACK-256-1 ~S" x)) + (defun %simd-pack-256-2 (x) (error "Called %SIMD-PACK-256-2 ~S" x)) + (defun %simd-pack-256-3 (x) (error "Called %SIMD-PACK-256-3 ~S" x))) + +(define-move-fun (load-int-avx2-immediate 1) (vop x y) + ((int-avx2-immediate) (int-avx2-reg)) + (let* ((x (tn-value x)) + (p0 (%simd-pack-256-0 x)) + (p1 (%simd-pack-256-1 x)) + (p2 (%simd-pack-256-2 x)) + (p3 (%simd-pack-256-3 x))) + (cond ((= p0 p1 p2 p3 0) + (inst pxor y y)) + ((= p0 p1 p2 p3 (ldb (byte 64 0) -1)) + ;; don't think this is recognized as dependency breaking... + (inst vpcmpeqd y y)) + (t + (inst vmovdqu y (register-inline-constant x)))))) + +(define-move-fun (load-float-avx2-immediate 1) (vop x y) + ((single-avx2-immediate double-avx2-immediate) + (single-avx2-reg double-avx2-reg)) + (let* ((x (tn-value x)) + (p0 (%simd-pack-256-0 x)) + (p1 (%simd-pack-256-1 x)) + (p2 (%simd-pack-256-2 x)) + (p3 (%simd-pack-256-3 x))) + (cond ((= p0 p1 p2 p3 0) + (inst vxorps y y)) + ((= p0 p1 p2 p3 (ldb (byte 64 0) -1)) + (inst vpcmpeqd y y y)) + (t + (inst vmovups y (register-inline-constant x)))))) + +(define-move-fun (load-int-avx2 2) (vop x y) + ((int-avx2-stack) (int-avx2-reg)) + (inst vmovdqu y (ea-for-sse-stack x))) + +(define-move-fun (load-float-avx2 2) (vop x y) + ((single-avx2-stack double-avx2-stack) (single-avx2-reg double-avx2-reg)) + (inst vmovups y (ea-for-sse-stack x))) + +(define-move-fun (store-int-avx2 2) (vop x y) + ((int-avx2-reg) (int-avx2-stack)) + (inst vmovdqu (ea-for-sse-stack y) x)) + +(define-move-fun (store-float-avx2 2) (vop x y) + ((double-avx2-reg single-avx2-reg) (double-avx2-stack single-avx2-stack)) + (inst vmovups (ea-for-sse-stack y) x)) + +(define-vop (avx2-move) + (:args (x :scs (single-avx2-reg double-avx2-reg int-avx2-reg) + :target y + :load-if (not (location= x y)))) + (:results (y :scs (single-avx2-reg double-avx2-reg int-avx2-reg) + :load-if (not (location= x y)))) + (:note "AVX2 move") + (:generator 0 + (move y x))) +(define-move-vop avx2-move :move + (int-avx2-reg single-avx2-reg double-avx2-reg) + (int-avx2-reg single-avx2-reg double-avx2-reg)) + +(define-vop (move-from-avx2) + (:args (x :scs (single-avx2-reg double-avx2-reg int-avx2-reg))) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "AVX2 to pointer coercion") + (:generator 13 + (fixed-alloc y simd-pack-256-widetag simd-pack-256-size node) + ;; see *simd-pack-element-types* + (storew (fixnumize + (sc-case x + (single-avx2-reg 1) + (double-avx2-reg 2) + (int-avx2-reg 0) + (t 0))) + y simd-pack-256-tag-slot other-pointer-lowtag) + (let ((ea (make-ea-for-object-slot + y simd-pack-256-p0-slot other-pointer-lowtag))) + (if (float-avx2-p x) + (inst vmovups ea x) + (inst vmovdqu ea x))))) +(define-move-vop move-from-avx2 :move + (int-avx2-reg single-avx2-reg double-avx2-reg) (descriptor-reg)) + +(define-vop (move-to-avx2) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (int-avx2-reg double-avx2-reg single-avx2-reg))) + (:note "pointer to AVX2 coercion") + (:generator 2 + (let ((ea (make-ea-for-object-slot x simd-pack-256-p0-slot other-pointer-lowtag))) + (if (float-avx2-p y) + (inst vmovups y ea) + (inst vmovdqu y ea))))) + +(define-move-vop move-to-avx2 :move + (descriptor-reg) + (int-avx2-reg double-avx2-reg single-avx2-reg)) + +(define-vop (move-avx2-arg) + (:args (x :scs (int-avx2-reg double-avx2-reg single-avx2-reg) :target y) + (fp :scs (any-reg) + :load-if (not (sc-is y int-avx2-reg double-avx2-reg single-avx2-reg)))) + (:results (y)) + (:note "AVX2 argument move") + (:generator 4 + (sc-case y + ((int-avx2-reg double-avx2-reg single-avx2-reg) + (unless (location= x y) + (if (or (float-avx2-p x) + (float-avx2-p y)) + (inst vmovups y x) + (inst vmovdqu y x)))) + ((int-avx2-stack double-avx2-stack single-avx2-stack) + (if (float-avx2-p x) + (inst vmovups (ea-for-sse-stack y fp) x) + (inst vmovdqu (ea-for-sse-stack y fp) x)))))) +(define-move-vop move-avx2-arg :move-arg + (int-avx2-reg double-avx2-reg single-avx2-reg descriptor-reg) + (int-avx2-reg double-avx2-reg single-avx2-reg)) + +(define-move-vop move-arg :move-arg + (int-avx2-reg double-avx2-reg single-avx2-reg) + (descriptor-reg)) + + +(define-vop (%simd-pack-256-0) + (:translate %simd-pack-256-0) + (:args (x :scs (int-avx2-reg double-avx2-reg single-avx2-reg))) + (:arg-types simd-pack-256) + (:results (dst :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 3 + (inst vmovq dst x))) + +(define-vop (%simd-pack-256-1) + (:translate %simd-pack-256-1) + (:args (x :scs (int-avx2-reg double-avx2-reg single-avx2-reg))) + (:arg-types simd-pack-256) + (:results (dst :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 3 + (inst vpextrq dst x 1))) + +(define-vop (%simd-pack-256-2) + (:translate %simd-pack-256-2) + (:args (x :scs (int-avx2-reg double-avx2-reg single-avx2-reg))) + (:arg-types simd-pack-256) + (:temporary (:sc avx2-reg :from (:argument 1)) tmp) + (:results (dst :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 3 + (inst vextracti128 tmp x 1) + (inst vmovq dst tmp))) + +(define-vop (%simd-pack-256-3) + (:translate %simd-pack-256-3) + (:args (x :scs (int-avx2-reg double-avx2-reg single-avx2-reg))) + (:arg-types simd-pack-256) + (:temporary (:sc avx2-reg :from (:argument 1)) tmp) + (:results (dst :scs (unsigned-reg))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 3 + (inst vextracti128 tmp x 1) + (inst vpextrq dst x 1))) + +(define-vop (%make-simd-pack-256) + (:translate %make-simd-pack-256) + (:policy :fast-safe) + (:args (tag :scs (any-reg)) + (p0 :scs (unsigned-reg)) + (p1 :scs (unsigned-reg)) + (p2 :scs (unsigned-reg)) + (p3 :scs (unsigned-reg))) + (:arg-types tagged-num unsigned-num unsigned-num unsigned-num unsigned-num) + (:results (dst :scs (descriptor-reg) :from :load)) + (:result-types t) + (:node-var node) + (:generator 13 + (fixed-alloc dst simd-pack-256-widetag simd-pack-256-size node) + ;; see *simd-pack-element-types* + (storew tag dst simd-pack-256-tag-slot other-pointer-lowtag) + (storew p0 dst simd-pack-256-p0-slot other-pointer-lowtag) + (storew p1 dst simd-pack-256-p1-slot other-pointer-lowtag) + (storew p2 dst simd-pack-256-p2-slot other-pointer-lowtag) + (storew p3 dst simd-pack-256-p3-slot other-pointer-lowtag))) + +(define-vop (%make-simd-pack-256-ub64) + (:translate %make-simd-pack-256-ub64) + (:policy :fast-safe) + (:args (p0 :scs (unsigned-reg)) + (p1 :scs (unsigned-reg)) + (p2 :scs (unsigned-reg)) + (p3 :scs (unsigned-reg))) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:temporary (:sc int-avx2-reg) tmp) + (:results (dst :scs (int-avx2-reg))) + (:result-types simd-pack-256-int) + (:generator 5 + (inst vmovq dst p0) + (inst vpinsrq dst dst p1 1) + (inst vmovq tmp p2) + (inst vpinsrq tmp tmp p3 1) + (inst vinserti128 dst dst tmp 1))) + +#-sb-xc-host +(declaim (inline %make-simd-pack-256-ub32)) +#-sb-xc-host +(defun %make-simd-pack-256-ub32 (p0 p1 p2 p3 p4 p5 p6 p7) + (declare (type (unsigned-byte 32) p0 p1 p2 p3 p4 p5 p6 p7)) + (%make-simd-pack-256-ub64 (logior p0 (ash p1 32)) + (logior p2 (ash p3 32)) + (logior p4 (ash p5 32)) + (logior p6 (ash p7 32)))) + +#-sb-xc-host +(progn + (declaim (inline %simd-pack-256-ub32s %simd-pack-256-ub64s)) + (defun %simd-pack-256-ub32s (pack) + (declare (type simd-pack-256 pack)) + (let ((p0 (%simd-pack-256-0 pack)) + (p1 (%simd-pack-256-1 pack)) + (p2 (%simd-pack-256-2 pack)) + (p3 (%simd-pack-256-3 pack))) + (values (ldb (byte 32 0) p0) (ash p0 -32) + (ldb (byte 32 0) p1) (ash p1 -32) + (ldb (byte 32 0) p2) (ash p2 -32) + (ldb (byte 32 0) p3) (ash p3 -32)))) + + (defun %simd-pack-256-ub64s (pack) + (declare (type simd-pack-256 pack)) + (values (%simd-pack-256-0 pack) + (%simd-pack-256-1 pack) + (%simd-pack-256-2 pack) + (%simd-pack-256-3 pack)))) + +(define-vop (%make-simd-pack-256-double) + (:translate %make-simd-pack-256-double) + (:policy :fast-safe) + (:args (p0 :scs (double-reg) :target dst) + (p1 :scs (double-reg)) + (p2 :scs (double-reg)) + (p3 :scs (double-reg))) + (:arg-types double-float double-float double-float double-float) + (:temporary (:sc int-avx2-reg) tmp) + (:results (dst :scs (double-avx2-reg) :from (:argument 0))) + (:result-types simd-pack-256-double) + (:generator 5 + (inst vunpcklpd dst p0 p1) + (inst vunpcklpd tmp p2 p3) + (inst vinsertf128 dst dst tmp 1))) + +(define-vop (%make-simd-pack-256-single) + (:translate %make-simd-pack-256-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) :target tmp) + (p5 :scs (single-reg)) + (p6 :scs (single-reg)) + (p7 :scs (single-reg))) + (:arg-types single-float single-float single-float single-float + single-float single-float single-float single-float) + (:temporary (:sc single-avx2-reg :from (:argument 3)) tmp) + (:results (dst :scs (single-avx2-reg) :from (:argument 0))) + (:result-types simd-pack-256-single) + (:generator 5 + (inst vinsertps dst p0 p1 (ash 1 4)) + (inst vinsertps dst dst p2 (ash 2 4)) + (inst vinsertps dst dst p3 (ash 3 4)) + (inst vinsertps tmp p4 p5 (ash 1 4)) + (inst vinsertps tmp tmp p6 (ash 2 4)) + (inst vinsertps tmp tmp p7 (ash 3 4)) + (inst vinsertf128 dst dst tmp 1))) + +(defknown %simd-pack-256-single-item + (simd-pack-256 (integer 0 7)) single-float (flushable)) + +(define-vop (%simd-pack-256-single-item) + (:args (x :scs (int-avx2-reg double-avx2-reg single-avx2-reg) + :target tmp)) + (:translate %simd-pack-256-single-item) + (:arg-types simd-pack-256 (:constant t)) + (:info index) + (:results (dst :scs (single-reg))) + (:result-types single-float) + (:temporary (:sc single-avx2-reg :from (:argument 0)) tmp) + (:policy :fast-safe) + (:generator 3 + (cond ((>= index 4) + (decf index 4) + (inst vextractf128 tmp x 1)) + (t + (move tmp x))) + (when (plusp index) + (inst vpsrldq tmp tmp (* 4 index))) + (inst vxorps dst dst dst) + (inst movss dst tmp))) + +#-sb-xc-host +(declaim (inline %simd-pack-256-singles)) +#-sb-xc-host +(defun %simd-pack-256-singles (pack) + (declare (type simd-pack-256 pack)) + (values (%simd-pack-256-single-item pack 0) + (%simd-pack-256-single-item pack 1) + (%simd-pack-256-single-item pack 2) + (%simd-pack-256-single-item pack 3) + (%simd-pack-256-single-item pack 4) + (%simd-pack-256-single-item pack 5) + (%simd-pack-256-single-item pack 6) + (%simd-pack-256-single-item pack 7))) + +(defknown %simd-pack-256-double-item + (simd-pack-256 (integer 0 3)) double-float (flushable)) + +(define-vop (%simd-pack-256-double-item) + (:translate %simd-pack-256-double-item) + (:args (x :scs (int-avx2-reg double-avx2-reg single-avx2-reg) + :target tmp)) + (:info index) + (:arg-types simd-pack-256 (:constant t)) + (:results (dst :scs (double-reg))) + (:result-types double-float) + (:temporary (:sc double-avx2-reg :from (:argument 0)) tmp) + (:policy :fast-safe) + (:generator 3 + (cond ((>= index 2) + (decf index 2) + (inst vextractf128 tmp x 1)) + (t + (move tmp x))) + (when (plusp index) + (inst vpsrldq tmp tmp (* 8 index))) + (inst vxorpd dst dst dst) + (inst movsd dst tmp))) + +#-sb-xc-host +(declaim (inline %simd-pack-256-doubles)) +#-sb-xc-host +(defun %simd-pack-256-doubles (pack) + (declare (type simd-pack-256 pack)) + (values (%simd-pack-256-double-item pack 0) + (%simd-pack-256-double-item pack 1) + (%simd-pack-256-double-item pack 2) + (%simd-pack-256-double-item pack 3))) diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp index 99bd7592b..735bad42e 100644 --- a/src/compiler/x86-64/vm.lisp +++ b/src/compiler/x86-64/vm.lisp @@ -135,7 +135,9 @@ #!+sb-simd-pack (int-sse-immediate immediate-constant) #!+sb-simd-pack (double-sse-immediate immediate-constant) #!+sb-simd-pack (single-sse-immediate immediate-constant) - + #!+sb-simd-pack-256 (int-avx2-immediate immediate-constant) + #!+sb-simd-pack-256 (double-avx2-immediate immediate-constant) + #!+sb-simd-pack-256 (single-avx2-immediate immediate-constant) (immediate immediate-constant) ;; @@ -160,6 +162,12 @@ (double-sse-stack stack :element-size 2) #!+sb-simd-pack (single-sse-stack stack :element-size 2) + #!+sb-simd-pack-256 + (int-avx2-stack stack :element-size 4) + #!+sb-simd-pack-256 + (double-avx2-stack stack :element-size 4) + #!+sb-simd-pack-256 + (single-avx2-stack stack :element-size 4) ;; ;; magic SCs @@ -269,6 +277,24 @@ #!+avx2 (avx2-reg float-registers :locations #.*float-regs*) + #!+sb-simd-pack-256 + (int-avx2-reg float-registers + :locations #.*float-regs* + :constant-scs (int-avx2-immediate) + :save-p t + :alternate-scs (int-avx2-stack)) + #!+sb-simd-pack-256 + (double-avx2-reg float-registers + :locations #.*float-regs* + :constant-scs (double-avx2-immediate) + :save-p t + :alternate-scs (double-avx2-stack)) + #!+sb-simd-pack-256 + (single-avx2-reg float-registers + :locations #.*float-regs* + :constant-scs (single-avx2-immediate) + :save-p t + :alternate-scs (single-avx2-stack)) (catch-block stack :element-size catch-block-size) (unwind-block stack :element-size unwind-block-size))) @@ -286,19 +312,24 @@ (defparameter *complex-sc-names* '(complex-single-reg complex-single-stack complex-double-reg complex-double-stack)) #!+sb-simd-pack -;;; FIXME: there is no SSE-STACK storage class (defparameter *oword-sc-names* '(sse-reg int-sse-reg single-sse-reg double-sse-reg - sse-stack int-sse-stack single-sse-stack double-sse-stack)) + int-sse-stack single-sse-stack double-sse-stack)) +#!+sb-simd-pack-256 +(defparameter *hword-sc-names* '(avx2-reg int-avx2-reg single-avx2-reg double-avx2-reg + int-avx2-stack single-avx2-stack double-avx2-stack)) ) ; EVAL-WHEN (!define-storage-classes . #.(mapcar (lambda (class-spec) (let ((size - (case (car class-spec) - (#.*oword-sc-names* :oword) - (#.*qword-sc-names* :qword) - (#.*float-sc-names* :float) - (#.*double-sc-names* :double) - (#.*complex-sc-names* :complex)))) + (case (car class-spec) + #!+sb-simd-pack + (#.*oword-sc-names* :oword) + #!+sb-simd-pack-256 + (#.*hword-sc-names* :hword) + (#.*qword-sc-names* :qword) + (#.*float-sc-names* :float) + (#.*double-sc-names* :double) + (#.*complex-sc-names* :complex)))) (append class-spec (if size (list :operand-size size))))) *storage-class-defs*)) @@ -409,7 +440,13 @@ #!+(and sb-simd-pack (not (host-feature sb-xc-host))) ((simd-pack single-float) single-sse-immediate-sc-number) #!+(and sb-simd-pack (not (host-feature sb-xc-host))) - (simd-pack int-sse-immediate-sc-number))) + (simd-pack int-sse-immediate-sc-number) + #!+(and sb-simd-pack-256 (not (host-feature sb-xc-host))) + ((simd-pack-256 double-float) double-avx2-immediate-sc-number) + #!+(and sb-simd-pack-256 (not (host-feature sb-xc-host))) + ((simd-pack-256 single-float) single-avx2-immediate-sc-number) + #!+(and sb-simd-pack-256 (not (host-feature sb-xc-host))) + (simd-pack-256 int-avx2-immediate-sc-number))) (defun boxed-immediate-sc-p (sc) (eql sc immediate-sc-number)) diff --git a/src/interpreter/checkfuns.lisp b/src/interpreter/checkfuns.lisp index 1e585a41c..f9911413c 100644 --- a/src/interpreter/checkfuns.lisp +++ b/src/interpreter/checkfuns.lisp @@ -59,7 +59,8 @@ (etypecase type ((or named-type numeric-type member-type classoid 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) type) (fun-designator-type (specifier-type '(or function symbol))) (fun-type (specifier-type 'function)) diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index 1fad7a873..888c8e431 100644 --- a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ -635,6 +635,9 @@ static void relocate_space(uword_t start, lispobj* end, struct heap_adjust* adj) case COMPLEX_DOUBLE_FLOAT_WIDETAG: #ifdef SIMD_PACK_WIDETAG case SIMD_PACK_WIDETAG: +#endif +#ifdef SIMD_PACK_256_WIDETAG + case SIMD_PACK_256_WIDETAG: #endif continue; default: diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp index 86ece07cd..cd2569412 100644 --- a/tests/load.impure.lisp +++ b/tests/load.impure.lisp @@ -370,64 +370,6 @@ (when fasl (ignore-errors (delete-file fasl)))))) -(defvar *pack*) -#+sb-simd-pack -(with-test (:name :load-simd-pack-int) - (with-open-file (s *tmp-filename* - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print '(setq *pack* (sb-kernel:%make-simd-pack-ub64 2 4)) s)) - (let (tmp-fasl) - (unwind-protect - (progn - (setq tmp-fasl (compile-file *tmp-filename*)) - (let ((*pack* nil)) - (load tmp-fasl) - (assert (typep *pack* '(sb-kernel:simd-pack integer))) - (assert (= 2 (sb-kernel:%simd-pack-low *pack*))) - (assert (= 4 (sb-kernel:%simd-pack-high *pack*))))) - (when tmp-fasl (delete-file tmp-fasl)) - (delete-file *tmp-filename*)))) - -#+sb-simd-pack -(with-test (:name :load-simd-pack-single) - (with-open-file (s *tmp-filename* - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print '(setq *pack* (sb-kernel:%make-simd-pack-single 1f0 2f0 3f0 4f0)) s)) - (let (tmp-fasl) - (unwind-protect - (progn - (setq tmp-fasl (compile-file *tmp-filename*)) - (let ((*pack* nil)) - (load tmp-fasl) - (assert (typep *pack* '(sb-kernel:simd-pack single-float))) - (assert (equal (multiple-value-list (sb-kernel:%simd-pack-singles *pack*)) - '(1f0 2f0 3f0 4f0))))) - (when tmp-fasl (delete-file tmp-fasl)) - (delete-file *tmp-filename*)))) - -#+sb-simd-pack -(with-test (:name :load-simd-pack-double) - (with-open-file (s *tmp-filename* - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (print '(setq *pack* (sb-kernel:%make-simd-pack-double 1d0 2d0)) s)) - (let (tmp-fasl) - (unwind-protect - (progn - (setq tmp-fasl (compile-file *tmp-filename*)) - (let ((*pack* nil)) - (load tmp-fasl) - (assert (typep *pack* '(sb-kernel:simd-pack double-float))) - (assert (equal (multiple-value-list (sb-kernel:%simd-pack-doubles *pack*)) - '(1d0 2d0))))) - (when tmp-fasl (delete-file tmp-fasl)) - (delete-file *tmp-filename*)))) - ;; Check that ':load print' on a fasl has some non-null effect (with-test (:name :fasloader-print) (with-open-file (stream *tmp-filename* diff --git a/tests/simd-pack-256.impure.lisp b/tests/simd-pack-256.impure.lisp new file mode 100644 index 000000000..421c00339 --- /dev/null +++ b/tests/simd-pack-256.impure.lisp @@ -0,0 +1,172 @@ +;;;; 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-256 (exit :code 104) + +(defun make-constant-packs () + (values (sb-ext:%make-simd-pack-256-ub64 1 2 3 4) + (sb-ext:%make-simd-pack-256-ub32 0 0 0 0 0 0 0 0) + (sb-ext:%make-simd-pack-256-ub64 (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-256-single 1f0 2f0 3f0 4f0 5f0 6f0 7f0 8f0) + (sb-ext:%make-simd-pack-256-single 0f0 0f0 0f0 0f0 0f0 0f0 0f0 0f0) + (sb-ext:%make-simd-pack-256-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-ext:%make-simd-pack-256-double 1d0 2d0 3d0 4d0) + (sb-ext:%make-simd-pack-256-double 0d0 0d0 0d0 0d0) + (sb-ext:%make-simd-pack-256-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))))) + + +(with-test (:name :compile-simd-pack-256-256) + (multiple-value-bind (i i0 i-1 + f f0 f-1 + d d0 d-1) + (make-constant-packs) + (loop for (p0 p1 p2 p3) in (list '(1 2 3 4) '(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))) + for pack in (list i i0 i-1) + do (assert (eql p0 (sb-kernel:%simd-pack-256-0 pack))) + (assert (eql p1 (sb-kernel:%simd-pack-256-1 pack))) + (assert (eql p2 (sb-kernel:%simd-pack-256-2 pack))) + (assert (eql p3 (sb-kernel:%simd-pack-256-3 pack)))) + (loop for expected in (list '(1f0 2f0 3f0 4f0 5f0 6f0 7f0) + '(0f0 0f0 0f0 0f0 0f0 0f0 0f0 0f0) + (make-list + 8 :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-256-singles pack))))) + (loop for expected in (list '(1d0 2d0 3d0 4d0) + '(0d0 0d0 0d0 0d0) + (make-list + 4 :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-256-doubles pack))))))) + +(with-test (:name (simd-pack-256 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 + (typecase pack + ((simd-pack-256 single-float) + (if (and *print-readably* + (some #'float-nan-p (multiple-value-list + (%simd-pack-256-singles pack)))) + (assert-error (do-it) print-not-readable) + (do-it))) + ((simd-pack-256 double-float) + (if (and *print-readably* + (some #'float-nan-p (multiple-value-list + (%simd-pack-256-doubles pack)))) + (assert-error (do-it) print-not-readable) + (do-it))) + (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* "load-test.tmp") + +(defvar *pack*) +(with-test (:name :load-simd-pack-256-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-256-ub64 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-256 integer))) + (assert (= 2 (sb-kernel:%simd-pack-256-0 *pack*))) + (assert (= 4 (sb-kernel:%simd-pack-256-1 *pack*))) + (assert (= 8 (sb-kernel:%simd-pack-256-2 *pack*))) + (assert (= 16 (sb-kernel:%simd-pack-256-3 *pack*))))) + (when tmp-fasl (delete-file tmp-fasl)) + (delete-file *tmp-filename*)))) + +(with-test (:name :load-simd-pack-256-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-256-single 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-256 single-float))) + (assert (equal (multiple-value-list (sb-ext:%simd-pack-256-singles *pack*)) + '(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-256-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-256-double 1d0 2d0 3d0 4d0)) 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-256 double-float))) + (assert (equal (multiple-value-list (sb-ext:%simd-pack-256-doubles *pack*)) + '(1d0 2d0 3d0 4d0))))) + (when tmp-fasl (delete-file tmp-fasl)) + (delete-file *tmp-filename*)))) diff --git a/tests/simd-pack.impure.lisp b/tests/simd-pack.impure.lisp index a4f3e4b6d..5811025d3 100644 --- a/tests/simd-pack.impure.lisp +++ b/tests/simd-pack.impure.lisp @@ -11,7 +11,7 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -#+sb-simd-pack +#-sb-simd-pack (exit :code 104) (defun make-constant-packs () (values (sb-kernel:%make-simd-pack-ub64 1 2) (sb-kernel:%make-simd-pack-ub32 0 0 0 0) @@ -32,7 +32,6 @@ (sb-kernel:make-double-float -1 (ldb (byte 32 0) -1))))) -#+sb-simd-pack (with-test (:name :compile-simd-pack) (multiple-value-bind (i i0 i-1 f f0 f-1 @@ -60,7 +59,6 @@ do (assert (every #'eql expected (multiple-value-list (sb-kernel:%simd-pack-doubles pack))))))) -#+sb-simd-pack (with-test (:name (simd-pack print :smoke)) (let ((packs (multiple-value-list (make-constant-packs)))) (flet ((print-them (expect) @@ -97,3 +95,60 @@ (let ((*print-readably* t) (*read-eval* nil)) (print-them 'print-not-readable))))) + +(defvar *tmp-filename* "load-test.tmp") + +(defvar *pack*) +(with-test (:name :load-simd-pack-int) + (with-open-file (s *tmp-filename* + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print '(setq *pack* (sb-kernel:%make-simd-pack-ub64 2 4)) s)) + (let (tmp-fasl) + (unwind-protect + (progn + (setq tmp-fasl (compile-file *tmp-filename*)) + (let ((*pack* nil)) + (load tmp-fasl) + (assert (typep *pack* '(sb-kernel:simd-pack integer))) + (assert (= 2 (sb-kernel:%simd-pack-low *pack*))) + (assert (= 4 (sb-kernel:%simd-pack-high *pack*))))) + (when tmp-fasl (delete-file tmp-fasl)) + (delete-file *tmp-filename*)))) + +(with-test (:name :load-simd-pack-single) + (with-open-file (s *tmp-filename* + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print '(setq *pack* (sb-kernel:%make-simd-pack-single 1f0 2f0 3f0 4f0)) s)) + (let (tmp-fasl) + (unwind-protect + (progn + (setq tmp-fasl (compile-file *tmp-filename*)) + (let ((*pack* nil)) + (load tmp-fasl) + (assert (typep *pack* '(sb-kernel:simd-pack single-float))) + (assert (equal (multiple-value-list (sb-kernel:%simd-pack-singles *pack*)) + '(1f0 2f0 3f0 4f0))))) + (when tmp-fasl (delete-file tmp-fasl)) + (delete-file *tmp-filename*)))) + +(with-test (:name :load-simd-pack-double) + (with-open-file (s *tmp-filename* + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print '(setq *pack* (sb-kernel:%make-simd-pack-double 1d0 2d0)) s)) + (let (tmp-fasl) + (unwind-protect + (progn + (setq tmp-fasl (compile-file *tmp-filename*)) + (let ((*pack* nil)) + (load tmp-fasl) + (assert (typep *pack* '(sb-kernel:simd-pack double-float))) + (assert (equal (multiple-value-list (sb-kernel:%simd-pack-doubles *pack*)) + '(1d0 2d0))))) + (when tmp-fasl (delete-file tmp-fasl)) + (delete-file *tmp-filename*))))