common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Out of bounds in simd-copy-character-string-to-utf8-byte-array too

Browse source
This commit is contained in:
Stas Boukarev 2026-07-09 03:24:10 +03:00
parent c61d1ca77b
commit 6ae12b7cd8
4 changed files with 201 additions and 95 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
contrib/sb-posix/interface.lisp
View file

@ -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)))

32
src/code/arm64-simd.lisp
View file

@ -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,22 +1772,17 @@
(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))))
(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 1))
(incf byte-index))
((< b0 #xE0)
(let ((b1 (sap-ref-8 sap (+ byte-index 1))))
(setf (schar string char-index)
@ -1810,13 +1803,13 @@
(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))
(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)

53
src/code/x86-64-simd.lisp
View file

@ -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)
@ -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,23 +2397,18 @@
(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))))
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 1))
(incf byte-index))
((< b0 #xE0)
(let ((b1 (sap-ref-8 sap (+ byte-index 1))))
(setf (schar string char-index)
@ -2436,13 +2429,11 @@
(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))
(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))

107
tests/utf-8.impure.lisp Normal file
View file

@ -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))))