master: Expose a much simplified utf8-to-string decoder
snuglas via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via b3478e055b85c589cd08c1369bfd598a48b49db8 (commit)
from 0758784246a107603a04cff0628fbfdfdeebb845 (commit)
- Log -----------------------------------------------------------------
commit b3478e055b85c589cd08c1369bfd598a48b49db8
Author: Douglas Katzman <[email protected]>
Date: Sat Apr 4 20:57:15 2026 -0400
Expose a much simplified utf8-to-string decoder
It comes in two-and-a-half variations: accepting a SAP or ub8 vector,
and if a SAP then either counted or null-terminated. In the case where
it returns base-string as determined by a pre-scan of the input, it runs
nearly twice as fast as octets-to-string
---
benchmarks/utf8-to-string.lisp | 124 +++++++++++++++++++++++++++++
src/code/misc-aliens.lisp | 8 ++
src/code/target-unicode.lisp | 176 ++++++++++++++++++++++++++++++++++++++++-
tests/utf-8.pure.lisp | 34 ++++++++
4 files changed, 341 insertions(+), 1 deletion(-)
diff --git a/benchmarks/utf8-to-string.lisp b/benchmarks/utf8-to-string.lisp
new file mode 100644
index 000000000..ad0f1112d
--- /dev/null
+++ b/benchmarks/utf8-to-string.lisp
@@ -0,0 +1,124 @@
+(defun calc-et (from-sec from-ns to-sec to-ns)
+ (let ((from (floor (+ (* 1000000000 from-sec) from-ns) 1000))
+ (to (floor (+ (* 1000000000 to-sec) to-ns) 1000)))
+ (- to from)))
+
+(defmacro my-timing (form)
+ (let ((clockid #+linux sb-unix:clock-thread-cputime-id
+ #+darwin sb-unix:clock-process-cputime-id))
+ `(sb-int:binding* (((sec-before nsec-before) (sb-unix:clock-gettime ,clockid))
+ (nil ,form)
+ ((sec-after nsec-after) (sb-unix:clock-gettime ,clockid)))
+ (calc-et sec-before nsec-before sec-after nsec-after))))
+
+(defparameter *validate* nil)
+(defun compare (testcases &optional (validate *validate*))
+ (declare (simple-vector testcases))
+ (declare (optimize speed))
+ (declare (notinline sb-ext:octets-to-string)) ; because unsafely flushable
+ (when validate ; make sure they agree
+ (sb-int:dovector (x testcases)
+ (let ((way1 (sb-unicode:utf8-decode-from-octets x))
+ (way2 (sb-ext:octets-to-string x)))
+ (assert (string= way1 way2)))))
+ ;; These tests cons a lot and can be easily skewed by having very random
+ ;; places at which they GC. We get fairly consistent results when both the
+ ;; baseline and experiment have a manual GC done beforehand.
+ (gc)
+ ;; run the new way first to give the benefit-of-doubt to the old way
+ ;; in terms of bringing memory into L1 cache
+ (let ((et-new (my-timing
+ (sb-int:dovector (x testcases) (sb-unicode:utf8-decode-from-octets x)))))
+ (gc)
+ (let ((et-old (my-timing
+ (sb-int:dovector (x testcases) (sb-ext:octets-to-string x)))))
+ (format t "~D ~D (~f%)~%" et-old et-new (* 100 (/ (- et-new et-old) et-old))))))
+
+(defun random-string (stringlen percent-ascii &aux (unicode (- 100 percent-ascii)))
+ (let ((s (make-string stringlen)))
+ (dotimes (i stringlen s)
+ (setf (char s i)
+ (code-char (if (< (random 100.0) unicode)
+ (max #xE000 (random char-code-limit))
+ (max 1 (random 128))))))))
+
+(defun bench ()
+ (dolist (stringlen '(5 100 1000 10000 1000000))
+ (dolist (percent-ascii '(100 99 98 97 96 95 90 80 70 60 50 40))
+ (let ((n-trials (ceiling 10000000 stringlen)))
+ (format t "~&~3D% ASCII, length=~d [~d iterations]: " percent-ascii stringlen n-trials)
+ (force-output)
+ (let ((testcases
+ (coerce
+ (loop repeat n-trials
+ collect
+ (string-to-octets (random-string stringlen percent-ascii)))
+ 'vector)))
+ (compare testcases))))))
+
+#|
+My results on an x86-64 macbook (negative percent diff means new is is better)
+and the deltas are either very similar or show slightly less of an improvement
+for arm64 macbook, but still always an improvement over the baseline.
+
+100% ASCII, length=5 [2000000 iterations]: 426481 89626 (-78.984764%)
+ 99% ASCII, length=5 [2000000 iterations]: 469787 60676 (-87.08436%)
+ 98% ASCII, length=5 [2000000 iterations]: 471085 65415 (-86.11397%)
+ 97% ASCII, length=5 [2000000 iterations]: 488598 68924 (-85.89352%)
+ 96% ASCII, length=5 [2000000 iterations]: 482445 74787 (-84.49834%)
+ 95% ASCII, length=5 [2000000 iterations]: 481117 77478 (-83.896225%)
+ 90% ASCII, length=5 [2000000 iterations]: 491657 87709 (-82.16053%)
+ 80% ASCII, length=5 [2000000 iterations]: 515252 103540 (-79.904976%)
+ 70% ASCII, length=5 [2000000 iterations]: 539165 116004 (-78.484505%)
+ 60% ASCII, length=5 [2000000 iterations]: 569675 136532 (-76.033356%)
+ 50% ASCII, length=5 [2000000 iterations]: 589356 143996 (-75.56723%)
+ 40% ASCII, length=5 [2000000 iterations]: 613356 144063 (-76.51234%)
+100% ASCII, length=100 [100000 iterations]: 140443 3974 (-97.17038%)
+ 99% ASCII, length=100 [100000 iterations]: 149191 50945 (-65.8525%)
+ 98% ASCII, length=100 [100000 iterations]: 139345 77090 (-44.67688%)
+ 97% ASCII, length=100 [100000 iterations]: 154108 74434 (-51.700108%)
+ 96% ASCII, length=100 [100000 iterations]: 144111 87651 (-39.178135%)
+ 95% ASCII, length=100 [100000 iterations]: 162271 79519 (-50.996174%)
+ 90% ASCII, length=100 [100000 iterations]: 157988 92868 (-41.21832%)
+ 80% ASCII, length=100 [100000 iterations]: 196840 91016 (-53.76143%)
+ 70% ASCII, length=100 [100000 iterations]: 209938 108707 (-48.219475%)
+ 60% ASCII, length=100 [100000 iterations]: 248108 109260 (-55.962727%)
+ 50% ASCII, length=100 [100000 iterations]: 254467 121921 (-52.087696%)
+ 40% ASCII, length=100 [100000 iterations]: 285208 114461 (-59.867535%)
+100% ASCII, length=1000 [10000 iterations]: 105570 1546 (-98.53557%)
+ 99% ASCII, length=1000 [10000 iterations]: 112052 87494 (-21.91661%)
+ 98% ASCII, length=1000 [10000 iterations]: 120597 77042 (-36.116154%)
+ 97% ASCII, length=1000 [10000 iterations]: 133759 75267 (-43.729393%)
+ 96% ASCII, length=1000 [10000 iterations]: 124279 76452 (-38.483574%)
+ 95% ASCII, length=1000 [10000 iterations]: 145278 76784 (-47.14685%)
+ 90% ASCII, length=1000 [10000 iterations]: 141478 81126 (-42.658222%)
+ 80% ASCII, length=1000 [10000 iterations]: 177988 89134 (-49.921345%)
+ 70% ASCII, length=1000 [10000 iterations]: 190698 99088 (-48.039307%)
+ 60% ASCII, length=1000 [10000 iterations]: 240096 108468 (-54.82307%)
+ 50% ASCII, length=1000 [10000 iterations]: 241091 113381 (-52.9717%)
+ 40% ASCII, length=1000 [10000 iterations]: 274307 113896 (-58.478638%)
+100% ASCII, length=10000 [1000 iterations]: 116469 1521 (-98.69408%)
+ 99% ASCII, length=10000 [1000 iterations]: 122827 84726 (-31.020052%)
+ 98% ASCII, length=10000 [1000 iterations]: 125854 85905 (-31.742336%)
+ 97% ASCII, length=10000 [1000 iterations]: 144160 76104 (-47.208656%)
+ 96% ASCII, length=10000 [1000 iterations]: 149835 76644 (-48.847733%)
+ 95% ASCII, length=10000 [1000 iterations]: 149988 79170 (-47.21578%)
+ 90% ASCII, length=10000 [1000 iterations]: 143812 98798 (-31.300587%)
+ 80% ASCII, length=10000 [1000 iterations]: 188148 89944 (-52.19508%)
+ 70% ASCII, length=10000 [1000 iterations]: 214511 129084 (-39.824066%)
+ 60% ASCII, length=10000 [1000 iterations]: 240322 110871 (-53.865646%)
+ 50% ASCII, length=10000 [1000 iterations]: 237560 122167 (-48.574253%)
+ 40% ASCII, length=10000 [1000 iterations]: 272658 114349 (-58.061382%)
+100% ASCII, length=1000000 [10 iterations]: 122355 3950 (-96.77169%)
+ 99% ASCII, length=1000000 [10 iterations]: 127108 70778 (-44.316643%)
+ 98% ASCII, length=1000000 [10 iterations]: 135022 80389 (-40.462296%)
+ 97% ASCII, length=1000000 [10 iterations]: 126778 72913 (-42.487656%)
+ 96% ASCII, length=1000000 [10 iterations]: 144430 74448 (-48.453922%)
+ 95% ASCII, length=1000000 [10 iterations]: 138535 78872 (-43.067097%)
+ 90% ASCII, length=1000000 [10 iterations]: 145037 77884 (-46.3006%)
+ 80% ASCII, length=1000000 [10 iterations]: 190233 89723 (-52.83521%)
+ 70% ASCII, length=1000000 [10 iterations]: 197363 95052 (-51.838997%)
+ 60% ASCII, length=1000000 [10 iterations]: 216470 115180 (-46.791702%)
+ 50% ASCII, length=1000000 [10 iterations]: 244138 108852 (-55.413742%)
+ 40% ASCII, length=1000000 [10 iterations]: 247799 123019 (-50.355328%)
+|#
diff --git a/src/code/misc-aliens.lisp b/src/code/misc-aliens.lisp
index 985371e04..a1684d2b1 100644
--- a/src/code/misc-aliens.lisp
+++ b/src/code/misc-aliens.lisp
@@ -69,6 +69,14 @@
(dest system-area-pointer)
(src system-area-pointer)
(n sb-unix::size-t))
+;;; The overhead of Lisp may make the distinction between memmove() and memcpy()
+;;; irrelevant, but we may as well promise that the ranges don't overlap when one
+;;; of them is a freshly consed string, for example.
+(declaim (inline memcpy))
+(define-alien-routine ("memcpy" memcpy) system-area-pointer
+ (dest system-area-pointer)
+ (src system-area-pointer)
+ (n sb-unix::size-t))
(defun copy-ub8-to-system-area (src src-offset dst dst-offset length)
(with-pinned-objects (src)
diff --git a/src/code/target-unicode.lisp b/src/code/target-unicode.lisp
index d7abd61fb..9ae0c833d 100644
--- a/src/code/target-unicode.lisp
+++ b/src/code/target-unicode.lisp
@@ -21,7 +21,8 @@
grapheme-break-class word-break-class sentence-break-class graphemes
words sentences lines
unicode= unicode-equal unicode< unicode<= unicode> unicode>=
- confusable-p))
+ confusable-p scalar-p
+ utf8-decode-from-sap utf8-decode-from-octets))
(eval-when (:compile-toplevel :execute)
(defun lisp-expr-file-pathname (namestring)
@@ -2005,6 +2006,179 @@ according to the IDNA confusableSummary.txt table"
(clear-info :function :compiler-macro-function 'proplist-p)
+;;; Given the surprisingly large number of places the integers #xD800 and #xDFFF
+;;; are expressed as literals I would have thought by now someone would have abstracted
+;;; it out into surrogate-p or similar. Maybe I'm just blind and we do have it?
+;;; Anyway this is the opposite of a hypothetical surrogate-p predicate.
+;;; Note that scalars -include- the characters which are NONCHARACTER but not surrogates.
+(defun scalar-p (c) (or (< c #xD800) (and (>= c #xE000) (<= c #x10FFFF))))
+
+;;; A branch-free table to decide how long a utf8-encoded codepoint is in octets
+;;; given its first octet. Because the 32-bit codegen requires untagged words here,
+;;; it amusingly produces better assembly code than 64-bit which excessively shifts.
+(declaim (inline utf8-encoded-len-from-leading-byte))
+(defun utf8-encoded-len-from-leading-byte (octet)
+ (declare (type (unsigned-byte 8) octet)
+ (optimize (safety 0)))
+ (macrolet ((magic (&aux (result 0))
+ (dotimes (i 16 result)
+ (let ((bits (1- (aref #(1 1 1 1 1 1 1 1 1 1 1 1 2 2 3 4) i))))
+ (setq result (logior result (ash bits (* i 2))))))))
+ (let ((high4 (ash octet -4)))
+ (1+ (logand (ash (magic) (- (ash high4 1))) #b11)))))
+
+;;; To decode a 0-terminated UTF8 array of unknown length returning a Lisp string
+;;; with maximal speed, preferring a result type of BASE-STRING when possible,
+;;; and requiring there to be no decoding errors, this is the the way to do it.
+;;; When processing data from external sources it wouldn't be the worst thing to use
+;;; OCTETS-TO-STRING for its error checking, but when dealing with C APIs within
+;;; your system, checking for decoding errors at each function call can
+;;; cause a lot of unnecessary CPU cycles to be burnt.
+;;; I didn't see an efficient technique to construct anything exactly equivalent
+;;; to this function using other pre-existing functions.
+(labels
+ ((copy-to-char-string (sap length-in-octets nchars)
+ (declare (sb-sys:system-area-pointer sap) (index length-in-octets nchars))
+ (macrolet
+ ;; This character decoder is taken from (one of several) UTF8->STRING
+ ;; functions in enc-basic without any of the CRLF conversions.
+ ;; The best solution - at least for #+(or arm64 x86-64) - would be to cons
+ ;; a DX file buffer and call SIMD-COPY-UTF8-TO-CHARACTER-STRING on it.
+ ((cref (n) `(sb-sys:sap-ref-8 sap ,n))
+ (utf8-char@sap (bytes)
+ `(ecase ,bytes
+ (1 (cref 0))
+ (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6)
+ (ldb (byte 6 0) (cref 1))))
+ (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12)
+ (ash (ldb (byte 6 0) (cref 1)) 6)
+ (ldb (byte 6 0) (cref 2))))
+ (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18)
+ (ash (ldb (byte 6 0) (cref 1)) 12)
+ (ash (ldb (byte 6 0) (cref 2)) 6)
+ (ldb (byte 6 0) (cref 3)))))))
+ (let ((string (make-array nchars :element-type 'character))
+ (end-sap (sb-sys:sap+ sap length-in-octets))
+ (char-index -1))
+ (declare (sb-kernel:index-or-minus-1 char-index))
+ (loop
+ (let ((n (utf8-encoded-len-from-leading-byte (sb-sys:sap-ref-8 sap 0))))
+ (setf (char string (incf char-index)) (code-char (utf8-char@sap n)))
+ (when (sb-sys:sap>= (setf sap (sb-sys:sap+ sap n)) end-sap)
+ (return string)))))))
+ (copy-to-base-string (sap nchars)
+ (if (= nchars 0)
+ #.(coerce "" 'simple-base-string)
+ (let ((string (make-array nchars :element-type 'base-char)))
+ (sb-sys:with-pinned-objects (string)
+ (sb-impl::memcpy (sb-sys:vector-sap string) sap nchars))
+ string)))
+ (any-extended-char-p (sap limit)
+ ;; TODO: instead of looping over bytes, this should read exactly one word
+ ;; and mask off the irrelevant bytes. Then compare to the mask of high bits.
+ ;; To be pedantic there is the question of whether it is legal to read
+ ;; the entire word preceding SAP and entire word following LIMIT.
+ ;; The way to do it strictly observing the specified bounds is to purposely
+ ;; do an unaligned read so that you gather a word of octets not to exceed
+ ;; the stated bounds, as long as the CPU has no unaligned penalty. e.g.
+ ;; b | b | b | b | b | b | b | b | b | b
+ ;; |
+ ;; ^ aligned word boundary
+ ;; ^ specified start byte
+ ;; An unaligned load which gathers up a word at the specified start is ok
+ ;; provided that the specified end accomodates the entire word.
+ ;; Looping takes less brain power to get right, so let's just do that.
+ (declare (sb-sys:system-area-pointer sap limit))
+ (loop
+ (when (sb-sys:sap>= sap limit) (return nil))
+ (when (logtest (sb-sys:sap-ref-8 sap 0) #x80) (return t))
+ (setf sap (sb-sys:sap+ sap 1))))
+ (any-extended-char-p/word (sap limit)
+ (declare (sb-sys:system-area-pointer sap limit))
+ (loop
+ (when (sb-sys:sap>= sap limit) (return nil))
+ (when (logtest (sb-sys:sap-ref-word sap 0)
+ #+64-bit #x8080808080808080 #-64-bit #x80808080)
+ (return t))
+ (setf sap (sb-sys:sap+ sap sb-vm:n-word-bytes))))
+ (scan-between (sap limit &aux (length-in-chars 0) (start sap))
+ (declare (sb-sys:system-area-pointer sap limit) (index length-in-chars))
+ ;; Decode octets starting at SAP up to LIMIT. If an encoding sequence does not end
+ ;; exactly at LIMIT, this is an error on the part of the caller. The returned string
+ ;; will not contain the character involved in the overrun in that case.
+ ;; But first, do a quick pass to test for presence of any non-BASE-CHAR.
+ (flet ((sap-align-down (x)
+ (sb-sys:int-sap (logandc2 (sb-sys:sap-int x) (1- sb-vm:n-word-bytes)))))
+ (declare (inline sap-align-down))
+ ;; When trying to use SB-INT:ALIGN-UP here, the compiler doesn't know that
+ ;; the expression (+ value mask) should be treated modularly, and so it inserts
+ ;; possible bignum arithmetic. Performing SAP+ avoids that.
+ (let ((aligned-start (sap-align-down (sb-sys:sap+ sap (1- sb-vm:n-word-bytes))))
+ (aligned-end (sap-align-down limit)))
+ (unless (or (any-extended-char-p/word aligned-start aligned-end)
+ (any-extended-char-p sap aligned-start)
+ (any-extended-char-p aligned-end limit))
+ (return-from scan-between
+ (copy-to-base-string sap (sb-sys:sap- limit sap))))))
+ (loop
+ (let* ((n (utf8-encoded-len-from-leading-byte (sb-sys:sap-ref-8 sap 0)))
+ (next (sb-sys:sap+ sap n)))
+ (when (sb-sys:sap>= next limit)
+ (when (sb-sys:sap= next limit) (incf length-in-chars) (setq sap next))
+ (return))
+ (incf length-in-chars)
+ (setq sap next)))
+ (copy-to-char-string start (sb-sys:sap- sap start) length-in-chars)))
+
+ (defun utf8-decode-from-sap (sap &optional (count nil count-supplied)
+ &aux (length-in-chars 0) (start sap))
+ (declare (sb-sys:system-area-pointer sap) (index length-in-chars))
+ (if count-supplied
+ ;; The counted mode of operation allows embedded #\nul
+ (if (zerop (the index count))
+ #.(coerce "" 'simple-base-string)
+ (scan-between sap (sb-sys:sap+ sap count)))
+ ;; The uncounted mode of operation decodes until reaching a #\nul
+ (loop
+ (let ((octet (sb-sys:sap-ref-8 sap 0)))
+ (when (= octet 0)
+ (let ((bytes (sb-sys:sap- sap start)))
+ (return (if (> bytes length-in-chars)
+ (copy-to-char-string start bytes length-in-chars)
+ (copy-to-base-string start length-in-chars)))))
+ (setq sap (sb-sys:sap+ sap (utf8-encoded-len-from-leading-byte octet)))
+ (incf length-in-chars)))))
+
+ (defun utf8-decode-from-octets (ub8-vector)
+ ;; possibly use with-array-data here to allow non-simple array?
+ (declare ((simple-array (unsigned-byte 8) 1) ub8-vector))
+ (sb-sys:with-pinned-objects (ub8-vector)
+ (let ((sap (sb-sys:vector-sap ub8-vector)))
+ (scan-between sap (sb-sys:sap+ sap (length ub8-vector)))))))
+
+;; Compare UTF8-ENCODED-LEN-FROM-LEADING-BYTE to SB-IMPL::BYTES-FOR-CHAR/UTF-8/LF
+;; the former one getting shaken out of the resulting core file.
+#+sb-unicode
+(let ((s (make-string 1))
+ (replacement #.(coerce '(0) '(simple-array (unsigned-byte 8) (*)))))
+ (dotimes (c char-code-limit)
+ ;; An octet array of just 1 null looks to utf8-decode-from-sap like the empty string,
+ ;; as it should. It would need to be a counted octet string to decode as codepoint 0.
+ (when (and (scalar-p c) (> c 0))
+ (setf (char s 0) (code-char c))
+ (let* ((result (sb-impl::string->utf8 s 0 1 0 replacement))
+ (firstbyte (aref result 0))
+ (octet-len-expected (sb-impl::bytes-for-char/utf-8/lf (code-char c)))
+ (octet-len (utf8-encoded-len-from-leading-byte firstbyte)))
+ (when (or (/= octet-len octet-len-expected) (/= octet-len (length result)))
+ (error "~S is messed up at ~x" 'utf8-encoded-len-from-leading-byte c))
+ (let ((terminated-result (sb-impl::string->utf8 s 0 1 1 replacement)))
+ (aver (= (length terminated-result) (1+ octet-len)))
+ (let ((decoded (sb-sys:with-pinned-objects (terminated-result)
+ (utf8-decode-from-sap (sb-sys:vector-sap terminated-result)))))
+ (aver (string= decoded s))
+ (when (< c 128) (aver (sb-kernel:simple-base-string-p decoded)))))))))
+
#|
;;; For offline use.
;;; This could insert a call to MIX if it found nothing that worked.
diff --git a/tests/utf-8.pure.lisp b/tests/utf-8.pure.lisp
index 98be11f0e..c250e60b1 100644
--- a/tests/utf-8.pure.lisp
+++ b/tests/utf-8.pure.lisp
@@ -428,3 +428,37 @@
else if (= i 24) do (incf pos 2)
else do (incf pos 1))))))))
(delete-file *test-path*)
+
+#+sb-unicode
+(defun random-string (stringlen percent-ascii &aux (unicode (- 100 percent-ascii)))
+ (let ((s (make-string stringlen)))
+ (dotimes (i stringlen s)
+ (setf (char s i)
+ (code-char (if (< (random 100.0) unicode)
+ (max #xE000 (random char-code-limit))
+ (max 1 (random 128))))))))
+
+(with-test (:name :optimized-utf8-decoder
+ :skipped-on (:not :sb-unicode))
+ ;; some tests need 100% ascii so that it hits the special case for base-string
+ (dolist (percent-ascii '(100 50 10))
+ (dotimes (i 1000)
+ (let* ((string (random-string (random 1000) percent-ascii))
+ (octets (string-to-octets string :null-terminate t))
+ (readback1
+ (sb-ext:octets-to-string octets :end (1- (length octets))))
+ (readback2
+ (sb-sys:with-pinned-objects (octets)
+ (sb-unicode:utf8-decode-from-sap (sb-sys:vector-sap octets))))
+ (readback3
+ ;; doesn't take END or a displaaced string. It could, but if you need
+ ;; such capability, the SAP interface will do.
+ (sb-unicode:utf8-decode-from-octets
+ (subseq octets 0 (1- (length octets))))))
+ (when (= percent-ascii 100)
+ (assert (not (sb-kernel:simple-base-string-p readback1)))
+ (assert (sb-kernel:simple-base-string-p readback2))
+ (assert (sb-kernel:simple-base-string-p readback3)))
+ (assert (string= string readback1))
+ (assert (string= string readback2))
+ (assert (string= string readback3))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL