Commit 39ace35e authored by Stas Boukarev's avatar Stas Boukarev
Browse files

Optimize ascii string reading on SBCL.

parent bf9ca36b
......@@ -29,8 +29,7 @@
(defun identity-test (x &optional (mode :both))
(when (member mode '(:both :write))
(with-io-file (stream *test-file* :direction :output
:size (object-size x))
(with-io-file (stream *test-file* :direction :output)
(setf (fill-pointer *packages*) 0)
(write-object x stream))))
......@@ -47,6 +46,9 @@
(defmethod create-test-object ((type (eql 'fixnum)) &key)
(defmethod create-test-object ((type (eql 'string)) &key object-size)
(make-string (or object-size 10000)))
(defun class-preallocation-test (storage)
(loop for class in (storage-data storage)
for length = (length (objects-of-class class))
......@@ -360,12 +360,12 @@
(declaim (inline read-ascii-string))
(defun read-ascii-string (length stream)
(let ((string (make-string length :element-type 'base-char)))
(loop for i below length
do (setf (schar string i)
(code-char (read-n-bytes 1 stream))))
;; #+(and sbcl (or x86 x86-64))
;; (read-ascii-string-optimized length string stream)
#+(and sbcl (or x86 x86-64))
(read-ascii-string-optimized length string stream)
(defreader ascii-string (stream)
......@@ -612,7 +612,6 @@
#+sbcl (declaim (inline fast-allocate-instance))
(defun fast-allocate-instance (wrapper initforms)
(declare (simple-vector initforms))
......@@ -8,6 +8,7 @@
(defconstant +buffer-size+ 8192)
(deftype word () 'sb-vm:word)
(deftype signed-word () 'sb-vm:signed-word)
(defun allocate-buffer ()
......@@ -129,8 +130,7 @@
(declaim (inline advance-input-stream))
(defun advance-input-stream (n stream)
(declare (optimize (space 0))
(type word n)
(declare (type (and (integer 1) word) n)
(type input-stream stream))
(let* ((sap (input-stream-buffer-position stream))
(new-sap (sb-ext:truly-the word (+ sap n))))
......@@ -145,8 +145,7 @@
(declaim (inline read-n-bytes))
(defun read-n-bytes (n stream)
(declare (optimize (space 0))
(type word n))
(declare (type (integer 1 4) n))
(n-sap-ref n (advance-input-stream n stream)))
(declaim (inline read-n-signed-bytes))
......@@ -185,7 +184,7 @@
(declaim (inline advance-output-stream))
(defun advance-output-stream (n stream)
(declare (optimize (space 0) (safety 0))
(declare (optimize (safety 0))
(type word n)
(type output-stream stream)
((integer 1 4) n))
......@@ -215,22 +214,47 @@
(declaim (inline copy-mem))
(defun copy-mem (from to length)
(let ((words-end (- length (rem length sb-vm:n-word-bytes))))
(loop for i by sb-vm:n-word-bytes below words-end
(declare (word length))
(let ((words-end (sb-ext:truly-the word
(- length
(rem length sb-vm:n-word-bytes)))))
(loop for i fixnum by sb-vm:n-word-bytes below words-end
do (setf (sb-sys:sap-ref-word to i)
(sb-sys:sap-ref-word from i)))
(loop for i from words-end below length
(loop for i fixnum from words-end below length
do (setf (sb-sys:sap-ref-8 to i)
(sb-sys:sap-ref-8 from i)))))
(declaim (inline read-ascii-string-optimized))
(defun read-ascii-string-optimized (length string stream)
(declare (type fixnum length)
(optimize speed))
(declare (type word length)
(optimize speed)
(sb-ext:muffle-conditions sb-ext:compiler-note))
(sb-sys:with-pinned-objects (string)
(let ((sap (advance-input-stream length stream))
(string-sap (sb-sys:vector-sap string)))
(copy-mem sap string-sap length)))
(let* ((sap (input-stream-buffer-position stream))
(string-sap (sb-sys:vector-sap string))
(new-sap (sb-ext:truly-the word (+ sap length))))
(declare (type word sap new-sap))
(cond ((<= new-sap (input-stream-buffer-end stream))
(copy-mem (sb-sys:int-sap sap) string-sap length)
(setf (input-stream-buffer-position stream)
((<= length +buffer-size+)
(let* ((start (input-stream-buffer-start stream))
(left (- (input-stream-buffer-end stream) sap))
(left-length (sb-ext:truly-the word (- length left))))
(declare (word left left-length))
(when (> left-length (input-stream-left stream))
(error "End of file ~a" stream))
(copy-mem (sb-sys:int-sap sap) string-sap left)
(fill-buffer stream 0)
(copy-mem (sb-sys:int-sap start)
(sb-sys:sap+ string-sap left) left-length)
(setf (input-stream-buffer-position stream)
(sb-ext:truly-the word (+ start left-length)))))
(error "Strings of more than ~a are not supported yet."
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