Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Optimize ascii string reading on SBCL.

  • Loading branch information...
commit 39ace35e9808424ca2b88e56e1bf1b27c0272e03 1 parent bf9ca36
@stassats authored
Showing with 44 additions and 19 deletions.
  1. +4 −2 benchmarks.lisp
  2. +3 −4 disk.lisp
  3. +37 −13 io-sbcl.lisp
View
6 benchmarks.lisp
@@ -29,8 +29,7 @@
(defun identity-test (x &optional (mode :both))
(with-packages
(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))))
(with-packages
@@ -47,6 +46,9 @@
(defmethod create-test-object ((type (eql 'fixnum)) &key)
-1)
+(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))
View
7 disk.lisp
@@ -360,12 +360,12 @@
(declaim (inline read-ascii-string))
(defun read-ascii-string (length stream)
(let ((string (make-string length :element-type 'base-char)))
- ;#-sbcl
+ #-sbcl
(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)
string))
(defreader ascii-string (stream)
@@ -612,7 +612,6 @@
;;;
#+sbcl (declaim (inline fast-allocate-instance))
-
#+sbcl
(defun fast-allocate-instance (wrapper initforms)
(declare (simple-vector initforms))
View
50 io-sbcl.lisp
@@ -8,6 +8,7 @@
(defconstant +buffer-size+ 8192)
(deftype word () 'sb-vm:word)
+(deftype signed-word () 'sb-vm:signed-word)
(defun allocate-buffer ()
(sb-sys:sap-int
@@ -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)
+ new-sap))
+ ((<= 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)))))
+ (t
+ (error "Strings of more than ~a are not supported yet."
+ +buffer-size+)))))
string)
;;;
Please sign in to comment.
Something went wrong with that request. Please try again.