master: arm64: simd utf8-crlf-to-character-string-sized
stassats via Sbcl-commits <[email protected]> Fri, 31 Jul 2026 01:50:37 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 5f1c338ca69bd6212d9956704f2949deed80e402 (commit)
from f45092cdcd34fff9f6fdaa20df972328cee354d0 (commit)
- Log -----------------------------------------------------------------
commit 5f1c338ca69bd6212d9956704f2949deed80e402
Author: Stas Boukarev <[email protected]>
Date: Fri Jul 31 03:00:30 2026 +0300
arm64: simd utf8-crlf-to-character-string-sized
---
src/code/arm64-simd.lisp | 782 +++++++++++++++++--------------
src/code/external-formats/enc-basic.lisp | 6 +-
src/compiler/arm64/insts.lisp | 3 +
tests/utf-8.pure.lisp | 2 +
4 files changed, 431 insertions(+), 362 deletions(-)
diff --git a/src/code/arm64-simd.lisp b/src/code/arm64-simd.lisp
index 9e35ae4b7..4037711ce 100644
--- a/src/code/arm64-simd.lisp
+++ b/src/code/arm64-simd.lisp
@@ -566,7 +566,6 @@
((c-c0 complex-double-reg))
((c-ff complex-double-reg))
((c-4 complex-double-reg))
- ((errors complex-double-reg))
((powers double-reg))
((prev complex-double-reg))
((prev-len complex-double-reg))
@@ -640,7 +639,6 @@
(load-inline-constant tbl3 :oword #x202020203535332B2020202020202020)
(load-inline-constant tbl4 :oword #x08040202000000000000000000000000)
- (inst movi errors 0 :16b)
(inst movi prev 0 :16b)
(inst movi prev-len 0 :16b)
(inst movi c-c0 #xc0 :16b)
@@ -686,8 +684,7 @@
(inst tbl temp4 (list tbl3) temp4 :16b)
(inst and temp2 temp2 temp3 :16b)
- (inst and temp2 temp2 temp4 :16b)
- (inst orr errors errors temp2 :16b)
+ (inst and s1 temp2 temp4 :16b)
(inst ushr temp1 bytes 4 :16b)
(inst tbl temp1 (list tbl4) temp1 :16b)
@@ -708,9 +705,9 @@
(inst cmtst temp4 temp2 temp2 :16b)
(inst eor temp4 temp3 temp4 :16b)
- (inst orr errors errors temp4 :16b)
+ (inst orr s1 s1 temp4 :16b)
- (inst umaxv temp4 errors :16b)
+ (inst umaxv temp4 s1 :16b)
(inst umov tmp-tn temp4 0 :b)
(inst cbnz tmp-tn ERROR)
@@ -786,9 +783,13 @@
($when $sized
(inst clz chars-low chars-low :4s)
(inst clz chars-high chars-high :4s)
+
(inst uzp1 temp2 chars-low chars-high :8h)
(inst xtn temp2 temp2 :8b)
(inst tbl temp2 (list length1 length2) temp2 :8b)
+
+ ;; #\Nul clzs to 32, out of range for the table
+ (inst umax temp2 temp2 ones :8b)
(inst str temp2 (@ size-buffer) :d)
(inst sub size-buffer size-buffer char-count))))
(assemble ()
@@ -1088,359 +1089,422 @@
(setf (sb-impl::buffer-head ibuf) new-head)
(truly-the index (+ start copied)))))))
-(defun utf8-crlf-to-character-string (start end string ibuf)
- (declare (type index start end)
- (optimize speed (safety 0)))
- (with-pinned-objects-in-registers (string)
- (let* ((head (sb-impl::buffer-head ibuf))
- (tail (sb-impl::buffer-tail ibuf))
- (left (- end start))
- (string-end (- left (/ 64 4)))
- (byte-end (- tail head 32)))
- (multiple-value-bind (copied written)
- (inline-vop (((byte-start any-reg) head)
- ((string-start any-reg) start)
- ((byte-end any-reg) byte-end)
- ((string-end any-reg) string-end)
- ((byte-array* sap-reg t) (sb-impl::buffer-sap ibuf))
- ((byte-array sap-reg t))
- ((string* sap-reg t) (vector-sap string))
- ((string sap-reg t))
-
- ((index unsigned-reg t :from (:argument 1)))
- ((suffix unsigned-reg t :from (:argument 1)))
- ((char-count signed-reg t))
- ((full-table any-reg t))
- ((crlf-table any-reg t))
-
- ((bytes complex-double-reg))
- ((tbl1 complex-double-reg))
- ((tbl2 complex-double-reg))
- ((tbl3 complex-double-reg))
- ((tbl4 complex-double-reg))
-
- ((nibble-mask complex-double-reg))
- ((c-c0 complex-double-reg))
- ((c-ff complex-double-reg))
- ((c-4 complex-double-reg))
- ((crlf-mask complex-double-reg))
-
- ((errors complex-double-reg))
- ((powers complex-double-reg))
- ((prev complex-double-reg))
- ((prev-len complex-double-reg))
-
- ((temp1 complex-double-reg))
- ((temp2 complex-double-reg))
- ((temp3 complex-double-reg))
- ((temp4 complex-double-reg))
-
- ((shuf-low complex-double-reg t :offset 1))
- ((shuf-high complex-double-reg t :offset 2))
- ((chars-low complex-double-reg t :offset 5))
- ((chars-high complex-double-reg t :offset 6))
- ((tag-clear complex-double-reg))
- ((s1 complex-double-reg t :offset 8))
- ((s2 complex-double-reg t :offset 9)))
- ((copied unsigned-reg positive-fixnum)
- (written unsigned-reg positive-fixnum))
-
-
- (inst add byte-array* byte-array* (lsr byte-start 1))
- (inst mov byte-array byte-array*)
- (inst add byte-end byte-array* (lsr byte-end 1))
-
- (inst add string-end string* (lsl string-end (- 2 n-fixnum-tag-bits)))
- (inst add string string* (lsl string-start (- 2 n-fixnum-tag-bits)))
- (inst mov tmp-tn #x0A0D)
- (inst dup crlf-mask tmp-tn :8h)
- (load-inline-constant powers :oword #x80402010080402018040201008040201)
- (load-inline-constant crlf-table
- (let ((table (make-array (* 256 16) :element-type '(unsigned-byte 8))))
- (loop for row below 256
- do (loop with indexes = (loop for i below 16
- unless (logbitp i row)
- collect i)
- for column below 16
- for index = (or (pop indexes)
- #xFF)
- do
- (setf (aref table (+ (* row 16) column))
- index)))
- table))
- (inst ldr s1 (@ byte-array))
- (inst b start)
-
- ASCII-LOOP
- (inst mov bytes s1 :16b)
- (inst ldr s1 (@ byte-array 16))
-
- (inst umaxv temp1 bytes :16b)
- (inst umov tmp-tn temp1 0 :b)
- (inst tbnz tmp-tn 7 NOT-ASCII)
-
- (inst add byte-array byte-array 16)
- (progn
- ;; Shift bytes right to find CRLF starting at odd indexes
- ;; and grab the first byte from the next vector to check if it
- ;; it's an LF
- (inst ext temp2 bytes s1 1 :16b)
- ;; Compare both variants
- (inst cmeq temp1 bytes crlf-mask :8h)
- (inst cmeq temp2 temp2 crlf-mask :8h)
-
- ;; SLI retains the destination parts, matching elements
- ;; will have FFFF, shifting and inserting will combine
- ;; them with zeros producing just one FF
- (inst sli temp1 temp2 8 :8h)
-
- ;; Count matches
- (inst addv temp2 temp1 :8b)
- (inst smov char-count temp2 0 :b)
-
- ;; powers has powers of two for each byte index,
- ;; adding them together will produce an 8-bit mask.
- (inst and temp2 temp1 powers :16b)
-
- (inst addv temp3 temp2 :8b)
- (inst umov tmp-tn temp3 0 :b)
-
- (inst ldr temp3 (@ crlf-table (lsl tmp-tn 4)))
- (inst tbl temp3 (list bytes) temp3 :8b)
-
- ;; Widen
- (inst ushll temp3 :8h temp3 :8b)
- (inst ushll temp4 :4s temp3 :4h)
- (inst ushll2 s2 :4s temp3 :8h)
- (inst stp temp4 s2 (@ string 32 :post-index))
- (inst add string string (lsl char-count 2))
-
- ;; Second half
-
- ;; Count matches
- (inst ins temp3 0 temp1 1 :d)
- (inst addv temp3 temp3 :8b)
- (inst smov char-count temp3 0 :b)
- (inst ins temp2 0 temp2 1 :d)
- (inst addv temp2 temp2 :8b)
- (inst umov tmp-tn temp2 0 :b)
- (inst ldr temp3 (@ crlf-table (lsl tmp-tn 4)))
- (inst ins bytes 0 bytes 1 :d)
- (inst tbl temp1 (list bytes) temp3 :8b)
-
-
- (inst ushll temp1 :8h temp1 :8b)
- (inst ushll temp4 :4s temp1 :4h)
- (inst ushll2 s2 :4s temp1 :8h)
- (inst stp temp4 s2 (@ string 32 :post-index))
- (inst add string string (lsl char-count 2)))
-
- start
- (inst cmp byte-array byte-end)
- (inst b :ge DONE)
- (inst cmp string string-end)
- (inst b :ge DONE)
- (inst b ASCII-LOOP)
-
- NOT-ASCII
- (inst movi nibble-mask #x0f :16b)
-
- (load-inline-constant tbl1 :oword #x38060001000000000000000000000000)
- (load-inline-constant tbl2 :oword #x2020242020202020202020100000010B)
- (load-inline-constant tbl3 :oword #x202020203535332B2020202020202020)
- (load-inline-constant tbl4 :oword #x08040202000000000000000000000000)
-
- (inst movi errors 0 :16b)
- (inst movi prev 0 :16b)
- (inst movi prev-len 0 :16b)
- (inst movi c-c0 #xc0 :16b)
- (inst movi c-ff #xFF :8h)
- (inst movi c-4 4 :4s)
- (inst mov suffix 0)
-
- (load-inline-constant tag-clear :oword #x070F1F1F3F3F3F3F7F7F7F7F7F7F7F7F)
- (load-inline-constant full-table (coerce (loop for index below (ash 1 10)
- for low-index = (ldb (byte 8 0) index)
- for suffix = (ldb (byte 2 8) index)
- append (let ((starts (loop for i to 7
- when (logbitp i low-index)
- collect i)))
- (loop for lane below 8
- for start = (pop starts)
- for next = (car starts)
-
- for sources = (when start
- (loop for i from (1- (or next
- (+ suffix 8))) downto start
- collect i))
- append (loop for byte below 4
- collect (or (pop sources) #xFF)))))
- '(vector (unsigned-byte 8))))
-
- (flet ((validate ()
- (assemble ()
- ;; The Keiser, Lemire algorithm
- (inst ext temp1 prev bytes 15 :16b)
- (inst ushr temp2 temp1 4 :16b)
- (inst and temp3 temp1 nibble-mask :16b)
- (inst ushr temp4 bytes 4 :16b)
-
- (inst tbl temp2 (list tbl1) temp2 :16b)
- (inst tbl temp3 (list tbl2) temp3 :16b)
- (inst tbl temp4 (list tbl3) temp4 :16b)
-
- (inst and temp2 temp2 temp3 :16b)
- (inst and temp2 temp2 temp4 :16b)
- (inst orr errors errors temp2 :16b)
-
- (inst ushr temp1 bytes 4 :16b)
- (inst tbl temp1 (list tbl4) temp1 :16b)
-
- (inst ext temp2 prev-len temp1 15 :16b)
- (inst ext temp3 prev-len temp1 14 :16b)
- (inst ext temp4 prev-len temp1 13 :16b)
-
- (inst ushr temp2 temp2 1 :16b)
- (inst ushr temp3 temp3 2 :16b)
- (inst ushr temp4 temp4 3 :16b)
-
- (inst orr temp2 temp2 temp3 :16b)
- (inst orr temp2 temp2 temp4 :16b)
-
- (inst cmgt temp3 c-c0 bytes :16b) ;; continuations
-
- (inst cmtst temp4 temp2 temp2 :16b)
-
- (inst eor temp4 temp3 temp4 :16b)
- (inst orr errors errors temp4 :16b)
-
- (inst umaxv temp4 errors :16b)
- (inst umov tmp-tn temp4 0 :b)
- (inst cbnz tmp-tn ERROR)
-
- ;; convert-full consumes only 8
- (inst ext prev-len prev-len temp1 8 :16b)
- (inst ext prev prev bytes 8 :16b)
-
- VALIDATED))
- (remove-crlf ()
- ;; Count leading bytes before more are dragged in after removing CR
- (inst cmge temp1 bytes c-c0 :8b)
- (inst addv temp2 temp1 :8b)
- ;; A negated number of produced characters
- (inst smov char-count temp2 0 :b)
-
- ;; Shift bytes right to find CRLF starting at odd indexes
- (inst ext temp2 bytes bytes 1 :16b)
-
- ;; Compare both variants
- (inst cmeq temp1 bytes crlf-mask :4h)
- (inst cmeq temp2 temp2 crlf-mask :4h)
-
- ;; SLI retains the destination parts, matching elements
- ;; will have FFFF, shifting and inserting will combine
- ;; them with zeros producing just one FF
- (inst sli temp1 temp2 8 :4h)
-
- ;; Count matches
- (inst addv temp2 temp1 :8b)
- (inst smov tmp-tn temp2 0 :b)
-
- (inst sub char-count char-count tmp-tn)
-
- (inst and temp2 temp1 powers :8b)
- (inst addv temp3 temp2 :8b)
- (inst umov tmp-tn temp3 0 :b)
-
- (inst ldr temp3 (@ crlf-table (lsl tmp-tn 4)))
- (inst tbl bytes (list bytes) temp3 :16b))
- (convert-full ()
- ;; Process the leading bytes in the first 8 bytes, loading 16 bytes
- ;; so that the last leading byte might drag in 3 more bytes
-
- ;; Identify leading bytes
- (inst cmge temp1 bytes c-c0 :16b)
-
- ;; Turn them into an 8 bit index
- (inst and temp2 temp1 powers :8b)
- (inst addv temp3 temp2 :8b)
- (inst umov index temp3 0 :b)
-
- ;; Need to know where the last leading byte ends
- (inst umov suffix temp1 1 :d)
- ;; Count the number of bytes to the next leading byte, turning it into a 2 bit suffix
- (inst rbit suffix suffix)
- (inst clz suffix suffix)
- ;; Bytes to bits
- (inst lsr suffix suffix 3)
-
- ;; Add the size of the last character, ensuring that only 2 bits are added
- (inst bfm index suffix 56 1)
-
- (inst add tmp-tn full-table (lsl index 5))
- (inst ld1 (list shuf-low shuf-high) (@ tmp-tn) :16b)
-
- ;; Use the high 4 bits of each byte to get an and-mask that
- ;; will clear their tags
- (inst ushr temp1 bytes 4 :16b)
- (inst tbl temp1 (list tag-clear) temp1 :16b)
- (inst and bytes bytes temp1 :16b)
-
- ;; Shuffle the bytes into 4-byte lanes
- (inst tbl chars-low (list bytes) shuf-low :16b)
- (inst tbl chars-high (list bytes) shuf-high :16b)
-
- (flet ((decode-lane (chars)
- ;; Perform
- ;; A + B<<6 + C<<12 + D<<18
- ;; =>
- ;; A + B<<6 + ((C + D<<6) << 12)
-
- ;; [D, 0, B, 0]
- (inst bic s1 chars c-ff :16b)
- ;; [0, C, 0, A]
- (inst and s2 chars c-ff :16b)
- ;; Combine into two 12-bit blocks per 32-bit lane: [L1, L0]
- (inst usra s2 s1 2 :8h)
- ;; Shift L0 left by 4, leave L1 alone: [L1, L0 << 4]
- (inst ushl s2 s2 c-4 :8h)
- ;; Shift each 32-bit lane right by 4
- (inst ushr chars s2 4 :4s)))
-
- (decode-lane chars-low)
- (decode-lane chars-high)
- (inst st1 (list chars-low chars-high) (@ string) :16b))
-
-
- (inst add byte-array byte-array 8)
- (inst sub string string (lsl char-count 2))))
- (assemble ()
- FULL-LOOP
- (inst ldr bytes (@ byte-array))
- (validate)
- ;; (convert-full)
- ;; (inst cmp byte-array byte-end)
- ;; (inst b :ge FULL-DONE)
- ;; (inst cmp string string-end)
- ;; (inst b :ge FULL-DONE)
- (remove-crlf)
- (convert-full)
- (inst cmp byte-array byte-end)
- (inst b :ge FULL-DONE)
- (inst cmp string string-end)
- (inst b :ge FULL-DONE)
- (inst b FULL-LOOP)))
-
- ERROR
- FULL-DONE
-
- (inst add byte-array byte-array suffix) ;; strip any consumed continuations bytes
- DONE
- (inst sub copied byte-array byte-array*)
- (inst sub written string string*)
- (inst lsr written written 2))
- (setf (sb-impl::buffer-head ibuf) (+ head copied))
- (truly-the index written)))))
+(make-defs ((($suffix $sized)
+ (-sized t)
+ (|| nil)))
+ (defun utf8-crlf-to-character-string$suffix (start end string ibuf ($when $sized
+ size-buffer))
+ (declare (type index start end)
+ ($when $sized
+ (sb-impl::ansi-stream-csize-buffer size-buffer))
+ (optimize speed (safety 0)))
+ (with-pinned-objects-in-registers (string ($when $sized
+ size-buffer))
+ (let* ((head (sb-impl::buffer-head ibuf))
+ (tail (sb-impl::buffer-tail ibuf))
+ (left (- end start))
+ (string-end (- left (/ 64 4)))
+ (byte-end (- tail head 32)))
+ (multiple-value-bind (copied written)
+ (inline-vop (((byte-start any-reg) head)
+ ((string-start any-reg) start)
+ ((byte-end any-reg) byte-end)
+ ((string-end any-reg) string-end)
+ ((byte-array* sap-reg t) (sb-impl::buffer-sap ibuf))
+ ((byte-array sap-reg t))
+ ((string* sap-reg t) (vector-sap string))
+ ((string sap-reg t))
+ ($when $sized
+ ((size-buffer sap-reg t) (vector-sap size-buffer)))
+
+ ((index unsigned-reg t :from (:argument 1)))
+ ((suffix unsigned-reg t :from (:argument 1)))
+ ((char-count signed-reg t))
+ ((full-table any-reg t))
+ ((crlf-table any-reg t))
+
+ ((bytes complex-double-reg))
+ ((tbl1 complex-double-reg))
+ ((tbl2 complex-double-reg))
+ ((tbl3 complex-double-reg))
+ ((tbl4 complex-double-reg))
+
+ ((nibble-mask complex-double-reg))
+ ((c-c0 complex-double-reg))
+ ((c-ff complex-double-reg))
+ ((c-4 complex-double-reg))
+ ((crlf-mask complex-double-reg))
+
+ ((powers complex-double-reg))
+ ((prev complex-double-reg))
+ ((prev-len complex-double-reg))
+
+ ((temp1 complex-double-reg))
+ ((temp2 complex-double-reg))
+ ((temp3 complex-double-reg))
+ ((temp4 complex-double-reg))
+
+ ((shuf-low complex-double-reg t :offset 1))
+ ((shuf-high complex-double-reg t :offset 2))
+ ((chars-low complex-double-reg t :offset 5))
+ ((chars-high complex-double-reg t :offset 6))
+ ((tag-clear complex-double-reg))
+ ((s1 complex-double-reg t :offset 8))
+ ((s2 complex-double-reg t :offset 9))
+ ($when $sized
+ ((ones complex-double-reg))
+ ((length1 complex-double-reg t :offset 10))
+ ((length2 complex-double-reg t :offset 11))
+ ((crlf-carry complex-double-reg))))
+ ((copied unsigned-reg positive-fixnum)
+ (written unsigned-reg positive-fixnum))
+
+
+ (inst add byte-array* byte-array* (lsr byte-start 1))
+ (inst mov byte-array byte-array*)
+ (inst add byte-end byte-array* (lsr byte-end 1))
+
+ (inst add string-end string* (lsl string-end (- 2 n-fixnum-tag-bits)))
+ (inst add string string* (lsl string-start (- 2 n-fixnum-tag-bits)))
+ (inst mov tmp-tn #x0A0D)
+ (inst dup crlf-mask tmp-tn :8h)
+ (load-inline-constant powers :oword #x80402010080402018040201008040201)
+ (load-inline-constant crlf-table
+ (let ((table (make-array (* 256 16) :element-type '(unsigned-byte 8))))
+ (loop for row below 256
+ do (loop with indexes = (loop for i below 16
+ unless (logbitp i row)
+ collect i)
+ for column below 16
+ for index = (or (pop indexes)
+ #xFF)
+ do
+ (setf (aref table (+ (* row 16) column))
+ index)))
+ table))
+ ($when $sized
+ (inst add size-buffer size-buffer (lsr string-start 1))
+ (inst movi ones 1 :16b)
+ (inst movi crlf-carry 0 :16b))
+ (inst ldr s1 (@ byte-array))
+ (inst b start)
+
+ ASCII-LOOP
+ (inst mov bytes s1 :16b)
+ (inst ldr s1 (@ byte-array 16))
+
+ (inst umaxv temp1 bytes :16b)
+ (inst umov tmp-tn temp1 0 :b)
+ (inst tbnz tmp-tn 7 NOT-ASCII)
+
+ (inst add byte-array byte-array 16)
+
+ ;; Shift bytes right to find CRLF starting at odd indexes
+ ;; and grab the first byte from the next vector to check if it
+ ;; it's an LF
+ (inst ext temp2 bytes s1 1 :16b)
+ ;; Compare both variants
+ (inst cmeq temp1 bytes crlf-mask :8h)
+ (inst cmeq temp2 temp2 crlf-mask :8h)
+
+ ;; SLI retains the destination parts, matching elements
+ ;; will have FFFF, shifting and inserting will combine
+ ;; them with zeros producing just one FF
+ (inst sli temp1 temp2 8 :8h)
+
+ ($when $sized
+ ;; Move 0xFF to the place of LF
+ (inst ext shuf-low crlf-carry temp1 15 :16b)
+ (inst mov crlf-carry temp1 :16b)
+ (inst sub shuf-low ones shuf-low :16b))
+
+ ;; Count matches
+ (inst addv temp2 temp1 :8b)
+ (inst smov char-count temp2 0 :b)
+
+ ;; powers has powers of two for each byte index,
+ ;; adding them together will produce an 8-bit mask.
+ (inst and temp2 temp1 powers :16b)
+
+ (inst addv temp3 temp2 :8b)
+ (inst umov tmp-tn temp3 0 :b)
+
+ (inst ldr temp4 (@ crlf-table (lsl tmp-tn 4)))
+ (inst tbl temp3 (list bytes) temp4 :8b)
+ ($when $sized
+ (inst tbl temp4 (list shuf-low) temp4 :8b)
+ (inst str temp4 (@ size-buffer 8 :post-index) :d)
+ (inst add size-buffer size-buffer char-count))
+
+ ;; Widen
+ (inst ushll temp3 :8h temp3 :8b)
+ (inst ushll temp4 :4s temp3 :4h)
+ (inst ushll2 s2 :4s temp3 :8h)
+ (inst stp temp4 s2 (@ string 32 :post-index))
+ (inst add string string (lsl char-count 2))
+
+ ;; Second half
+
+ ;; Count matches
+ (inst ins temp3 0 temp1 1 :d)
+ (inst addv temp3 temp3 :8b)
+ (inst smov char-count temp3 0 :b)
+ (inst ins temp2 0 temp2 1 :d)
+ (inst addv temp2 temp2 :8b)
+ (inst umov tmp-tn temp2 0 :b)
+ (inst ldr temp4 (@ crlf-table (lsl tmp-tn 4)))
+ (inst ins bytes 0 bytes 1 :d)
+ (inst tbl temp1 (list bytes) temp4 :8b)
+ ($when $sized
+ (inst ins shuf-low 0 shuf-low 1 :d)
+ (inst tbl temp4 (list shuf-low) temp4 :8b)
+ (inst str temp4 (@ size-buffer 8 :post-index) :d)
+ (inst add size-buffer size-buffer char-count))
+
+ (inst ushll temp1 :8h temp1 :8b)
+ (inst ushll temp4 :4s temp1 :4h)
+ (inst ushll2 s2 :4s temp1 :8h)
+ (inst stp temp4 s2 (@ string 32 :post-index))
+ (inst add string string (lsl char-count 2))
+
+ start
+ (inst cmp byte-array byte-end)
+ (inst b :ge DONE)
+ (inst cmp string string-end)
+ (inst b :ge DONE)
+ (inst b ASCII-LOOP)
+
+ NOT-ASCII
+ (inst movi nibble-mask #x0f :16b)
+
+ (load-inline-constant tbl1 :oword #x38060001000000000000000000000000)
+ (load-inline-constant tbl2 :oword #x2020242020202020202020100000010B)
+ (load-inline-constant tbl3 :oword #x202020203535332B2020202020202020)
+ (load-inline-constant tbl4 :oword #x08040202000000000000000000000000)
+
+
+ (inst movi prev 0 :16b)
+ (inst movi prev-len 0 :16b)
+ (inst movi c-c0 #xc0 :16b)
+ (inst movi c-ff #xFF :8h)
+ (inst movi c-4 4 :4s)
+ (inst mov suffix 0)
+ ($when $sized
+ (inst movi length1 4 :16b)
+ (load-inline-constant length2 :oword #x01010101010101020202020303030303))
+
+ (load-inline-constant tag-clear :oword #x070F1F1F3F3F3F3F7F7F7F7F7F7F7F7F)
+ (load-inline-constant full-table (coerce (loop for index below (ash 1 10)
+ for low-index = (ldb (byte 8 0) index)
+ for suffix = (ldb (byte 2 8) index)
+ append (let ((starts (loop for i to 7
+ when (logbitp i low-index)
+ collect i)))
+ (loop for lane below 8
+ for start = (pop starts)
+ for next = (car starts)
+
+ for sources = (when start
+ (loop for i from (1- (or next
+ (+ suffix 8))) downto start
+ collect i))
+ append (loop for byte below 4
+ collect (or (pop sources) #xFF)))))
+ '(vector (unsigned-byte 8))))
+
+ (flet ((validate ()
+ (assemble ()
+ ;; The Keiser, Lemire algorithm
+ (inst ext temp1 prev bytes 15 :16b)
+ (inst ushr temp2 temp1 4 :16b)
+ (inst and temp3 temp1 nibble-mask :16b)
+ (inst ushr temp4 bytes 4 :16b)
+
+ (inst tbl temp2 (list tbl1) temp2 :16b)
+ (inst tbl temp3 (list tbl2) temp3 :16b)
+ (inst tbl temp4 (list tbl3) temp4 :16b)
+
+ (inst and temp2 temp2 temp3 :16b)
+ (inst and s1 temp2 temp4 :16b)
+
+ (inst ushr temp1 bytes 4 :16b)
+ (inst tbl temp1 (list tbl4) temp1 :16b)
+
+ (inst ext temp2 prev-len temp1 15 :16b)
+ (inst ext temp3 prev-len temp1 14 :16b)
+ (inst ext temp4 prev-len temp1 13 :16b)
+
+ (inst ushr temp2 temp2 1 :16b)
+ (inst ushr temp3 temp3 2 :16b)
+ (inst ushr temp4 temp4 3 :16b)
+
+ (inst orr temp2 temp2 temp3 :16b)
+ (inst orr temp2 temp2 temp4 :16b)
+
+ (inst cmgt temp3 c-c0 bytes :16b) ;; continuations
+
+ (inst cmtst temp4 temp2 temp2 :16b)
+
+ (inst eor temp4 temp3 temp4 :16b)
+ (inst orr s1 s1 temp4 :16b)
+
+ (inst umaxv temp4 s1 :16b)
+ (inst umov tmp-tn temp4 0 :b)
+ (inst cbnz tmp-tn ERROR)
+
+ ;; convert-full consumes only 8
+ (inst ext prev-len prev-len temp1 8 :16b)
+ (inst ext prev prev bytes 8 :16b)
+
+ VALIDATED))
+ (remove-crlf ()
+ ;; Count leading bytes before more are dragged in after removing CR
+ (inst cmge temp1 bytes c-c0 :8b)
+ (inst addv temp2 temp1 :8b)
+ ;; A negated number of produced characters
+ (inst smov char-count temp2 0 :b)
+
+ ;; Shift bytes right to find CRLF starting at odd indexes
+ (inst ext temp2 bytes bytes 1 :16b)
+
+
+ ;; Compare both variants
+ (inst cmeq temp1 bytes crlf-mask :4h)
+ (inst cmeq temp2 temp2 crlf-mask :4h)
+
+ ;; SLI retains the destination parts, matching elements
+ ;; will have FFFF, shifting and inserting will combine
+ ;; them with zeros producing just one FF
+ (inst sli temp1 temp2 8 :4h)
+
+ ($when $sized
+ ;; Move 0xFF to the place of LF
+ (inst ext temp4 crlf-carry temp1 15 :16b)
+ (inst ins crlf-carry 1 temp1 0 :d))
+
+ ;; Count matches
+ (inst addv temp2 temp1 :8b)
+ (inst smov tmp-tn temp2 0 :b)
+
+ (inst sub char-count char-count tmp-tn)
+
+ (inst and temp2 temp1 powers :8b)
+ (inst addv temp3 temp2 :8b)
+ (inst umov tmp-tn temp3 0 :b)
+
+ (inst ldr temp3 (@ crlf-table (lsl tmp-tn 4)))
+ (inst tbl bytes (list bytes) temp3 :16b)
+ ($when $sized
+ (inst tbl temp4 (list temp4) temp3 :16b)))
+ (convert-full ()
+ ;; Process the leading bytes in the first 8 bytes, loading 16 bytes
+ ;; so that the last leading byte might drag in 3 more bytes
+
+ ;; Identify leading bytes
+ (inst cmge temp1 bytes c-c0 :16b)
+
+ ;; Turn them into an 8 bit index
+ (inst and temp2 temp1 powers :8b)
+ (inst addv temp3 temp2 :8b)
+ (inst umov index temp3 0 :b)
+
+ ;; Need to know where the last leading byte ends
+ (inst umov suffix temp1 1 :d)
+ ;; Count the number of bytes to the next leading byte, turning it into a 2 bit suffix
+ (inst rbit suffix suffix)
+ (inst clz suffix suffix)
+ ;; Bytes to bits
+ (inst lsr suffix suffix 3)
+
+ ;; Add the size of the last character, ensuring that only 2 bits are added
+ (inst bfm index suffix 56 1)
+
+ (inst add tmp-tn full-table (lsl index 5))
+ (inst ld1 (list shuf-low shuf-high) (@ tmp-tn) :16b)
+
+ ;; Use the high 4 bits of each byte to get an and-mask that
+ ;; will clear their tags
+ (inst ushr temp2 bytes 4 :16b)
+ (inst tbl temp2 (list tag-clear) temp2 :16b)
+ (inst and bytes bytes temp2 :16b)
+
+
+
+
+
+ ;; Shuffle the bytes into 4-byte lanes
+ (inst tbl chars-low (list bytes) shuf-low :16b)
+ (inst tbl chars-high (list bytes) shuf-high :16b)
+
+ (flet ((decode-lane (chars)
+ ;; Perform
+ ;; A + B<<6 + C<<12 + D<<18
+ ;; =>
+ ;; A + B<<6 + ((C + D<<6) << 12)
+
+ ;; [D, 0, B, 0]
+ (inst bic s1 chars c-ff :16b)
+ ;; [0, C, 0, A]
+ (inst and s2 chars c-ff :16b)
+ ;; Combine into two 12-bit blocks per 32-bit lane: [L1, L0]
+ (inst usra s2 s1 2 :8h)
+ ;; Shift L0 left by 4, leave L1 alone: [L1, L0 << 4]
+ (inst ushl s2 s2 c-4 :8h)
+ ;; Shift each 32-bit lane right by 4
+ (inst ushr chars s2 4 :4s)))
+
+ (decode-lane chars-low)
+ (decode-lane chars-high)
+ (inst st1 (list chars-low chars-high) (@ string) :16b))
+ ($when $sized
+ ;; CRLF sizes
+ (inst tbl s1 (list temp4) shuf-low :16b)
+ (inst tbl s2 (list temp4) shuf-high :16b)
+ (inst uzp1 temp4 s1 s2 :8h)
+ (inst xtn temp4 temp4 :8b)
+
+ (inst clz chars-low chars-low :4s)
+ (inst clz chars-high chars-high :4s)
+ (inst uzp1 temp2 chars-low chars-high :8h)
+ (inst xtn temp2 temp2 :8b)
+ (inst tbl temp2 (list length1 length2) temp2 :8b)
+
+ ;; Add CRLF
+ (inst sub temp2 temp2 temp4 :8b)
+ ;; #\Nul clzs to 32, out of range for the table
+ (inst umax temp2 temp2 ones :8b)
+ (inst str temp2 (@ size-buffer) :d)
+ (inst sub size-buffer size-buffer char-count))
+
+ (inst add byte-array byte-array 8)
+ (inst sub string string (lsl char-count 2))))
+ (assemble ()
+ FULL-LOOP
+ (inst ldr bytes (@ byte-array))
+ (validate)
+ ;; (convert-full)
+ ;; (inst cmp byte-array byte-end)
+ ;; (inst b :ge FULL-DONE)
+ ;; (inst cmp string string-end)
+ ;; (inst b :ge FULL-DONE)
+ (remove-crlf)
+ (convert-full)
+ (inst cmp byte-array byte-end)
+ (inst b :ge FULL-DONE)
+ (inst cmp string string-end)
+ (inst b :ge FULL-DONE)
+ (inst b FULL-LOOP)))
+
+ ERROR
+ FULL-DONE
+
+ (inst add byte-array byte-array suffix) ;; strip any consumed continuations bytes
+ DONE
+ (inst sub copied byte-array byte-array*)
+ (inst sub written string string*)
+ (inst lsr written written 2))
+ (setf (sb-impl::buffer-head ibuf) (+ head copied))
+ (truly-the index written))))))
(defun character-string-to-utf8 (start end string obuf)
(declare (type index start end)
diff --git a/src/code/external-formats/enc-basic.lisp b/src/code/external-formats/enc-basic.lisp
index be97cd897..6ec6efd02 100644
--- a/src/code/external-formats/enc-basic.lisp
+++ b/src/code/external-formats/enc-basic.lisp
@@ -706,8 +706,8 @@
(loop for i below length
do (setf (aref string i) (code-char (sap-ref-8 sap i)))))
-#+(and sb-unicode 64-bit little-endian)
-(defun sb-vm::utf8-crlf-to-character-string-with-size (start end string ibuf size-buffer)
+#+(and sb-unicode 64-bit little-endian (not arm64))
+(defun sb-vm::utf8-crlf-to-character-string-sized (start end string ibuf size-buffer)
(declare (type index start end)
(optimize speed (safety 0)))
(with-pinned-objects (string size-buffer)
@@ -947,7 +947,7 @@
(())
#+(and sb-unicode 64-bit little-endian)
(setf index
- (sb-vm::utf8-crlf-to-character-string-with-size index end string (fd-stream-ibuf stream) size-buffer))
+ (sb-vm::utf8-crlf-to-character-string-sized index end string (fd-stream-ibuf stream) size-buffer))
(let* ((ibuf (fd-stream-ibuf stream))
(head (buffer-head ibuf))
(tail (buffer-tail ibuf))
diff --git a/src/compiler/arm64/insts.lisp b/src/compiler/arm64/insts.lisp
index 2a7518c14..21d736741 100644
--- a/src/compiler/arm64/insts.lisp
+++ b/src/compiler/arm64/insts.lisp
@@ -3736,6 +3736,9 @@
(define-instruction ext (segment rd rn rm index size)
(:printer simd-extract ())
(:emitter
+ (ecase size
+ (:8b (the (mod 8) index))
+ (:16b (the (mod 16) index)))
(emit-simd-extract segment
(encode-vector-size size)
(fpr-offset rm)
diff --git a/tests/utf-8.pure.lisp b/tests/utf-8.pure.lisp
index 1ed9aafbb..caf3120db 100644
--- a/tests/utf-8.pure.lisp
+++ b/tests/utf-8.pure.lisp
@@ -388,6 +388,7 @@
(loop for x from 78 by 78 below 2048
do (setf (aref string x) #\Newline))
(setf (aref string 24) #\LATIN_SMALL_LETTER_E_WITH_ACUTE) ; 2-bytes in UTF-8
+ (setf (aref string 23) #\Nul)
(with-open-file (s *test-path* :direction :output :external-format :utf-8 :if-exists :supersede)
(write-sequence string s))
(with-open-file (s *test-path* :external-format :utf-8)
@@ -409,6 +410,7 @@
(let ((string (make-string 2048 :initial-element #\x)))
(loop for x from 78 by 78 below 2048
do (setf (aref string x) #\Newline))
+ (setf (aref string 23) #\Nul)
(setf (aref string 24) #\LATIN_SMALL_LETTER_E_WITH_ACUTE) ; 2-bytes in UTF-8
(with-open-file (s *test-path* :direction :output
:external-format '(:utf-8 :newline :crlf) :if-exists :supersede)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL