master: arm64: support byte-array inline constants
stassats via Sbcl-commits <[email protected]> Tue, 14 Jul 2026 21:35:10 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 4d6772fd1bf0b3e28f08255a49502f11993f9920 (commit)
from 2d6b8ff746c131630320fa8679fa046ea0153fb3 (commit)
- Log -----------------------------------------------------------------
commit 4d6772fd1bf0b3e28f08255a49502f11993f9920
Author: Stas Boukarev <[email protected]>
Date: Tue Jul 14 23:59:55 2026 +0300
arm64: support byte-array inline constants
Fewer instructions to load.
Saves registers on not having to pin in a descriptor register.
---
src/code/arm64-simd.lisp | 128 ++++++++++++++++++++---------------------
src/compiler/arm64/insts.lisp | 24 +++++---
src/compiler/arm64/macros.lisp | 5 +-
xperfecthash63.lisp-expr | 9 +++
4 files changed, 93 insertions(+), 73 deletions(-)
diff --git a/src/code/arm64-simd.lisp b/src/code/arm64-simd.lisp
index c6835cc1a..31a0a6083 100644
--- a/src/code/arm64-simd.lisp
+++ b/src/code/arm64-simd.lisp
@@ -1813,72 +1813,15 @@
(simple-character-string string)
((simple-array (unsigned-byte 8) (*)) byte-array)
(optimize speed (safety 0)))
- (let* ((table (load-time-value
- (let* ((table-size 256)
- (table (make-array (* table-size 16) :element-type '(unsigned-byte 8)
- :initial-element #xFF)))
- ;; A table for selecting 1 or 2 byte utf8
- ;; indexed by an 8 bit mask each bit with a set bit representing 1-byte characters
- (loop for row below table-size
- do (loop with dest-index = 0
- for lane below 8
- do
- (cond ((logbitp lane row)
- (setf (aref table (+ (* row 16) dest-index)) (* lane 2))
- (incf dest-index))
- ((setf (aref table (+ (* row 16) dest-index)) (+ 16 (* lane 2)))
- (setf (aref table (+ (* row 16) (1+ dest-index))) (+ 16 1 (* lane 2)))
- (incf dest-index 2)))))
- table)))
- (table2 (load-time-value
- (let* ((table-size 256)
- (row-size (* 16 3))
- (table (make-array (* table-size row-size) :element-type '(unsigned-byte 8)
- :initial-element 0)))
-
- ;; A table with three masks per entry
- ;; indexed by 4x2 bits represting the number of utf8 bytes for character - 1
- (loop for i below (* table-size row-size)
- when (< (mod i row-size) 16)
- ;; fill the TBL part with an out of bounds index to get back zeros
- do (setf (aref table i) #xFF))
- (loop for row below table-size
- do (loop with dest-index = 0
- for lane below 4
- for bytes = (1+ (ldb (byte 2 (* lane 2)) row))
- for zeros = (- 4 bytes)
- do (loop for b below bytes
- for reg-index = (+ zeros b)
- for src-index = (+ (* reg-index 16) (* lane 4))
- for lead-p = (= b 0)
- for and-mask = (if lead-p
- (case bytes
- (1 #x7F)
- (2 #x1F)
- (3 #x0F)
- (4 #x07))
- #x3F)
- for orr-mask = (if lead-p
- (case bytes
- (1 #x00)
- (2 #xC0)
- (3 #xE0)
- (4 #xF0))
- #x80)
- do (setf (aref table (+ (* row row-size) dest-index)) src-index) ;; tbl
- (setf (aref table (+ (* row row-size) 16 dest-index)) and-mask) ;; and
- (setf (aref table (+ (* row row-size) 32 dest-index)) orr-mask) ;; orr
- (incf dest-index))))
- table)))
- (length (length string)))
- (with-pinned-objects-in-registers (string byte-array table table2)
+ (let* ((length (length string)))
+ (with-pinned-objects-in-registers (string byte-array)
(multiple-value-bind (byte-index char-index)
(inline-vop (((32-bit-array* sap-reg t :target 32-bit-array) (vector-sap string))
((byte-array sap-reg t) (vector-sap byte-array))
((n signed-reg) (logand (+ (* length 4) 15) -16))
((byte-array-length unsigned-reg) (logand (+ byte-array-length 15) -16))
- ((table sap-reg t) (vector-sap table))
- ((table2 sap-reg t) (vector-sap table2))
+ ((table any-reg t))
+ ((full-table any-reg t))
((32-bit-array sap-reg t :from (:argument 0)))
((tmp unsigned-reg))
((ptr unsigned-reg))
@@ -1909,8 +1852,64 @@
(move 32-bit-array 32-bit-array*)
(load-inline-constant 2byte-mask-8h :oword #x80C080C080C080C080C080C080C080C0)
(load-inline-constant powers :qword (concat-ub 8 '(128 64 32 16 8 4 2 1)))
+ (flet ((make-table ()
+ (let* ((table-size 256)
+ (table (make-array (* table-size 16) :element-type '(unsigned-byte 8)
+ :initial-element #xFF)))
+ ;; A table for selecting 1 or 2 byte utf8
+ ;; indexed by an 8 bit mask each bit with a set bit representing 1-byte characters
+ (loop for row below table-size
+ do (loop with dest-index = 0
+ for lane below 8
+ do
+ (cond ((logbitp lane row)
+ (setf (aref table (+ (* row 16) dest-index)) (* lane 2))
+ (incf dest-index))
+ ((setf (aref table (+ (* row 16) dest-index)) (+ 16 (* lane 2)))
+ (setf (aref table (+ (* row 16) (1+ dest-index))) (+ 16 1 (* lane 2)))
+ (incf dest-index 2)))))
+ table))
+ (make-full-table ()
+ (let* ((table-size 256)
+ (row-size (* 16 3))
+ (table (make-array (* table-size row-size) :element-type '(unsigned-byte 8)
+ :initial-element 0)))
- (flet ((convert (size full-length)
+ ;; A table with three masks per entry
+ ;; indexed by 4x2 bits represting the number of utf8 bytes for character - 1
+ (loop for i below (* table-size row-size)
+ when (< (mod i row-size) 16)
+ ;; fill the TBL part with an out of bounds index to get back zeros
+ do (setf (aref table i) #xFF))
+ (loop for row below table-size
+ do (loop with dest-index = 0
+ for lane below 4
+ for bytes = (1+ (ldb (byte 2 (* lane 2)) row))
+ for zeros = (- 4 bytes)
+ do (loop for b below bytes
+ for reg-index = (+ zeros b)
+ for src-index = (+ (* reg-index 16) (* lane 4))
+ for lead-p = (= b 0)
+ for and-mask = (if lead-p
+ (case bytes
+ (1 #x7F)
+ (2 #x1F)
+ (3 #x0F)
+ (4 #x07))
+ #x3F)
+ for orr-mask = (if lead-p
+ (case bytes
+ (1 #x00)
+ (2 #xC0)
+ (3 #xE0)
+ (4 #xF0))
+ #x80)
+ do (setf (aref table (+ (* row row-size) dest-index)) src-index) ;; tbl
+ (setf (aref table (+ (* row row-size) 16 dest-index)) and-mask) ;; and
+ (setf (aref table (+ (* row row-size) 32 dest-index)) orr-mask) ;; orr
+ (incf dest-index))))
+ table))
+ (convert (size full-length)
(assemble ()
(multiple-value-bind (h-size b-size)
(ecase size
@@ -2001,7 +2000,7 @@
;; Multiply by 48 (3 * 16)
(inst add tmp tmp (lsl tmp 1))
- (inst add ptr table2 (lsl tmp 4))
+ (inst add ptr full-table (lsl tmp 4))
(inst ld1 (list shuf-mask and-mask orr-mask) (@ ptr) :16b)
@@ -2022,6 +2021,7 @@
(inst add char-index char-index 16)
(inst sub n n 16)))
(assemble ()
+ (load-inline-constant table (make-table))
(inst mov byte-index 0)
(inst mov char-index 0)
@@ -2043,7 +2043,7 @@
(inst movi c-10000 #x10000 :4s)
(inst movi c-800 #x800 :4s)
(inst movi c-80-4s #x80 :4s)
-
+ (load-inline-constant full-table (make-full-table))
FULL-LENGTH
(convert-full)
diff --git a/src/compiler/arm64/insts.lisp b/src/compiler/arm64/insts.lisp
index 590f2ca23..66fca6f69 100644
--- a/src/compiler/arm64/insts.lisp
+++ b/src/compiler/arm64/insts.lisp
@@ -4601,6 +4601,8 @@
(setq constant
(list :oword (logior (%simd-pack-low first)
(ash (%simd-pack-high first) 64)))))
+ ((simple-array (unsigned-byte 8) (*))
+ (setf constant (list :byte-array first)))
.
#+sb-xc-host
((complex
@@ -4644,7 +4646,7 @@
(cons :oword
(logior (ash (ldb (byte 64 0) (double-float-bits (imagpart value))) 64)
(ldb (byte 64 0) (double-float-bits (realpart value))))))
- ((:fixup :jump-table)
+ ((:fixup :jump-table :byte-array)
(cons type value))))))
(defun inline-constant-value (constant)
@@ -4652,11 +4654,12 @@
(size (ecase (car constant)
((:byte :word :dword :qword) (car constant))
((:fixup :jump-table) :qword)
+ (:byte-array (length (cdr constant)))
((:oword) :oword))))
(values label (cons size label))))
-(defun size-nbyte (size)
- (ecase size
+(defun size-nbyte (constant)
+ (ecase (car constant)
(:byte 1)
;; These keywords are completely wrong for AARCH64 but I don't want to touch them.
;; The correct definitions would have :HWORD (halfword) for 2 bytes, :WORD for 4,
@@ -4664,11 +4667,12 @@
(:word 2)
(:dword 4)
((:qword :fixup :jump-table) 8)
- (:oword 16)))
+ (:oword 16)
+ (:byte-array
+ (length (cdr constant)))))
(defun sort-inline-constants (constants)
- (stable-sort constants #'> :key (lambda (constant)
- (size-nbyte (caar constant)))))
+ (stable-sort constants #'> :key (lambda (c) (size-nbyte (car c)))))
(sb-assem::%def-inst-encoder
'.layout-id
@@ -4679,9 +4683,11 @@
(defun emit-inline-constant (section constant label)
(let* ((type (car constant))
(val (cdr constant))
- (size (size-nbyte type)))
+ (size (size-nbyte constant)))
(emit section
- `(.align ,(integer-length (1- size)))
+ `(.align ,(if (eq type :byte-array)
+ 4
+ (integer-length (1- size))))
label
(cond ((typep val '(cons (eql :layout-id)))
`(.layout-id ,(cadr val)))
@@ -4691,6 +4697,8 @@
`(dword ,(apply #'make-fixup val)))
((eq type :jump-table)
`(.lispword ,@(coerce val 'list)))
+ ((eq type :byte-array)
+ `(.byte ,@(coerce val 'list)))
(t
;; Could add pseudo-ops for .WORD, .INT, .QUAD, .OCTA just like gcc has.
;; But it works fine to emit as a sequence of bytes
diff --git a/src/compiler/arm64/macros.lisp b/src/compiler/arm64/macros.lisp
index 6f412a910..dc2882435 100644
--- a/src/compiler/arm64/macros.lisp
+++ b/src/compiler/arm64/macros.lisp
@@ -551,7 +551,10 @@
,value (@ tmp-tn (- (* ,offset n-word-bytes) ,lowtag))))))))))))))
(defun load-inline-constant (dst &rest constant-descriptor)
- (inst load-from-label dst (cdr (apply #'register-inline-constant constant-descriptor))))
+ (let ((label (cdr (apply #'register-inline-constant constant-descriptor))))
+ (if (vectorp (car constant-descriptor))
+ (inst adr dst label)
+ (inst load-from-label dst label))))
;;;
diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr
index 0b4d89dc4..4770ac10d 100644
--- a/xperfecthash63.lisp-expr
+++ b/xperfecthash63.lisp-expr
@@ -1779,5 +1779,14 @@
(let ((b (& val #xf)))
(let ((a (>> (u32+ val (<< val 23)) 28)))
(^ a (aref tab b))))))")
+(#(428DC20 B445B28 27168950 5A0CB91B 60BC6EF6 80D0C591 8DECED5A 92FE1EC2 A245F357 AC841474 C17B6FA5 C6B4780F CF5ABDAB F28A2060)
+ "(:BYTE-ARRAY :JUMP-TABLE :FIXUP :COMPLEX-DOUBLE-FLOAT :COMPLEX-SINGLE-FLOAT :DOUBLE-FLOAT :SINGLE-FLOAT :CHARACTER :BASE-CHAR :OWORD :QWORD :DWORD :WORD :BYTE)"
+ "((let ((tab #a((8) (unsigned-byte 8) 0 0 8 14 12 7 11 3)))
+ (let ((b (& val #x7)))
+ (let ((a (>> (<< val 5) 29)))
+ (^ a (aref tab b))))))")
+(#(428DC20 27168950 5A0CB91B 8DECED5A 92FE1EC2 C17B6FA5 CF5ABDAB F28A2060)
+ "(:OWORD :BYTE-ARRAY :JUMP-TABLE :FIXUP :QWORD :DWORD :WORD :BYTE)"
+ "((& (- val (>> val 10)) 7))")
)
;; EOF
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL