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

Optimize writing of non-base ascii strings.

parent f2a504a1
...@@ -331,13 +331,23 @@ ...@@ -331,13 +331,23 @@
(defun write-ascii-string (string stream) (defun write-ascii-string (string stream)
(declare (simple-string string)) (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 (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) (defun write-multibyte-string (string stream)
(declare (simple-string string)) (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 (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) (defmethod write-object ((string string) stream)
(etypecase string (etypecase string
...@@ -349,12 +359,8 @@ ...@@ -349,12 +359,8 @@
(write-n-bytes (length string) +sequence-length+ stream) (write-n-bytes (length string) +sequence-length+ stream)
(write-ascii-string-optimized string stream)) (write-ascii-string-optimized string stream))
(ascii-string (ascii-string
(write-n-bytes #.(type-code 'ascii-string) 1 stream)
(write-n-bytes (length string) +sequence-length+ stream)
(write-ascii-string string stream)) (write-ascii-string string stream))
(string (string
(write-n-bytes #.(type-code 'string) 1 stream)
(write-n-bytes (length string) +sequence-length+ stream)
(write-multibyte-string string stream)))) (write-multibyte-string string stream))))
(declaim (inline read-ascii-string)) (declaim (inline read-ascii-string))
......
...@@ -286,6 +286,48 @@ ...@@ -286,6 +286,48 @@
+buffer-size+))))) +buffer-size+)))))
string) 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 (defmacro with-io-file ((stream file
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment