master: Speed up output-to-c-string/utf-8/lf
stassats via Sbcl-commits <[email protected]> Thu, 18 Jun 2026 00:58:26 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 836190da1c695b6e9070c24504f955f1ca32d769 (commit)
from 7ee71e8a92f54be5767ccb4a5331effa18ac5f19 (commit)
- Log -----------------------------------------------------------------
commit 836190da1c695b6e9070c24504f955f1ca32d769
Author: Stas Boukarev <[email protected]>
Date: Thu Jun 18 03:52:46 2026 +0300
Speed up output-to-c-string/utf-8/lf
---
src/code/external-formats/enc-basic.lisp | 110 ++++++++++++++++++++++++++++++-
src/code/fd-stream.lisp | 110 ++++++++++++++++---------------
2 files changed, 164 insertions(+), 56 deletions(-)
diff --git a/src/code/external-formats/enc-basic.lisp b/src/code/external-formats/enc-basic.lisp
index 2ecb4fe46..a903ad2ba 100644
--- a/src/code/external-formats/enc-basic.lisp
+++ b/src/code/external-formats/enc-basic.lisp
@@ -709,7 +709,7 @@
(sap (buffer-sap ibuf))
(n (logand (min (1- (- end start))
(1- (- tail head)))
- (- 2)))
+ -2))
(repeat (ldb (byte 16 0) #x0101010101010101))
(ascii-mask (* 128 repeat))
(string-sap (vector-sap string))
@@ -1194,6 +1194,7 @@
:write-n-bytes-fun output-bytes/utf-8/lf
:char-encodable-p (let ((bits (char-code |ch|))) (not (<= #xd800 bits #xdfff)))
:read-c-string-function read-from-c-string/utf-8/lf*
+ :output-c-string-function output-to-c-string/utf-8/lf
:handle-size nil)
(define-external-format/variable-width (:utf-8) t
@@ -1352,7 +1353,7 @@
(sap (buffer-sap ibuf))
(n (logand (min (1- (- end start))
(1- (- tail head)))
- (- 2)))
+ -2))
(repeat (ldb (byte 16 0) #x0101010101010101))
(ascii-mask (* 128 repeat))
(string-sap (vector-sap string))
@@ -1392,7 +1393,7 @@
(sap (buffer-sap ibuf))
(n (logand (min (1- (- end start))
(1- (- tail head)))
- (- 2)))
+ -2))
(repeat (ldb (byte 16 0) #x0101010101010101))
(ascii-mask (* 128 repeat))
(string-sap (vector-sap string))
@@ -1621,3 +1622,106 @@
(incf byte-index 4)))))
(incf char-index))))
string))))
+
+(declaim (ftype (sfunction ((simple-array character (*))) nil)
+ check-utf8-encoding))
+(defun check-utf8-encoding (string)
+ (loop for char across string
+ for code = (char-code char)
+ when (<= #xd800 code #xdfff)
+ do
+ (c-string-encoding-error string code))
+ (error "~s modified while validating UTF-8" string))
+
+(declaim (ftype (sfunction ((simple-array character (*))) (values (or null index) t))
+ simd-character-string-utf8-length))
+(defun simd-character-string-utf8-length (string)
+ (let* ((string-length (length string))
+ (index 0))
+ (declare (index index))
+ #+64-bit
+ (let ((word-length (truncate string-length 2)))
+ ;; SWAR ASCII
+ (loop until (or (>= index word-length)
+ (logtest (%vector-raw-bits string index) #xFFFFFF80FFFFFF80))
+ do (incf index)))
+ (let ((index (* index 2)))
+ (declare (index index))
+ ;; ASCII-only
+ (loop when (>= index string-length)
+ do (return-from simd-character-string-utf8-length (values index t))
+ until (> (char-code (char string index)) 127)
+ do (incf index))
+ (let ((length index))
+ (declare (index length))
+ (loop until (>= index string-length)
+ do
+ (let ((bits (char-code (char string index))))
+ (incf length
+ (cond ((< bits 128) 1)
+ ((< bits 2048) 2)
+ ((< bits 65536)
+ (when (<= #xd800 bits #xdfff)
+ (return-from simd-character-string-utf8-length (values nil nil)))
+ 3)
+ (t 4)))
+ (incf index)))
+ (values length nil)))))
+
+(defun output-to-c-string/utf-8/lf (string)
+ (declare (type simple-string string)
+ (optimize speed (safety 0)))
+ (cond ((simple-base-string-p string) string)
+ (t
+ (multiple-value-bind (buffer-length ascii-only) (simd-character-string-utf8-length string)
+ (unless buffer-length
+ (check-utf8-encoding string))
+ (let* ((buffer (make-array (1+ buffer-length) :element-type '(unsigned-byte 8)
+ :initial-element 0)))
+ (cond (ascii-only
+ (let ((byte-index 0))
+ (declare (index byte-index))
+ ;; SWAR ASCII
+ #+64-bit
+ (with-pinned-objects (buffer)
+ (let ((sap (vector-sap buffer))
+ (word-length (truncate buffer-length 2))
+ (index 0))
+ (declare (index index))
+ (loop until (>= index word-length)
+ do (let* ((word (%vector-raw-bits string index))
+ (a (ldb (byte 8 0) word))
+ (b (ash word -24)))
+ (setf (sap-ref-16 sap (* index 2))
+ (logior a b)))
+
+ (incf index)
+ (incf byte-index 2))))
+ (loop for i from byte-index below buffer-length
+ do (setf (aref buffer i)
+ (logand (char-code (aref string i)) #xFF)))))
+ (t
+ (let ((index 0))
+ (declare (index index))
+ (loop for char across string
+ for bits = (char-code char)
+ do (cond ((< bits 128)
+ (setf (aref buffer index) bits)
+ (incf index))
+ ((< bits 2048)
+ (setf (aref buffer (+ 1 index)) (logior 128 (ldb (byte 6 0) bits))
+ (aref buffer index) (logior 192 (ldb (byte 5 6) bits)))
+ (incf index 2))
+ ((< bits 65536)
+ (setf (aref buffer (+ 2 index)) (logior 128 (ldb (byte 6 0) bits))
+ (aref buffer (+ 1 index)) (logior 128 (ldb (byte 6 6) bits))
+ (aref buffer index) (logior 224 (ldb (byte 4 12) bits)))
+ (incf index 3))
+ (t
+ (setf (aref buffer (+ 3 index)) (logior 128 (ldb (byte 6 0) bits))
+ (aref buffer (+ 2 index)) (logior 128 (ldb (byte 6 6) bits))
+ (aref buffer (+ 1 index)) (logior 128 (ldb (byte 6 12) bits))
+ (aref buffer index) (logior 240 (ldb (byte 3 18) bits)))
+ (incf index 4)))))))
+
+ buffer)))))
diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 7616f3d03..a744bb95d 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -918,10 +918,12 @@
(defun sb-alien::string-to-c-string (string external-format)
(declare (type simple-string string)
(explicit-check :result))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (let ((external-format (get-external-format-or-lose external-format)))
- (funcall (ef-write-c-string-fun external-format) string))))
+ (if (eq external-format :utf-8)
+ (output-to-c-string/utf-8/lf string)
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((external-format (get-external-format-or-lose external-format)))
+ (funcall (ef-write-c-string-fun external-format) string)))))
(defun sb-alien::c-string-to-string (sap external-format element-type)
(declare (type system-area-pointer sap)
@@ -1564,7 +1566,8 @@
write-n-bytes-fun
(newline-variant :lf)
(char-encodable-p t)
- (read-c-string-function nil custom-read-c-string-function-p))
+ (read-c-string-function nil custom-read-c-string-function-p)
+ (output-c-string-function nil custom-output-c-string-function))
(let* ((name (first external-format))
(suffix (symbolicate name '/ newline-variant))
(out-function (or write-n-bytes-fun
@@ -1577,7 +1580,8 @@
(size-function (symbolicate "BYTES-FOR-CHAR/" suffix))
(read-c-string-function (or read-c-string-function
(symbolicate "READ-FROM-C-STRING/" suffix)))
- (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" suffix))
+ (output-c-string-function (or output-c-string-function
+ (symbolicate "OUTPUT-TO-C-STRING/" suffix)))
(n-buffer (gensym "BUFFER")))
`(progn
(defun ,size-function (|ch|)
@@ -1852,55 +1856,55 @@
(c-string-decoding-error
,name sap head decode-break-reason))
(setf (aref string index) |ch|)))))))
-
- (defun ,output-c-string-function (string)
- (declare (type simple-string string))
- (cond ,@(and base-string-direct-mapping
- `(((simple-base-string-p string)
- string)))
- (t
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (block output-nothing
- (let* ((length (length string))
- (null-size (let* ((|ch| (code-char 0))
- (bits (char-code |ch|)))
- (declare (ignorable |ch| bits))
- (the index ,out-size-expr)))
- (buffer-length
- (+ (loop for i of-type index below length
+ ,@(unless custom-output-c-string-function
+ `((defun ,output-c-string-function (string)
+ (declare (type simple-string string))
+ (cond ,@(and base-string-direct-mapping
+ `(((simple-base-string-p string)
+ string)))
+ (t
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (block output-nothing
+ (let* ((length (length string))
+ (null-size (let* ((|ch| (code-char 0))
+ (bits (char-code |ch|)))
+ (declare (ignorable |ch| bits))
+ (the index ,out-size-expr)))
+ (buffer-length
+ (+ (loop for i of-type index below length
+ for |ch| of-type character = (aref string i)
+ for bits = (char-code |ch|)
+ sum (the index ,out-size-expr) of-type index)
+ null-size))
+ (tail 0)
+ (,n-buffer (make-array buffer-length
+ :element-type '(unsigned-byte 8)))
+ ;; For external-format-encoding-error
+ (stream ',name))
+ (declare (type index length buffer-length tail)
+ (ignorable stream))
+ (with-pinned-objects (,n-buffer)
+ (let ((sap (vector-sap ,n-buffer)))
+ (declare (system-area-pointer sap))
+ (loop for i of-type index below length
for |ch| of-type character = (aref string i)
for bits = (char-code |ch|)
- sum (the index ,out-size-expr) of-type index)
- null-size))
- (tail 0)
- (,n-buffer (make-array buffer-length
- :element-type '(unsigned-byte 8)))
- ;; For external-format-encoding-error
- (stream ',name))
- (declare (type index length buffer-length tail)
- (ignorable stream))
- (with-pinned-objects (,n-buffer)
- (let ((sap (vector-sap ,n-buffer)))
- (declare (system-area-pointer sap))
- (loop for i of-type index below length
- for |ch| of-type character = (aref string i)
- for bits = (char-code |ch|)
- ,@(when handle-size
- `(for size of-type index = ,out-size-expr))
- do (prog1
- ,out-expr
- ,@(when handle-size
- `((incf tail size)))))
- (let* ((bits 0)
- (|ch| (code-char bits))
- ,@(when handle-size
- `((size null-size))))
- (declare (ignorable bits |ch|
- ,@(when handle-size
- `(size))))
- ,out-expr)))
- ,n-buffer))))))
+ ,@(when handle-size
+ `(for size of-type index = ,out-size-expr))
+ do (prog1
+ ,out-expr
+ ,@(when handle-size
+ `((incf tail size)))))
+ (let* ((bits 0)
+ (|ch| (code-char bits))
+ ,@(when handle-size
+ `((size null-size))))
+ (declare (ignorable bits |ch|
+ ,@(when handle-size
+ `(size))))
+ ,out-expr)))
+ ,n-buffer))))))))
(register-external-format
',external-format
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL