From 8c2cd86cf19291cbe1e366fa825ff074dbd7377c Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 12 Jul 2023 21:19:07 +0100 Subject: [PATCH] Load-time resolution of external-formats in octet functions If the :EXTERNAL-FORMAT argument to STRING-TO-OCTETS or OCTETS-TO-STRING is a compile-time constant, perform the external-format lookup only once at load-time. If the input vector is simple (or speed > space), inline the array data vector lookup too. --- NEWS | 3 ++ src/code/octets.lisp | 56 ++++++++++++++++++--------------- src/cold/exports.lisp | 6 +++- src/compiler/fndb.lisp | 17 ++++++++++ src/compiler/srctran.lisp | 65 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 121 insertions(+), 26 deletions(-) diff --git a/NEWS b/NEWS index 896d26b02..0b6000562 100644 --- a/NEWS +++ b/NEWS @@ -49,6 +49,9 @@ changes in the external-format-line-endings branch: * optimization: external formats with :REPLACEMENT no longer bind handlers for coding errors around conversion functions, and so should cons less and be faster. + * optimization: when the :EXTERNAL-FORMAT argument to STRING-TO-OCTETS or + OCTETS-TO-STRING is a compile-time constant, the external format is + resolved at load time rather than on each call. changes relative to sbcl-2.3.10: * enhancement: During generic function dispatch, for a generic function diff --git a/src/code/octets.lisp b/src/code/octets.lisp index 79e4d26b8..02980bd76 100644 --- a/src/code/octets.lisp +++ b/src/code/octets.lisp @@ -359,12 +359,20 @@ (default-external-format) external-format))) -(declaim (ftype (sfunction ((vector (unsigned-byte 8)) &key (:external-format t) - (:start index) - (:end sequence-end)) +(declaim (inline %octets-to-string)) +(declaim (ftype (sfunction (function (vector (unsigned-byte 8)) index sequence-end t) (or (simple-array character (*)) (simple-array base-char (*)))) - octets-to-string)) + %octets-to-string)) +(defun %octets-to-string (fun vector start end replacement) + (declare (explicit-check start end :result)) + (with-array-data ((vector vector) + (start start) + (end end) + :check-fill-pointer t) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (funcall fun vector start end replacement))) +(declaim (notinline %octets-to-string)) (defun octets-to-string (vector &key (external-format :default) (start 0) end) "Return a string obtained by decoding VECTOR according to EXTERNAL-FORMAT. @@ -380,22 +388,24 @@ SB-INT:CHARACTER-DECODING-ERROR is signaled. Note that for some values of EXTERNAL-FORMAT the length of the returned string may be different from the length of VECTOR (or the subsequence bounded by START and END)." + (let* ((ef (maybe-defaulted-external-format external-format)) + (replacement (ef-replacement ef))) + (declare (inline %octets-to-string)) + (%octets-to-string (ef-octets-to-string-fun ef) vector start end replacement))) + +(declaim (inline %string-to-octets)) +(declaim (ftype (sfunction (function string index sequence-end t t) + (simple-array (unsigned-byte 8) (*))) + %string-to-octets)) +(defun %string-to-octets (fun string start end null-terminate replacement) (declare (explicit-check start end :result)) - (with-array-data ((vector vector) + (with-array-data ((string string) (start start) (end end) :check-fill-pointer t) - (declare (type (simple-array (unsigned-byte 8) (*)) vector)) - (let* ((ef (maybe-defaulted-external-format external-format)) - (replacement (ef-replacement ef))) - (funcall (ef-octets-to-string-fun ef) vector start end replacement)))) - -(declaim (ftype (sfunction (string &key (:external-format t) - (:start index) - (:end sequence-end) - (:null-terminate t)) - (simple-array (unsigned-byte 8) (*))) - string-to-octets)) + (declare (type simple-string string)) + (funcall fun string start end null-terminate replacement))) +(declaim (notinline %string-to-octets)) (defun string-to-octets (string &key (external-format :default) (start 0) end null-terminate) "Return an octet vector that is STRING encoded according to EXTERNAL-FORMAT. @@ -416,15 +426,11 @@ Note that for some values of EXTERNAL-FORMAT and NULL-TERMINATE the length of the returned vector may be different from the length of STRING (or the subsequence bounded by START and END)." (declare (explicit-check start end :result)) - (with-array-data ((string string) - (start start) - (end end) - :check-fill-pointer t) - (declare (type simple-string string)) - (let* ((ef (maybe-defaulted-external-format external-format)) - (replacement (ef-replacement ef))) - (funcall (ef-string-to-octets-fun ef) string start end - (if null-terminate 1 0) replacement)))) + (let* ((ef (maybe-defaulted-external-format external-format)) + (replacement (ef-replacement ef))) + (declare (inline %string-to-octets)) + (%string-to-octets (ef-string-to-octets-fun ef) string start end + (if null-terminate 1 0) replacement))) ;;; Vector of all available EXTERNAL-FORMAT instances. Each format is named ;;; by one or more keyword symbols. The mapping from symbol to index into this diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index bb755be9e..3e0e5ceec 100644 --- a/src/cold/exports.lisp +++ b/src/cold/exports.lisp @@ -3093,8 +3093,8 @@ possibly temporarily, because it might be used internally.") "TWO-ARG-CHAR-LESSP" "TWO-ARG-CHAR-NOT-LESSP" "TWO-ARG-CHAR-GREATERP" "TWO-ARG-CHAR-NOT-GREATERP" "CHAR-CASE-INFO" - ;; FIXME: potential SB-EXT exports + ;; FIXME: potential SB-EXT exports "CHARACTER-CODING-ERROR" "CHARACTER-DECODING-ERROR" "CHARACTER-DECODING-ERROR-OCTETS" "CHARACTER-ENCODING-ERROR" "CHARACTER-ENCODING-ERROR-CODE" @@ -3103,6 +3103,10 @@ possibly temporarily, because it might be used internally.") "C-STRING-DECODING-ERROR" "ATTEMPT-RESYNC" "FORCE-END-OF-FILE" + ;; not potential SB-EXT exports + "GET-EXTERNAL-FORMAT" "GET-EXTERNAL-FORMAT-OR-LOSE" + "MAYBE-DEFAULTED-EXTERNAL-FORMAT" + ;; bootstrapping magic, to make things happen both in ;; the cross-compilation host compiler's environment and ;; in the cross-compiler's environment diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 4c1390d40..430caf60d 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1867,6 +1867,23 @@ (defknown array-storage-vector (array) (simple-array * (*)) (any)) + +(defknown octets-to-string ((vector (unsigned-byte 8)) + &key + (:external-format t) + (:start index) + (:end sequence-end)) + (or (simple-array character (*)) (simple-array base-char (*))) + (flushable)) +(defknown string-to-octets (string + &key + (:external-format t) + (:start index) + (:end sequence-end) + (:null-terminate t)) + (simple-array (unsigned-byte 8) (*)) + (flushable)) + ;;;; magical compiler frobs diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 743a112ca..934782a13 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -5820,6 +5820,71 @@ (%coerce-callable-to-fun predicate) (and key (%coerce-callable-to-fun key))))))) +;;;; transforms for SB-EXT:OCTETS-TO-STRING and SB-EXT:STRING-TO-OCTETS + +#+sb-xc ; not needed to cross-compile +(progn +(deftransform string-to-octets ((string &key external-format (start 0) end null-terminate) + (t &rest t) + * + :node node) + "precompute external-format lookup" + (unless external-format + (give-up-ir1-transform)) + (unless (constant-lvar-p external-format) + (give-up-ir1-transform)) + (let ((xf-designator (lvar-value external-format))) + (when (eql xf-designator :default) + (give-up-ir1-transform)) + (let ((xf (get-external-format xf-designator))) + (unless xf + (give-up-ir1-transform)) + (let ((form `(let ((fun (load-time-value + (sb-impl::ef-string-to-octets-fun + (get-external-format ',xf-designator)) + t)) + (replacement + (load-time-value + (sb-impl::ef-replacement + (get-external-format ',xf-designator))))) + (sb-impl::%string-to-octets fun string start end + (if null-terminate 1 0) replacement)))) + (if (or (csubtypep (lvar-type string) (specifier-type 'simple-string)) + (policy node (> speed space))) + `(locally (declare (inline sb-impl::%string-to-octets)) + ,form) + form))))) +(deftransform octets-to-string ((vector &key external-format (start 0) end) + (t &rest t) + * + :node node) + "precompute external-format lookup" + (unless external-format + (give-up-ir1-transform)) + (unless (constant-lvar-p external-format) + (give-up-ir1-transform)) + (let ((xf-designator (lvar-value external-format))) + (when (eql xf-designator :default) + (give-up-ir1-transform)) + (let ((xf (get-external-format xf-designator))) + (unless xf + (give-up-ir1-transform)) + (let ((form `(let ((fun (load-time-value + (sb-impl::ef-octets-to-string-fun + (get-external-format ',xf-designator)) + t)) + (replacement + (load-time-value + (sb-impl::ef-replacement + (get-external-format ',xf-designator))))) + (sb-impl::%octets-to-string fun vector start end replacement)))) + (if (or (csubtypep (lvar-type vector) (specifier-type '(simple-array (unsigned-byte 8) (*)))) + (policy node (> speed space))) + `(locally (declare (inline sb-impl::%octets-to-string)) + ,form) + form))))) +) ; PROGN + ;;;; debuggers' little helpers ;;; for debugging when transforms are behaving mysteriously,