Commit ce85ba82 authored by Stas Boukarev's avatar Stas Boukarev
Browse files

Optimize writing of non-base ascii strings.

parent f2a504a1
Loading
Loading
Loading
Loading
+12 −6
Original line number Diff line number Diff line
@@ -331,13 +331,23 @@

(defun write-ascii-string (string stream)
  (declare (simple-string string))
  (write-n-bytes #.(type-code 'ascii-string) 1 stream)
  (write-n-bytes (length string) +sequence-length+ stream)
  #-(and sb-unicode (or x86 x86-64))
  (loop for char across string
        do (write-n-bytes (char-code char) 1 stream)))
        do (write-n-bytes (char-code char) 1 stream))
  #+(and sb-unicode (or x86 x86-64))
  (write-ascii-non-base-string-optimized string stream))

(defun write-multibyte-string (string stream)
  (declare (simple-string string))
  (write-n-bytes #.(type-code 'string) 1 stream)
  (write-n-bytes (length string) +sequence-length+ stream)
  #-(and sb-unicode (or x86 x86-64))
  (loop for char across string
        do (write-n-bytes (char-code char) +char-length+ stream)))
        do (write-n-bytes (char-code char) +char-length+ stream))
  #+(and sb-unicode (or x86 x86-64))
  (write-multibyte-string-optimized string stream))

(defmethod write-object ((string string) stream)
  (etypecase string
@@ -349,12 +359,8 @@
     (write-n-bytes (length string) +sequence-length+ stream)
     (write-ascii-string-optimized string stream))
    (ascii-string
     (write-n-bytes #.(type-code 'ascii-string) 1 stream)
     (write-n-bytes (length string) +sequence-length+ stream)
     (write-ascii-string string stream))
    (string
     (write-n-bytes #.(type-code 'string) 1 stream)
     (write-n-bytes (length string) +sequence-length+ stream)
     (write-multibyte-string string stream))))

(declaim (inline read-ascii-string))
+42 −0
Original line number Diff line number Diff line
@@ -286,6 +286,48 @@
                    +buffer-size+)))))
  string)

(declaim (inline copy-mem-non-base-string))
(defun copy-mem-non-base-string (from to length)
  (declare (word length)
           (optimize (safety 0)))
  (loop for string-index fixnum by 4
        for i fixnum below length
        do (setf (sb-sys:sap-ref-8 to i)
                 (sb-sys:sap-ref-8 from string-index))))

(declaim (inline write-ascii-non-base-string-optimized))
(defun write-ascii-non-base-string-optimized (string stream)
  (declare (optimize speed)
           (simple-string string)
           (sb-ext:muffle-conditions sb-ext:compiler-note))
  (sb-sys:with-pinned-objects (string)
    (let* ((length (length string))
           (position (output-stream-buffer-position stream))
           (string-sap (sb-sys:vector-sap string))
           (new-position (sb-ext:truly-the word (+ position length))))
      (declare (type word position new-position))
      (cond ((<= new-position (output-stream-buffer-end stream))
             (copy-mem-non-base-string string-sap (sb-sys:int-sap position) length)
             (setf (output-stream-buffer-position stream)
                   new-position))
            ((<= length +buffer-size+)
             (let* ((start (output-stream-buffer-start stream))
                    (left (- (output-stream-buffer-end stream) position))
                    (left-length (sb-ext:truly-the word (- length left))))
               (declare (word left left-length))
               (copy-mem-non-base-string string-sap (sb-sys:int-sap position) left)
               (setf (output-stream-buffer-position stream)
                     (output-stream-buffer-end stream))
               (flush-buffer stream)
               (copy-mem-non-base-string (sb-sys:sap+ string-sap left)
                                         (sb-sys:int-sap start) left-length)
               (setf (output-stream-buffer-position stream)
                     (sb-ext:truly-the word (+ start left-length)))))
            (t
             (error "Strings of more than ~a are not supported yet."
                    +buffer-size+)))))
  string)

;;;

(defmacro with-io-file ((stream file