master: sb-simd: Portability fixes
stassats via Sbcl-commits <[email protected]> Tue, 30 Jun 2026 22:46:46 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via f99638c4e007e361fb7a4e6d232ab9f524133fc6 (commit)
from 1b4ec2334224d8dfa9908e9e105d8a25b3cded0f (commit)
- Log -----------------------------------------------------------------
commit f99638c4e007e361fb7a4e6d232ab9f524133fc6
Author: Sylvia Harrington <[email protected]>
Date: Wed Jun 18 21:33:14 2025 +0100
sb-simd: Portability fixes
This is mostly just building on what already existed, primarily
only defining and calling VOPs where the instruction set exists.
Also a phony simd-pack-256 type to allow building when that
type doesn't exist.
And disable the vref vop implementation outside x86oids, as it's entirely
specific to that instruction set.
---
contrib/sb-simd/code/define-custom-vops.lisp | 48 +++++++--------
contrib/sb-simd/code/define-scalar-casts.lisp | 85 +++++++++++++++------------
contrib/sb-simd/code/define-simd-casts.lisp | 15 ++---
contrib/sb-simd/code/define-vref-vops.lisp | 1 +
contrib/sb-simd/code/define-vrefs.lisp | 38 +++++++-----
contrib/sb-simd/code/record.lisp | 11 +++-
6 files changed, 115 insertions(+), 83 deletions(-)
diff --git a/contrib/sb-simd/code/define-custom-vops.lisp b/contrib/sb-simd/code/define-custom-vops.lisp
index 0fd034ebd..8ed639a34 100644
--- a/contrib/sb-simd/code/define-custom-vops.lisp
+++ b/contrib/sb-simd/code/define-custom-vops.lisp
@@ -7,31 +7,33 @@
(argument-records sb-simd-internals:instruction-record-argument-records)
(result-records sb-simd-internals:instruction-record-result-records)
(cost sb-simd-internals:instruction-record-cost)
- (encoding sb-simd-internals:instruction-record-encoding))
+ (encoding sb-simd-internals:instruction-record-encoding)
+ (instruction-set sb-simd-internals:instruction-record-instruction-set))
(sb-simd-internals:find-function-record name)
(assert (eq encoding :custom))
- (labels ((find-clauses (key)
- (remove key clauses :test-not #'eq :key #'first))
- (find-clause (key)
- (let ((found (find-clauses key)))
- (assert (= 1 (length found)))
- (rest (first found)))))
- `(sb-c:define-vop (,vop)
- (:translate ,vop)
- (:policy :fast-safe)
- (:arg-types ,@(mapcar #'sb-simd-internals:value-record-primitive-type argument-records))
- (:result-types ,@(mapcar #'sb-simd-internals:value-record-primitive-type result-records))
- (:args
- ,@(loop for arg in (find-clause :args)
- for argument-record in argument-records
- collect `(,@arg :scs ,(sb-simd-internals:value-record-scs argument-record))))
- ,@(find-clauses :info)
- ,@(find-clauses :temporary)
- (:results
- ,@(loop for result in (find-clause :results)
- for result-record in result-records
- collect `(,@result :scs ,(sb-simd-internals:value-record-scs result-record))))
- (:generator ,cost ,@(find-clause :generator)))))))
+ (when (sb-simd-internals:instruction-set-available-p instruction-set)
+ (labels ((find-clauses (key)
+ (remove key clauses :test-not #'eq :key #'first))
+ (find-clause (key)
+ (let ((found (find-clauses key)))
+ (assert (= 1 (length found)))
+ (rest (first found)))))
+ `(sb-c:define-vop (,vop)
+ (:translate ,vop)
+ (:policy :fast-safe)
+ (:arg-types ,@(mapcar #'sb-simd-internals:value-record-primitive-type argument-records))
+ (:result-types ,@(mapcar #'sb-simd-internals:value-record-primitive-type result-records))
+ (:args
+ ,@(loop for arg in (find-clause :args)
+ for argument-record in argument-records
+ collect `(,@arg :scs ,(sb-simd-internals:value-record-scs argument-record))))
+ ,@(find-clauses :info)
+ ,@(find-clauses :temporary)
+ (:results
+ ,@(loop for result in (find-clause :results)
+ for result-record in result-records
+ collect `(,@result :scs ,(sb-simd-internals:value-record-scs result-record))))
+ (:generator ,cost ,@(find-clause :generator))))))))
;; SSE
(macrolet ((def (name cmp)
`(define-custom-vop ,name
diff --git a/contrib/sb-simd/code/define-scalar-casts.lisp b/contrib/sb-simd/code/define-scalar-casts.lisp
index 45cb30a73..2f970d100 100644
--- a/contrib/sb-simd/code/define-scalar-casts.lisp
+++ b/contrib/sb-simd/code/define-scalar-casts.lisp
@@ -5,8 +5,20 @@
;;; signal an error.
(macrolet
- ((define-scalar-cast (scalar-cast-record-name)
- (with-accessors ((name scalar-cast-record-name))
+ ((call-vop (instruction-record-name &rest arguments)
+ (with-accessors ((instruction-set instruction-record-instruction-set)
+ (vop instruction-record-vop))
+ (find-function-record instruction-record-name)
+ (if (instruction-set-available-p instruction-set)
+ `(,vop ,@arguments)
+ `(progn
+ (missing-instruction
+ (load-time-value
+ (find-function-record ',instruction-record-name)))
+ (touch ,@arguments)))))
+ (define-scalar-cast (scalar-cast-record-name)
+ (with-accessors ((name scalar-cast-record-name)
+ (instruction-set scalar-cast-record-instruction-set))
(find-function-record scalar-cast-record-name)
(let ((err (mksym (symbol-package name) "CANNOT-CONVERT-TO-" name)))
`(progn
@@ -17,33 +29,34 @@
:overwrite-fndb-silently t)
(sb-c:deftransform ,name ((x) (,name) *)
'x)
- ,@(case name
- (sb-simd:f32
- `((sb-c:deftransform ,name ((x) (double-float) *)
- '(coerce x 'single-float))))
- (sb-simd:f64
- `((sb-c:deftransform ,name ((x) (single-float) *)
- '(coerce x 'double-float))))
- (sb-simd-sse:f32
- `((sb-c:deftransform ,name ((x) (double-float) *)
- '(sb-kernel:%single-float x))
- (sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
- '(sb-simd-sse::f32-from-s64 x))))
- (sb-simd-sse2:f64
- `((sb-c:deftransform ,name ((x) (single-float) *)
- '(sb-simd-sse2::f64-from-f32 x))
- (sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
- '(sb-simd-sse2::f64-from-s64 x))))
- (sb-simd-avx:f32
- `((sb-c:deftransform ,name ((x) (double-float) *)
- '(sb-simd-avx::f32-from-f64 x))
- (sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
- '(sb-simd-avx::f32-from-s64 x))))
- (sb-simd-avx:f64
- `((sb-c:deftransform ,name ((x) (single-float) *)
- '(sb-simd-avx::f64-from-f32 x))
- (sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
- '(sb-simd-avx::f64-from-s64 x)))))
+ ,@(when (instruction-set-available-p instruction-set)
+ (case name
+ (sb-simd:f32
+ `((sb-c:deftransform ,name ((x) (double-float) *)
+ '(coerce x 'single-float))))
+ (sb-simd:f64
+ `((sb-c:deftransform ,name ((x) (single-float) *)
+ '(coerce x 'double-float))))
+ (sb-simd-sse:f32
+ `((sb-c:deftransform ,name ((x) (double-float) *)
+ '(sb-kernel:%single-float x))
+ (sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
+ '(sb-simd-sse::f32-from-s64 x))))
+ (sb-simd-sse2:f64
+ `((sb-c:deftransform ,name ((x) (single-float) *)
+ '(sb-simd-sse2::f64-from-f32 x))
+ (sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
+ '(sb-simd-sse2::f64-from-s64 x))))
+ (sb-simd-avx:f32
+ `((sb-c:deftransform ,name ((x) (double-float) *)
+ '(sb-simd-avx::f32-from-f64 x))
+ (sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
+ '(sb-simd-avx::f32-from-s64 x))))
+ (sb-simd-avx:f64
+ `((sb-c:deftransform ,name ((x) (single-float) *)
+ '(sb-simd-avx::f64-from-f32 x))
+ (sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
+ '(sb-simd-avx::f64-from-s64 x))))))
(defun ,name (x)
(typecase x
(,name x)
@@ -56,19 +69,19 @@
(real (coerce x ',name))))
(sb-simd-sse:f32
`((double-float (sb-kernel:%single-float x))
- (sb-simd-sse:s64 (sb-simd-sse::%f32-from-s64 x))
+ (sb-simd-sse:s64 (call-vop sb-simd-sse::f32-from-s64 x))
(real (coerce x ',name))))
(sb-simd-sse2:f64
- `((sb-simd-sse2:f32 (sb-simd-sse2::%f64-from-f32 x))
- (sb-simd-sse2:s64 (sb-simd-sse2::%f64-from-s64 x))
+ `((sb-simd-sse2:f32 (call-vop sb-simd-sse2::f64-from-f32 x))
+ (sb-simd-sse2:s64 (call-vop sb-simd-sse2::f64-from-s64 x))
(real (coerce x ',name))))
(sb-simd-avx:f32
- `((sb-simd-avx:f64 (sb-simd-avx::%f32-from-f64 x))
- (sb-simd-avx:s64 (sb-simd-avx::%f32-from-s64 x))
+ `((sb-simd-avx:f64 (call-vop sb-simd-avx::f32-from-f64 x))
+ (sb-simd-avx:s64 (call-vop sb-simd-avx::f32-from-s64 x))
(real (coerce x ',name))))
(sb-simd-avx:f64
- `((sb-simd-avx:f32 (sb-simd-avx::%f64-from-f32 x))
- (sb-simd-avx:s64 (sb-simd-avx::%f64-from-s64 x))
+ `((sb-simd-avx:f32 (call-vop sb-simd-avx::f64-from-f32 x))
+ (sb-simd-avx:s64 (call-vop sb-simd-avx::f64-from-s64 x))
(real (coerce x ',name)))))
(otherwise (,err x))))))))
(define-scalar-casts ()
diff --git a/contrib/sb-simd/code/define-simd-casts.lisp b/contrib/sb-simd/code/define-simd-casts.lisp
index cc3e1c183..acb1d9b49 100644
--- a/contrib/sb-simd/code/define-simd-casts.lisp
+++ b/contrib/sb-simd/code/define-simd-casts.lisp
@@ -48,13 +48,14 @@
`(progn
(define-notinline ,err (x)
(error "Cannot convert ~S to ~S." x ',name))
- (sb-c:defknown ,name (t) (values ,name &optional)
- (sb-c:foldable)
- :overwrite-fndb-silently t)
- (sb-c:deftransform ,name ((x) (,simd-type) *)
- 'x)
- (sb-c:deftransform ,name ((x) (real) *)
- '(,broadcast (,real-type x)))
+ ,@(when (instruction-set-available-p instruction-set)
+ `((sb-c:defknown ,name (t) (values ,name &optional)
+ (sb-c:foldable)
+ :overwrite-fndb-silently t)
+ (sb-c:deftransform ,name ((x) (,simd-type) *)
+ 'x)
+ (sb-c:deftransform ,name ((x) (real) *)
+ '(,broadcast (,real-type x)))))
(defun ,name (x)
(typecase x
(,simd-type x)
diff --git a/contrib/sb-simd/code/define-vref-vops.lisp b/contrib/sb-simd/code/define-vref-vops.lisp
index b68cd8f16..3a93fd41b 100644
--- a/contrib/sb-simd/code/define-vref-vops.lisp
+++ b/contrib/sb-simd/code/define-vref-vops.lisp
@@ -7,6 +7,7 @@
;;; variants of the VOP - one for the general case, and one for the case
;;; where the index is a compile-time constant.
+#+(or x86 x86-64)
(macrolet
((define-vref-vop (vref-record-name)
(with-accessors ((name sb-simd-internals:vref-record-name)
diff --git a/contrib/sb-simd/code/define-vrefs.lisp b/contrib/sb-simd/code/define-vrefs.lisp
index 6834ef918..11186b567 100644
--- a/contrib/sb-simd/code/define-vrefs.lisp
+++ b/contrib/sb-simd/code/define-vrefs.lisp
@@ -14,23 +14,29 @@
(value-record-type vector-record))))
(ecase kind
(:load
- `(define-inline ,name (array index)
- (declare (type (array ,element-type) array)
- (index index))
- (sb-kernel:check-bound array (array-total-size array) (+ index ,(1- simd-width)))
- (multiple-value-bind (vector index)
- (sb-kernel:%data-vector-and-index array index)
- (declare (type (simple-array ,element-type (*)) vector))
- (,vop vector index 0))))
+ (if (not (instruction-set-available-p instruction-set))
+ `(define-missing-instruction ,name
+ :required-arguments (array index))
+ `(define-inline ,name (array index)
+ (declare (type (array ,element-type) array)
+ (index index))
+ (sb-kernel:check-bound array (array-total-size array) (+ index ,(1- simd-width)))
+ (multiple-value-bind (vector index)
+ (sb-kernel:%data-vector-and-index array index)
+ (declare (type (simple-array ,element-type (*)) vector))
+ (,vop vector index 0)))))
(:store
- `(define-inline ,name (value array index)
- (declare (type (array ,element-type) array)
- (index index))
- (sb-kernel:check-bound array (array-total-size array) (+ index ,(1- simd-width)))
- (multiple-value-bind (vector index)
- (sb-kernel:%data-vector-and-index array index)
- (declare (type (simple-array ,element-type (*)) vector))
- (,vop (,(value-record-name value-record) value) vector index 0))))))))
+ (if (not (instruction-set-available-p instruction-set))
+ `(define-missing-instruction ,name
+ :required-arguments (value array index))
+ `(define-inline ,name (value array index)
+ (declare (type (array ,element-type) array)
+ (index index))
+ (sb-kernel:check-bound array (array-total-size array) (+ index ,(1- simd-width)))
+ (multiple-value-bind (vector index)
+ (sb-kernel:%data-vector-and-index array index)
+ (declare (type (simple-array ,element-type (*)) vector))
+ (,vop (,(value-record-name value-record) value) vector index 0)))))))))
(define-vrefs ()
`(progn
,@(loop for load-record in (filter-function-records #'load-record-p)
diff --git a/contrib/sb-simd/code/record.lisp b/contrib/sb-simd/code/record.lisp
index 77f581d80..90eadebe7 100644
--- a/contrib/sb-simd/code/record.lisp
+++ b/contrib/sb-simd/code/record.lisp
@@ -181,13 +181,22 @@
(defun scalar-record-p (x)
(typep x '(and value-record (not simd-record))))
+#-simd-pack-256
+(progn
+ (defstruct phony-simd-pack-256)
+ (deftype simd-pack-256 (&optional element-type)
+ (declare (ignore element-type))
+ 'phony-simd-pack-256))
+
(defmethod decode-record-definition ((_ (eql 'simd-record)) expr):w
(destructuring-bind (name scalar-record-name bits primitive-type scs) expr
(let ((simd-pack-type
(let ((base-type
(ecase bits
(128 (find-symbol "SIMD-PACK" "SB-EXT"))
- (256 (find-symbol "SIMD-PACK-256" "SB-EXT")))))
+ (256 (or (find-symbol "SIMD-PACK-256" "SB-EXT")
+ #-simd-pack-256
+ 'simd-pack-256)))))
(cond ((not base-type) 't)
((not scalar-record-name) base-type)
(t `(,base-type ,scalar-record-name))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL