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

Add SIMD-PACK-256.

Browse source
This commit is contained in:
Stas Boukarev 2018-12-05 22:28:05 +03:00
parent 45a2fd72f5
commit 1d61dea7ec
37 changed files with 1157 additions and 237 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
NEWS
View file

@ -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.

2
build-order.lisp-expr
View file

@ -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")

2
make-config.sh
View file

@ -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)

58
package-data-list.lisp-expr
View file

@ -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

6
src/code/class.lisp
View file

@ -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

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

@ -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

25
src/code/early-type.lisp
View file

@ -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)

15
src/code/fop.lisp
View file

@ -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

58
src/code/late-type.lisp
View file

@ -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

3
src/code/pred.lisp
View file

@ -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))))

36
src/code/print.lisp
View file

@ -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

5
src/code/room.lisp
View file

@ -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)

10
src/code/stubs.lisp
View file

@ -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 ())

15
src/code/target-type.lisp
View file

@ -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)))))

18
src/code/typep.lisp
View file

@ -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")

10
src/compiler/dump.lisp
View file

@ -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.

4
src/compiler/early-assem.lisp
View file

@ -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))

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

@ -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

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

@ -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

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

@ -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")

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

@ -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))

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

@ -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.

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

@ -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

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

@ -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))

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

@ -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)

3
src/compiler/ir1tran.lisp
View file

@ -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

16
src/compiler/typetran.lisp
View file

@ -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))))

32
src/compiler/x86-64/avx2-insts.lisp
View file

@ -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

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

@ -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!

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

@ -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)))))

375
src/compiler/x86-64/simd-pack-256.lisp Normal file
View file

@ -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)))

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

@ -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))

3
src/interpreter/checkfuns.lisp
View file

@ -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))

3
src/runtime/coreparse.c
View file

@ -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:

58
tests/load.impure.lisp
View file

@ -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*

172
tests/simd-pack-256.impure.lisp Normal file
View file

@ -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*))))

61
tests/simd-pack.impure.lisp
View file

@ -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*))))