master: Improve receiving some C strings from foreign function on 64-bit Unicode
snuglas via Sbcl-commits <[email protected]> Wed, 10 Jun 2026 03:09:00 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 007463a97af9e11b4ea2c41917bf2838b371e9c0 (commit)
from 2df3f8071bfcf85721104e58efad6d38e9c2b912 (commit)
- Log -----------------------------------------------------------------
commit 007463a97af9e11b4ea2c41917bf2838b371e9c0
Author: Douglas Katzman <[email protected]>
Date: Tue Jun 9 22:57:57 2026 -0400
Improve receiving some C strings from foreign function on 64-bit Unicode
If the string's EF is :ASCII and the desired element-type is BASE-CHAR then just memcpy.
---
src/code/c-call.lisp | 33 ++++++++++++++++++++++++---------
src/code/misc-aliens.lisp | 8 --------
src/code/target-alieneval.lisp | 9 +++++++++
src/code/target-c-call.lisp | 8 ++++++++
src/cold/exports.lisp | 2 +-
src/compiler/fndb.lisp | 2 ++
tests/aliencall.pure.lisp | 16 ++++++++++++++++
7 files changed, 60 insertions(+), 18 deletions(-)
diff --git a/src/code/c-call.lisp b/src/code/c-call.lisp
index 2d343d1ac..67c130576 100644
--- a/src/code/c-call.lisp
+++ b/src/code/c-call.lisp
@@ -83,6 +83,8 @@
:datum nil))
(define-alien-type-method (c-string :naturalize-gen) (type alien)
+ ;; Potentially the SAFETY policy could influence whether to elide
+ ;; the null check on strings whose alien type says non-nullable.
`(if (zerop (sap-int ,alien))
,(if (alien-c-string-type-not-null type)
`(null-error ',type)
@@ -91,19 +93,32 @@
;; conversion, or whether we can just do a cheap byte-by-byte
;; copy of the c-string data.
;;
- ;; On SB-UNICODE we can never do the cheap copy, even if the
- ;; external format and element-type are suitable, since
+ ;; On SB-UNICODE the cheap copy is possible for external-format :ASCII
+ ;; and copying to a base-string. Otherwise it isn't since
;; simple-base-strings may not contain ISO-8859-1 characters.
;; If we need to check for non-ascii data in the input, we
;; might as well go through the usual external-format machinery
;; instead of rewriting another version of it.
- ,(if #+sb-unicode t
- #-sb-unicode (c-string-needs-conversion-p type)
- `(c-string-to-string ,alien
- (c-string-external-format ,type)
- (alien-c-string-type-element-type
- ,type))
- `(%naturalize-c-string ,alien))))
+ ,(let ((conv `(c-string-to-string
+ ,alien
+ (c-string-external-format ,type)
+ ',(alien-c-string-type-element-type type))))
+ #-sb-unicode
+ (if (c-string-needs-conversion-p type) conv `(%naturalize-c-string ,alien))
+ #+sb-unicode
+ (if (or (neq (alien-c-string-type-external-format type) :ascii)
+ (neq (alien-c-string-type-element-type type) 'base-char)
+ ;; this test might be unnecessary but if you're asking for maximum
+ ;; safety then we should check for non-ASCII characters
+ (sb-c::policy sb-c::*policy* (= safety 3)))
+ conv
+ ;; else "cheap byte-by-byte copy"
+ #-64-bit `(%naturalize-c-string ,alien)
+ ;; even better: avoid SAP consing. The CPU and OS assure that us that
+ ;; userspace can't have bit 63 on for two popular architectures.
+ #+64-bit
+ `(%naturalize-base-string/word #+(or arm64 x86-64) (the fixnum (sap-int ,alien))
+ #-(or arm64 x86-64) (sap-int ,alien))))))
(define-alien-type-method (c-string :deport-gen) (type value)
;; This SAP taking is safe as DEPORT callers pin the VALUE when
diff --git a/src/code/misc-aliens.lisp b/src/code/misc-aliens.lisp
index 49620026e..6c8d73139 100644
--- a/src/code/misc-aliens.lisp
+++ b/src/code/misc-aliens.lisp
@@ -69,14 +69,6 @@
(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-alieneval.lisp b/src/code/target-alieneval.lisp
index dce96d26b..b2fa2593e 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -963,3 +963,12 @@ specifies the way that the argument is passed.
(error "(STRUCT ~S) has unexpected size" tag)))))
(check-size 'sb-unix::timespec)
(check-size 'sb-unix::timeval)))
+
+;;; 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 sb-impl::memcpy))
+(define-alien-routine ("memcpy" sb-impl::memcpy) system-area-pointer
+ (dest system-area-pointer)
+ (src system-area-pointer)
+ (n sb-unix::size-t))
diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp
index c24355191..c517663ed 100644
--- a/src/code/target-c-call.lisp
+++ b/src/code/target-c-call.lisp
@@ -70,3 +70,11 @@
;; COPY-UB8 pins the lisp string, no need to do it here
(sb-kernel:copy-ub8-from-system-area sap 0 result 0 length)
result))
+
+(defun %naturalize-base-string/word (word)
+ (declare (type sb-vm:word word))
+ (let* ((length (alien-funcall (extern-alien "strlen" (function size-t unsigned)) word))
+ (result (make-string length :element-type 'base-char)))
+ (with-pinned-objects (result)
+ (sb-impl::memcpy (vector-sap result) (int-sap word) length))
+ result))
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index cf0f8b564..34770006b 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -1012,7 +1012,7 @@ Lisp extension proposal by David N. Gray")
"%CAST"
"%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR"
"%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN"
- "%NATURALIZE-C-STRING"
+ "%NATURALIZE-C-STRING" "%NATURALIZE-BASE-STRING/WORD"
"%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT"
"%SLOT-ADDR" "*SAVED-FP*" "*VALUES-TYPE-OKAY*"
"*ALIEN-TYPE-HASHSETS*"
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 69a7f4be3..622d27a08 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -2397,6 +2397,8 @@
;;;; ALIEN and call-out-to-C stuff
(defknown %alien-funcall ((or string system-area-pointer) alien-type &rest t) *)
+#+64-bit
+(defknown sb-alien-internals:%naturalize-base-string/word (sb-vm:word) simple-base-string)
;; Used by WITH-PINNED-OBJECTS
(defknown sb-vm::touch-object (t) (values)
diff --git a/tests/aliencall.pure.lisp b/tests/aliencall.pure.lisp
index 68d651671..84d3bf19f 100644
--- a/tests/aliencall.pure.lisp
+++ b/tests/aliencall.pure.lisp
@@ -39,3 +39,19 @@
;; 53F9FF58 LDR R9, #x1001A10048 ; printf
;; 2) 60023FD6 BLR R9
#+arm64 (assert (= (loop for line in lines count (search "BLR" line)) 2))))
+
+(locally
+(declare (optimize (sb-c::alien-funcall-saves-fp-and-pc 0)))
+(define-alien-routine strerror (c-string :external-format :ascii :element-type base-char)
+ (e int)))
+
+(with-test (:name :return-c-string-optimizer :skipped-on (:not :x86-64))
+ ;; check that the thing actually works
+ (assert (plusp (length (strerror sb-unix:ebadf))))
+ (let ((lines (ctu:disassembly-lines #'strerror)))
+ ;; should tail-call the naturalize function
+ (assert (loop for line in lines
+ thereis (and (search "JMP" line) (search "%NATURALIZE-BASE-STRING/WORD" line))))
+ ;; no alloc-tramp (no SAP consing), nor BIGNUM consing
+ (assert (loop for line in lines
+ never (or (search "ALLOC" line) (search "BIGNUM" line))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL