Decode utf8 from C

This improves the benchmark result for long strings and does not
degrade it on short strings.

And fix the benchmark's randomizer. The hacky attempt to avoid the
surrogate pair range inadvertently prevented random strings from
containing any code point requiring exactly 2 encoding bytes.

benchmarks/utf8-to-string.lisp

@@ -39,7 +39,8 @@
     (dotimes (i stringlen s)
       (setf (char s i)
             (code-char (if (< (random 100.0) unicode)
-                           (max #xE000 (random char-code-limit))
+                           (loop (let ((c (max 1 (random char-code-limit))))
+                                   (when (sb-unicode:scalar-p c) (return c))))
                            (max 1 (random 128))))))))
 
 (defun bench ()

src/code/target-unicode.lisp

@@ -2039,33 +2039,19 @@ according to the IDNA confusableSummary.txt table"
 (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)))))))
+       ;; It is generally quicker to call a foreign function to decode utf8,
+       ;; with the possible exception of strings shorter than a few characters.
+       (let* ((string (make-array nchars :element-type 'character))
+              (result
+               (sb-sys:with-pinned-objects (string)
+                 (sb-alien:alien-funcall
+                  (sb-alien:extern-alien "utf8_into_simple_character_string"
+                   (function sb-alien:unsigned
+                             sb-sys:system-area-pointer sb-alien:unsigned
+                             sb-alien:system-area-pointer))
+                  sap length-in-octets (sb-sys:vector-sap string)))))
+         (sb-int:aver (= result nchars))
+         string))
      (copy-to-base-string (sap nchars)
        (if (= nchars 0)
            #.(coerce "" 'simple-base-string)

src/runtime/runtime.c

@@ -809,3 +809,37 @@ initialize_lisp(int argc, char *argv[], char *envp[])
 }
 
 int lisp_gc_strategy_id() { return GC_STRATEGY_ID; }
+
+/**
+ * Convert UTF-8 to UCS4 assuming adequate output space and well-formed input.
+ *  input -  pointer to UTF-8 octets
+ *  in_len - number of octets to process
+ *  output - VECTOR-SAP of the resulting Lisp SIMPLE-CHARACTER-STRING
+ * Returns the number of UCS4 characters placed into 'output'
+ */
+size_t utf8_into_simple_character_string(const uint8_t* input, size_t in_len, uint32_t* output)
+{
+    const uint8_t* in = input;
+    const uint8_t* end = input + in_len;
+    uint32_t* out_start = output;
+
+    while (in < end) {
+        uint8_t first = *in++;
+        uint32_t c; // codepoint
+        if (first < 0x80) { // 1-byte sequence (0xxxxxxx)
+            c = first;
+        } else if (first < 0xE0) { // 2-byte sequence (110xxxxx 10xxxxxx)
+            c = ((first & 0x1F) << 6) | (in[0] & 0x3F);
+            in += 1;
+        } else if (first < 0xF0) { // 3-byte sequence (1110xxxx 10xxxxxx 10xxxxxx)
+            c = ((first & 0x0F) << 12) | ((in[0] & 0x3F) << 6) | (in[1] & 0x3F);
+            in += 2;
+        } else { // 4-byte sequence (11110xxx 10xxxxxx 10xxxxxx 10xxxxxx)
+            c = ((first & 0x07) << 18) | ((in[0] & 0x3F) << 12)
+              | ((in[1] & 0x3F) << 6) | (in[2] & 0x3F);
+            in += 3;
+        }
+        *output++ = c;
+    }
+    return output - out_start;
+}

tests/utf-8.pure.lisp

@@ -435,7 +435,8 @@
     (dotimes (i stringlen s)
       (setf (char s i)
             (code-char (if (< (random 100.0) unicode)
-                           (max #xE000 (random char-code-limit))
+                           (loop (let ((c (max 1 (random char-code-limit))))
+                                   (when (sb-unicode:scalar-p c) (return c))))
                            (max 1 (random 128))))))))
 
 (with-test (:name :optimized-utf8-decoder
@@ -451,7 +452,7 @@
               (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
+              ;; doesn't take END or a displaced 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))))))