master: arm64: full unicode decoding in utf8-crlf-to-character-string
stassats via Sbcl-commits <[email protected]> Thu, 30 Jul 2026 02:54:02 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 87357677a4f80935cef6d048afbbc413e39ded17 (commit)
from ff3913b27709be207ee201b872c3636ec23b7feb (commit)
- Log -----------------------------------------------------------------
commit 87357677a4f80935cef6d048afbbc413e39ded17
Author: Stas Boukarev <[email protected]>
Date: Thu Jul 30 04:37:49 2026 +0300
arm64: full unicode decoding in utf8-crlf-to-character-string
---
src/code/arm64-simd.lisp | 495 +++++++++++++++++++++++++----------
src/compiler/arm64/insts.lisp | 13 +-
src/compiler/arm64/target-insts.lisp | 16 +-
tests/compiler-ir.pure.lisp | 8 +-
tests/utf-8.impure.lisp | 66 ++++-
5 files changed, 439 insertions(+), 159 deletions(-)
diff --git a/src/code/arm64-simd.lisp b/src/code/arm64-simd.lisp
index e5c2ff8d5..ca717b2fa 100644
--- a/src/code/arm64-simd.lisp
+++ b/src/code/arm64-simd.lisp
@@ -563,8 +563,7 @@
((tbl4 complex-double-reg))
((nibble-mask complex-double-reg))
- ((twos complex-double-reg))
- ((c-c1 complex-double-reg))
+ ((ones complex-double-reg))
((c-c0 complex-double-reg))
((c-ff complex-double-reg))
((c-4 complex-double-reg))
@@ -600,7 +599,7 @@
(inst add string string* (lsl string-start (- 2 n-fixnum-tag-bits)))
($when $sized
(inst add size-buffer size-buffer (lsr string-start 1))
- (inst movi twos 1 :16b))
+ (inst movi ones 1 :16b))
(inst b start)
@@ -624,7 +623,7 @@
(inst stp temp2 temp4 (@ string -32))
($when $sized
- (inst str twos (@ size-buffer 16 :post-index))) ;; actually ones
+ (inst str ones (@ size-buffer 16 :post-index)))
start
(inst cmp byte-array byte-end)
@@ -635,7 +634,6 @@
NOT-ASCII
(inst movi nibble-mask #x0f :16b)
- (inst movi twos 2 :16b)
(load-inline-constant tbl1 :oword #x38060001000000000000000000000000)
(load-inline-constant tbl2 :oword #x2020242020202020202020100000010B)
@@ -646,7 +644,6 @@
(inst movi prev 0 :16b)
(inst movi prev-len 0 :16b)
(inst movi c-c0 #xc0 :16b)
- (inst movi c-c1 #xc1 :16b)
(inst movi c-ff #xFF :8h)
(inst movi c-4 4 :4s)
(inst mov suffix 0)
@@ -1093,140 +1090,358 @@
(truly-the index (+ start copied)))))))
(defun utf8-crlf-to-character-string (start end string ibuf)
- (declare (type index start end)
- (optimize speed (safety 0)))
- (let* ((head (sb-impl::buffer-head ibuf))
- (tail (sb-impl::buffer-tail ibuf))
- (n (logand (min (- end start)
- (- (- tail head) 16)) ;; read one more chunk
- (- 16)))
- (shuffle-table (load-time-value (let ((table (make-array (* 256 8) :element-type '(unsigned-byte 8))))
- (loop for row below 256
- do (loop with indexes = (loop for i below 8
- unless (logbitp i row)
- collect i)
- for column below 8
- for index = (or (pop indexes)
- 0)
- do
- (setf (aref table (+ (* row 8) column))
- index)))
- table))))
-
- (if (<= n 0)
- start
- (with-pinned-objects-in-registers (string shuffle-table)
- (multiple-value-bind (new-head copied)
- (inline-vop (((byte-array* sap-reg t) (sb-impl::buffer-sap ibuf))
- ((byte-array sap-reg t))
- ((char-array* sap-reg t) (vector-sap string))
- ((char-array sap-reg t))
- ((crlf-mask complex-double-reg))
- ((bytes complex-double-reg))
- ((next-bytes complex-double-reg))
- ((shifted complex-double-reg))
- ((temp complex-double-reg))
- ((temp2 complex-double-reg))
- ((temp3 complex-double-reg))
- ((string-start any-reg) start)
- ((end any-reg) n)
- ((head any-reg) head)
- ((bit-mask complex-double-reg))
- ((shuffle-table sap-reg) (vector-sap shuffle-table))
- ((shuffle-mask complex-double-reg))
- ((shuffle-mask2 complex-double-reg))
- ((16-bits complex-double-reg))
- ((32-bits complex-double-reg))
- ((32-bits-2 complex-double-reg))
- ((count unsigned-reg)))
- ((new-head unsigned-reg positive-fixnum :from :load)
- (copied unsigned-reg positive-fixnum :from :load))
- (inst mov tmp-tn #x0A0D)
- (inst dup crlf-mask tmp-tn :8h)
-
- (inst add byte-array byte-array* (lsr head 1))
- (inst add end byte-array (lsr end 1))
-
- (inst add char-array* char-array* (lsl string-start (- 2 1)))
- (inst mov char-array char-array*)
-
- (load-inline-constant bit-mask :oword
- (concat-ub 8 (append (loop for i downfrom 7 to 0
- collect (ash 1 i))
- (loop for i downfrom 7 to 0
- collect (ash 1 i)))))
- (inst ldr next-bytes (@ byte-array))
- (check-ascii next-bytes temp DONE)
-
- LOOP
- (inst mov bytes next-bytes :16b)
- (inst ldr next-bytes (@ byte-array 16))
- (check-ascii next-bytes temp DONE)
- (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 shifted bytes next-bytes 1 :16b)
- ;; Compare both variants
- (inst cmeq temp bytes crlf-mask :8h)
- (inst cmeq temp2 shifted 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 temp temp2 8 :8h)
-
- ;; Count matches
- (inst addv temp2 temp :8b)
- (inst smov count temp2 0 :b)
-
- ;; bit-mask has powers of two for each byte index,
- ;; adding them together will produce an 8-bit mask.
- (inst and temp2 temp bit-mask :16b)
-
- (inst addv temp3 temp2 :8b)
- (inst umov tmp-tn temp3 0 :b)
- (inst ldr shuffle-mask (@ shuffle-table (lsl tmp-tn 3)) :d)
- (inst tbl temp3 (list bytes) shuffle-mask :8b)
-
- ;; Widen
- (inst ushll 16-bits :8h temp3 :8b)
- (inst ushll 32-bits :4s 16-bits :4h)
- (inst ushll2 32-bits-2 :4s 16-bits :8h)
- (inst stp 32-bits 32-bits-2 (@ char-array 32 :post-index))
- (inst add char-array char-array (lsl count 2))
-
- ;; Second half
-
- ;; Count matches
- (inst ins temp3 0 temp 1 :d)
- (inst addv temp3 temp3 :8b)
- (inst smov 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 shuffle-mask2 (@ shuffle-table (lsl tmp-tn 3)) :d)
- (inst ins bytes 0 bytes 1 :d)
- (inst tbl temp (list bytes) shuffle-mask2 :8b)
-
- (inst ushll 16-bits :8h temp :8b)
- (inst ushll 32-bits :4s 16-bits :4h)
- (inst ushll2 32-bits-2 :4s 16-bits :8h)
- (inst stp 32-bits 32-bits-2 (@ char-array 32 :post-index))
- (inst add char-array char-array (lsl count 2))
-
- (inst cmp byte-array end)
- (inst b :lt LOOP)
-
- DONE
- (inst sub copied char-array char-array*)
- (inst sub new-head byte-array byte-array*))
- (setf (sb-impl::buffer-head ibuf) new-head)
- (truly-the index (+ start (ash copied -2))))))))
+ (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 (/ 32 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)))))
(defun character-string-to-utf8 (start end string obuf)
(declare (type index start end)
diff --git a/src/compiler/arm64/insts.lisp b/src/compiler/arm64/insts.lisp
index 36d8adb02..2a7518c14 100644
--- a/src/compiler/arm64/insts.lisp
+++ b/src/compiler/arm64/insts.lisp
@@ -1615,9 +1615,16 @@
(register shift extend)
(if (extend-p offset)
(values (extend-register offset)
- (if (> (extend-operand offset) 0)
- 1
- 0)
+ (cond ((> (extend-operand offset) 0)
+ (let ((allowed-offset (if (and fp
+ (not vector-size))
+ 4
+ size)))
+ (unless (= (extend-operand offset) allowed-offset)
+ (error "Offset can only be 0 or ~a, not ~a" allowed-offset (extend-operand offset))))
+ 1)
+ (t
+ 0))
(ecase (extend-kind offset)
(:uxtw #b010)
(:lsl #b011)
diff --git a/src/compiler/arm64/target-insts.lisp b/src/compiler/arm64/target-insts.lisp
index b28c17e47..56c63b87e 100644
--- a/src/compiler/arm64/target-insts.lisp
+++ b/src/compiler/arm64/target-insts.lisp
@@ -100,15 +100,13 @@
(#b111 "SXTX"))
stream))
(when (plusp amount)
- (if vector
- (format stream " #~a" (cond ((= opc 1)
- 4)
- (t
- size)
- ))
- (format stream " #~a" (if (= size #b11)
- 3
- 2))))))
+ (if vector
+ (format stream " #~a" (if (= opc 1)
+ 4
+ size))
+ (format stream " #~a" (if (= size #b11)
+ 3
+ 2))))))
(defun print-immediate (value stream dstate)
(declare (ignore dstate))
diff --git a/tests/compiler-ir.pure.lisp b/tests/compiler-ir.pure.lisp
index 4cf774ae8..2acddfcdd 100644
--- a/tests/compiler-ir.pure.lisp
+++ b/tests/compiler-ir.pure.lisp
@@ -308,8 +308,8 @@
;;; cannot. In this case, FM, F, G and H all have the same
;;; continuation.
#+sb-devel
-(with-test (:name (:assignment-convert :fluet-weeks-5.1
- :fails-on :sbcl))
+(with-test (:name (:assignment-convert :fluet-weeks-5.1)
+ :fails-on :sbcl)
(let ((converted '()))
(let ((fun (inspect-ir
'(lambda (b x y flag)
@@ -349,8 +349,8 @@
;;; analysis. In this case, F, G1, G2 and H all have the same
;;; continuation.
#+sb-devel
-(with-test (:name (:assignment-convert :fluet-weeks-5.2
- :fails-on :sbcl))
+(with-test (:name (:assignment-convert :fluet-weeks-5.2)
+ :fails-on :sbcl)
(let ((converted '()))
(let ((fun (inspect-ir
'(lambda (b x y flag)
diff --git a/tests/utf-8.impure.lisp b/tests/utf-8.impure.lisp
index 7814fb45d..74ba714cd 100644
--- a/tests/utf-8.impure.lisp
+++ b/tests/utf-8.impure.lisp
@@ -21,7 +21,7 @@
(require :sb-posix)
(defconstant +page-size+ (extern-alien "os_reported_page_size" int))
-
+(setf *random-state* (make-random-state t))
(defun free-protected-array (vector)
(let* ((addr (sb-sys:sap-int (sb-sys:vector-sap vector)))
(rw (logand addr (- +page-size+))))
@@ -257,7 +257,7 @@
(ibuf (sb-impl::alloc-buffer))
(string (make-protected-array 512 'character nil)))
(setf (sb-impl::buffer-tail ibuf) sb-impl::+bytes-per-buffer+)
- (loop repeat (* 512 #+slow 10)
+ (loop repeat (* 256 #+slow 10)
do
(map-into vector (lambda () (random 256)))
(setf (sb-impl::buffer-head ibuf) 0
@@ -269,4 +269,64 @@
(decoded (octets-to-string vector :end bad)))
(when bad
(assert (>= bad bytes)))
- (assert (string= string decoded :end1 chars :end2 chars))))))
+ (assert (string= string decoded :end1 chars :end2 chars))))
+ (let ((random-string (make-string sb-impl::+bytes-per-buffer+)))
+ (loop repeat (* 256 #+slow 10)
+ do
+ (fill-random-string random-string)
+ (replace vector (string-to-octets random-string))
+ (setf (sb-impl::buffer-head ibuf) 0
+ (sb-impl::buffer-tail ibuf) sb-impl::+bytes-per-buffer+)
+ (sb-kernel:copy-ub8-to-system-area vector 0 (sb-impl::buffer-sap ibuf) 0 (length vector))
+ (let* ((bad (validate-utf8 vector))
+ (chars (sb-vm::utf8-to-character-string 0 (length string) string ibuf))
+ (bytes (sb-impl::buffer-head ibuf))
+ (decoded (octets-to-string vector :end bad)))
+ (when bad
+ (assert (>= bad bytes)))
+ (assert (string= string decoded :end1 chars :end2 chars)))))))
+
+#+(or arm64 x86-64)
+(with-test (:name :utf8-crlf-to-character-string)
+ (let ((vector (make-array 1024 :element-type '(unsigned-byte 8)))
+ (ibuf (sb-impl::alloc-buffer))
+ (string (make-protected-array 512 'character nil)))
+ (setf (sb-impl::buffer-tail ibuf) sb-impl::+bytes-per-buffer+)
+ (loop repeat (* 256 #+slow 10)
+ do
+ (map-into vector (lambda () (random 256)))
+ (let ((crlf (random (1- (length vector)))))
+ (setf (aref vector crlf) #xd)
+ (setf (aref vector (1+ crlf)) #xa))
+
+ (setf (sb-impl::buffer-head ibuf) 0
+ (sb-impl::buffer-tail ibuf) 1024)
+ (sb-kernel:copy-ub8-to-system-area vector 0 (sb-impl::buffer-sap ibuf) 0 (length vector))
+ (let* ((bad (validate-utf8 vector))
+ (chars (sb-vm::utf8-crlf-to-character-string 0 (length string) string ibuf))
+ (bytes (sb-impl::buffer-head ibuf))
+ (decoded (octets-to-string vector :end bad)))
+ (when bad
+ (assert (>= bad bytes)))
+ (assert (string= string decoded :end1 chars :end2 chars))))
+ (let ((random-string (make-string sb-impl::+bytes-per-buffer+)))
+ (loop repeat (* 256 #+slow 10)
+ do
+ (fill-random-string random-string)
+ (replace vector (string-to-octets random-string))
+ (let ((crlf (random (1- (length vector)))))
+ (setf (aref vector crlf) #xd)
+ (setf (aref vector (1+ crlf)) #xa))
+
+ (setf (sb-impl::buffer-head ibuf) 0
+ (sb-impl::buffer-tail ibuf) 1024)
+ (sb-kernel:copy-ub8-to-system-area vector 0 (sb-impl::buffer-sap ibuf) 0 (length vector))
+ (let* ((bad (validate-utf8 vector))
+ (chars (sb-vm::utf8-crlf-to-character-string 0 (length string) string ibuf))
+ (bytes (sb-impl::buffer-head ibuf))
+ (decoded (octets-to-string vector :end bad
+ :external-format '(:utf8 :newline :crlf))))
+ (when bad
+ (assert (>= bad bytes)))
+ (unless (string= string decoded :end1 chars :end2 chars)
+ (error "~s" vector)))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL