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

@@ -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

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

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

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
 

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,