master: Out of bounds in simd-copy-character-string-to-utf8-byte-array too
stassats via Sbcl-commits <[email protected]> Thu, 09 Jul 2026 02:01:27 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 6ae12b7cd82aa1cd9718c5abd5d3580ed1c15cda (commit)
from c61d1ca77b19beb3b53b4d216392bc6d8b78ac22 (commit)
- Log -----------------------------------------------------------------
commit 6ae12b7cd82aa1cd9718c5abd5d3580ed1c15cda
Author: Stas Boukarev <[email protected]>
Date: Thu Jul 9 03:24:10 2026 +0300
Out of bounds in simd-copy-character-string-to-utf8-byte-array too
---
contrib/sb-posix/interface.lisp | 2 +
src/code/arm64-simd.lisp | 82 +++++++++++++++---------------
src/code/x86-64-simd.lisp | 105 +++++++++++++++++++--------------------
tests/utf-8.impure.lisp | 107 ++++++++++++++++++++++++++++++++++++++++
4 files changed, 201 insertions(+), 95 deletions(-)
diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index be51a8a6d..5a71902cc 100644
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -559,6 +559,8 @@ not supported."
(define-call "munmap" int minusp
(start sb-sys:system-area-pointer) (length unsigned))
+ (define-call "mprotect" int minusp
+ (addr system-area-pointer) (length size-t) (prot unsigned))
(define-call "msync" int minusp
(addr sb-sys:system-area-pointer) (length unsigned) (flags int)))
diff --git a/src/code/arm64-simd.lisp b/src/code/arm64-simd.lisp
index b4a4d3ed6..eddb989d8 100644
--- a/src/code/arm64-simd.lisp
+++ b/src/code/arm64-simd.lisp
@@ -1761,9 +1761,7 @@
(inst cmp byte-index n)
(inst b :le LOOP)
- ;; In the last iteration, did it consume 9 or 8 bytes?
- (inst umov tmp current 7 :b)
- (inst b ADJUST)
+ (inst b DONE)
TAIL-16
(inst movi mask-2 #xFFFFFFFF)
@@ -1774,49 +1772,44 @@
(inst add byte-index byte-index 4)
(inst add char-index char-index 4)
(inst add char-index char-index tmp)
-
- ;; In the last iteration, did it consume 5 or 4 bytes?
- (inst umov tmp current 3 :b)
- ADJUST
- ;; the last current byte is a leading byte, meaning
- ;; the first next byte is a continuation byte
- (inst cmp tmp #xC0)
- (inst csinc byte-index byte-index byte-index :lt)
-
DONE))))
- (loop while (< byte-index length) do
- (let ((b0 (sap-ref-8 sap byte-index)))
- (cond
- ((< b0 #x80)
- (setf (schar string char-index) (code-char b0))
- (incf byte-index 1))
- ((< b0 #xE0)
- (let ((b1 (sap-ref-8 sap (+ byte-index 1))))
- (setf (schar string char-index)
- (code-char (dpb b0 (byte 5 6) b1)))
- (incf byte-index 2)))
- ((< b0 #xF0)
- (let ((b1 (sap-ref-8 sap (+ byte-index 1)))
- (b2 (sap-ref-8 sap (+ byte-index 2))))
- (setf (schar string char-index)
- (code-char (dpb b0 (byte 4 12)
- (dpb b1 (byte 6 6) b2))))
- (incf byte-index 3)))
- (t
- (let ((b1 (sap-ref-8 sap (+ byte-index 1)))
- (b2 (sap-ref-8 sap (+ byte-index 2)))
- (b3 (sap-ref-8 sap (+ byte-index 3))))
- (setf (schar string char-index)
- (code-char (dpb b0 (byte 3 18)
- (dpb b1 (byte 6 12)
- (dpb b2 (byte 6 6) b3)))))
- (incf byte-index 4)))))
- (incf char-index))
+ (when (< byte-index length)
+ (when (= (ldb (byte 2 6) (sap-ref-8 sap byte-index)) #b10)
+ ;; A continuation byte consumed by the previous byte in the simd loop
+ (incf byte-index))
+ (loop while (< byte-index length) do
+ (let ((b0 (sap-ref-8 sap byte-index)))
+ (cond
+ ((< b0 #x80)
+ (setf (schar string char-index) (code-char b0))
+ (incf byte-index))
+ ((< b0 #xE0)
+ (let ((b1 (sap-ref-8 sap (+ byte-index 1))))
+ (setf (schar string char-index)
+ (code-char (dpb b0 (byte 5 6) b1)))
+ (incf byte-index 2)))
+ ((< b0 #xF0)
+ (let ((b1 (sap-ref-8 sap (+ byte-index 1)))
+ (b2 (sap-ref-8 sap (+ byte-index 2))))
+ (setf (schar string char-index)
+ (code-char (dpb b0 (byte 4 12)
+ (dpb b1 (byte 6 6) b2))))
+ (incf byte-index 3)))
+ (t
+ (let ((b1 (sap-ref-8 sap (+ byte-index 1)))
+ (b2 (sap-ref-8 sap (+ byte-index 2)))
+ (b3 (sap-ref-8 sap (+ byte-index 3))))
+ (setf (schar string char-index)
+ (code-char (dpb b0 (byte 3 18)
+ (dpb b1 (byte 6 12)
+ (dpb b2 (byte 6 6) b3)))))
+ (incf byte-index 4))))
+ (incf char-index))))
char-index))
(defun simd-copy-character-string-to-utf8-byte-array (byte-array string byte-array-length)
- (declare (ignore byte-array-length)
+ (declare (index byte-array-length)
(simple-character-string string)
((simple-array (unsigned-byte 8) (*)) byte-array)
(optimize speed (safety 0)))
@@ -1839,6 +1832,7 @@
(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))
((32-bit-array sap-reg t :from (:argument 0)))
((tmp unsigned-reg))
@@ -1861,6 +1855,8 @@
(load-inline-constant powers :qword (concat-ub 8 '(128 64 32 16 8 4 2 1)))
(flet ((convert (size)
+ (inst cmp byte-array-length (/ size 2))
+ (inst b :lt DONE)
(multiple-value-bind (h-size b-size)
(ecase size
(32
@@ -1918,7 +1914,9 @@
(when (eq size 32)
(inst smov tmp ascii-count 0 :b)
(inst add byte-index byte-index 16)
- (inst add byte-index byte-index tmp)))))
+ (inst add byte-index byte-index tmp)
+ (inst sub byte-array-length byte-array-length 16)
+ (inst sub byte-array-length byte-array-length tmp)))))
(assemble ()
(inst mov byte-index 0)
(inst mov char-index 0)
diff --git a/src/code/x86-64-simd.lisp b/src/code/x86-64-simd.lisp
index 9c6c79ea1..9fcc0bc7c 100644
--- a/src/code/x86-64-simd.lisp
+++ b/src/code/x86-64-simd.lisp
@@ -2266,7 +2266,7 @@
DONE)))
-(defun simd-copy-utf8-sap-to-character-string (sap string length)
+(def-variant simd-copy-utf8-sap-to-character-string :avx2 (sap string length)
(declare (optimize speed (safety 0))
(type system-area-pointer sap)
(type index length)
@@ -2275,7 +2275,7 @@
(char-index 0)
(table (load-time-value (let ((table (make-array (* #b10101011 16) :element-type '(unsigned-byte 8)
:initial-element #xFF)))
- (loop for row to #b10101010 ;; highest possible inverted index for compressing 1/2 bytes
+ (loop for row to #b10101010 ;; highest possible inverted index for compressing 1/2 bytes
do (loop with indexes = (loop for i below 8
unless (logbitp i row)
collect (* i 2)
@@ -2385,9 +2385,7 @@
(inst cmp byte-index n)
(inst jmp :le LOOP)
- ;; In the last iteration, did it consume 9 or 8 bytes?
- (inst vpextrb tmp current 7)
- (inst jmp ADJUST)
+ (inst jmp DONE)
TAIL-16
(inst and :dword tmp #xF0)
(inst popcnt :dword tmp tmp)
@@ -2399,50 +2397,43 @@
(inst add byte-index 4)
(inst add char-index tmp)
- ;; In the last iteration, did it consume 5 or 4 bytes?
- (inst vpextrb tmp current 3)
- ADJUST
- ;; the last current byte is a leading byte, meaning
- ;; the first next byte is a continuation byte
- (inst cmp tmp #xC0)
- (inst jmp :l DONE)
- (inst inc byte-index)
-
- (inst vzeroupper)
- DONE))))
- (loop while (< byte-index length) do
- (let ((b0 (sap-ref-8 sap byte-index)))
- (cond
- ((< b0 #x80)
- (setf (schar string char-index) (code-char b0))
- (incf byte-index 1))
- ((< b0 #xE0)
- (let ((b1 (sap-ref-8 sap (+ byte-index 1))))
- (setf (schar string char-index)
- (code-char (dpb b0 (byte 5 6) b1)))
- (incf byte-index 2)))
- ((< b0 #xF0)
- (let ((b1 (sap-ref-8 sap (+ byte-index 1)))
- (b2 (sap-ref-8 sap (+ byte-index 2))))
- (setf (schar string char-index)
- (code-char (dpb b0 (byte 4 12)
- (dpb b1 (byte 6 6) b2))))
- (incf byte-index 3)))
- (t
- (let ((b1 (sap-ref-8 sap (+ byte-index 1)))
- (b2 (sap-ref-8 sap (+ byte-index 2)))
- (b3 (sap-ref-8 sap (+ byte-index 3))))
- (setf (schar string char-index)
- (code-char (dpb b0 (byte 3 18)
- (dpb b1 (byte 6 12)
- (dpb b2 (byte 6 6) b3)))))
- (incf byte-index 4)))))
- (incf char-index))
-
- char-index))
+ DONE
+ (inst vzeroupper)))))
+ (when (< byte-index length)
+ (when (= (ldb (byte 2 6) (sap-ref-8 sap byte-index)) #b10)
+ ;; A continuation byte consumed by the previous byte in the simd loop
+ (incf byte-index))
+ (loop while (< byte-index length) do
+ (let ((b0 (sap-ref-8 sap byte-index)))
+ (cond
+ ((< b0 #x80)
+ (setf (schar string char-index) (code-char b0))
+ (incf byte-index))
+ ((< b0 #xE0)
+ (let ((b1 (sap-ref-8 sap (+ byte-index 1))))
+ (setf (schar string char-index)
+ (code-char (dpb b0 (byte 5 6) b1)))
+ (incf byte-index 2)))
+ ((< b0 #xF0)
+ (let ((b1 (sap-ref-8 sap (+ byte-index 1)))
+ (b2 (sap-ref-8 sap (+ byte-index 2))))
+ (setf (schar string char-index)
+ (code-char (dpb b0 (byte 4 12)
+ (dpb b1 (byte 6 6) b2))))
+ (incf byte-index 3)))
+ (t
+ (let ((b1 (sap-ref-8 sap (+ byte-index 1)))
+ (b2 (sap-ref-8 sap (+ byte-index 2)))
+ (b3 (sap-ref-8 sap (+ byte-index 3))))
+ (setf (schar string char-index)
+ (code-char (dpb b0 (byte 3 18)
+ (dpb b1 (byte 6 12)
+ (dpb b2 (byte 6 6) b3)))))
+ (incf byte-index 4))))
+ (incf char-index))))))
(def-variant simd-copy-character-string-to-utf8-byte-array :avx2 (byte-array string byte-array-length)
- (declare (ignore byte-array-length)
+ (declare (index byte-array-length)
(simple-character-string string)
((simple-array (unsigned-byte 8) (*)) byte-array)
(optimize speed (safety 0)))
@@ -2465,6 +2456,7 @@
(inline-vop (((byte-array sap-reg t) (vector-sap byte-array))
((32-bit-array sap-reg t) (vector-sap string))
((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))
((tmp unsigned-reg))
((temp complex-double-reg))
@@ -2497,15 +2489,20 @@
(inst vpbroadcastd mask-7ff temp)
(inst vpxor zero zero zero)
(flet ((convert (size)
- (let ((bytes (reg-in-sc bytes size))
- (temp (reg-in-sc temp size)))
+ (inst cmp byte-array-length (/ size 2))
+ (inst jmp :l DONE)
+ (let* ((sc (ecase size
+ (32 'int-avx2-reg)
+ (16 'int-sse-reg)))
+ (bytes (reg-in-sc bytes sc))
+ (temp (reg-in-sc temp sc)))
(inst vmovdqu bytes (ea 32-bit-array char-index))
;; Stop if anything is 3-4 bytes in utf8
(inst vpcmpgtd temp bytes mask-7ff)
(inst vptest temp temp)
(inst jmp :nz DONE)
;; Narrow to 16 bits
- (cond ((eq size 'int-avx2-reg)
+ (cond ((eq size 32)
(inst vpackusdw bytes bytes bytes)
(inst vpermq bytes bytes 216))
(t
@@ -2535,7 +2532,7 @@
(inst and tmp 255)
(inst shl :dword tmp 4)
(inst vpshufb bytes bytes (ea table tmp))
- (if (eq size 'int-avx2-reg)
+ (if (eq size 32)
(inst vmovdqu (ea byte-index byte-array) bytes)
(inst vmovq (ea byte-index byte-array) bytes))))
(assemble ()
@@ -2545,19 +2542,21 @@
(inst sub n 32)
(inst jmp :b TAIL)
LOOP
- (convert 'int-avx2-reg)
+ (convert 32)
(inst add byte-index 16)
(inst add char-index 32)
(inst popcnt tmp tmp)
(inst sub byte-index tmp)
+ (inst sub byte-array-length 16)
+ (inst add byte-array-length tmp)
(inst sub n 32)
(inst jmp :ae LOOP)
TAIL
(inst cmp :dword n -32)
(inst jmp :z DONE)
- (convert 'int-sse-reg)
+ (convert 16)
(inst add char-index 16)))
DONE
(inst vzeroupper))
diff --git a/tests/utf-8.impure.lisp b/tests/utf-8.impure.lisp
new file mode 100644
index 000000000..e5d57072d
--- /dev/null
+++ b/tests/utf-8.impure.lisp
@@ -0,0 +1,107 @@
+;;;; This file is for testing external-format functionality for UTF-8,
+;;;; using test machinery which does not have side effects. Note that
+;;;; the tests here reach into unexported functionality, and should
+;;;; not be used as a guide for users.
+
+;;;; 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.
+
+#+(or (not sb-unicode)
+ win32)
+(invoke-restart 'run-tests::skip-file)
+
+(require :sb-posix)
+
+(defconstant +page-size+ (extern-alien "os_reported_page_size" int))
+
+(defun free-protected-array (vector)
+ (let* ((addr (sb-sys:sap-int (sb-sys:vector-sap vector)))
+ (rw (logand addr (- +page-size+))))
+ (sb-posix:munmap (sb-sys:int-sap (- rw +page-size+))
+ (* +page-size+ 3))))
+
+(defun make-protected-array (length type align-to-start)
+ (multiple-value-bind (widetag shift) (sb-vm::%vector-widetag-and-n-bits-shift type)
+ (let* ((full-length (+ length (if (= widetag sb-vm::simple-base-string-widetag) 1 0)))
+ (bytes (sb-vm:pad-data-block
+ (+ sb-vm:vector-data-offset
+ (sb-vm::vector-length-in-words full-length shift))))
+ (whole (sb-posix:mmap nil (* +page-size+ 3)
+ (logior sb-posix:prot-read
+ sb-posix:prot-write)
+ (logior sb-posix:map-private sb-posix:map-anon) -1 0))
+ (rw (sb-sys:sap+ whole +page-size+))
+ (addr (sb-sys:sap+ rw (if align-to-start
+ 0
+ (- +page-size+ bytes))))
+ (vector (sb-kernel:%make-lisp-obj (logior (sb-sys:sap-int addr)
+ sb-vm:other-pointer-lowtag))))
+ (sb-posix:mprotect whole +page-size+ sb-posix:prot-none)
+ (sb-posix:mprotect (sb-sys:sap+ whole (* +page-size+ 2))
+ +page-size+ sb-posix:prot-none)
+ (setf (sb-sys:sap-ref-word addr 0) widetag)
+ (setf (sb-kernel:%array-fill-pointer vector) length)
+ vector)))
+
+(defun decode-test (vector string-length)
+ (sb-sys:with-pinned-objects (vector)
+ (let* ((length (length vector))
+ (string (make-protected-array string-length 'character nil)))
+ (unwind-protect
+ (progn (sb-vm::simd-copy-utf8-sap-to-character-string (sb-sys:vector-sap vector)
+ string
+ length)
+ (copy-seq string))
+
+ (free-protected-array string)))))
+
+(compile 'decode-test)
+
+(with-test (:name :decode-test)
+ (loop for length from 1 to 32
+ for string = (make-string length)
+ do
+ (loop repeat (* 500 #+slow 10)
+ do (map-into string (lambda ()
+ (code-char (random 4096))))
+ (let* ((octets (sb-ext:string-to-octets string))
+ (bytes (make-protected-array (length octets) '(unsigned-byte 8) nil)))
+ (unwind-protect
+ (progn (replace bytes octets)
+ (assert (equal (decode-test bytes length)
+ string)))
+ (free-protected-array bytes))))))
+
+(defun encode-test (string byte-length)
+ (let ((byte-array (make-protected-array byte-length '(unsigned-byte 8) nil)))
+ (unwind-protect
+ (progn (sb-vm::simd-copy-character-string-to-utf8-byte-array byte-array
+ string
+ byte-length)
+ (copy-seq byte-array))
+ (free-protected-array byte-array))))
+
+(compile 'encode-test)
+
+(with-test (:name :encode-test)
+ (loop for length from 1 to 32
+ for string = (make-protected-array length 'character nil)
+ do
+ (unwind-protect
+ (loop repeat (* 500 #+slow 10)
+ do (map-into string (lambda ()
+ (code-char (random 4096))))
+ (let* ((octets (sb-ext:string-to-octets string))
+ (result (encode-test string (length octets))))
+ (unless (equalp result octets)
+ (error "(encode-test ~s ~a) => ~a /= ~a" string (length octets)
+ result octets))))
+ (free-protected-array string))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL