From 84ba65ff8a508590c57ed3d4354ad80a7f2870bc Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Sun, 25 Mar 2012 21:39:36 +0400 Subject: [PATCH] Pack information about non-simple arrays into a single bit. --- benchmarks.lisp | 29 +++++++++++++++--------- disk.lisp | 60 ++++++++++++++++++++++++++++++------------------- io-sbcl.lisp | 5 ++--- 3 files changed, 58 insertions(+), 36 deletions(-) diff --git a/benchmarks.lisp b/benchmarks.lisp index 11dd565..41d63b9 100644 --- a/benchmarks.lisp +++ b/benchmarks.lisp @@ -5,11 +5,12 @@ (defvar *test-file* #p"/tmp/test.db") (defun save-test (type amount &key object-size) - (let ((object (create-test-object type :object-size object-size))) - (with-io-file (stream *test-file* :direction :output) - (write-object amount stream) - (loop repeat amount - do (write-object object stream))))) + (with-packages + (let ((object (create-test-object type :object-size object-size))) + (with-io-file (stream *test-file* :direction :output) + (write-object amount stream) + (loop repeat amount + do (write-object object stream)))))) (defun gc () #+sbcl (sb-ext:gc :full t) @@ -21,10 +22,11 @@ (time (progn ,@body)))) (defun load-test () - (with-io-file (stream *test-file*) - (time-with-gc - (loop repeat (read-next-object stream) - do (read-next-object stream))))) + (with-packages + (with-io-file (stream *test-file*) + (time-with-gc + (loop repeat (read-next-object stream) + do (read-next-object stream)))))) (defun identity-test (x &optional (mode :both)) (with-packages @@ -50,7 +52,8 @@ (make-string (or object-size 10000))) (defmethod create-test-object ((type (eql 'simple-base-string)) &key) - #.(coerce "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" 'simple-base-string)) + #.(coerce "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" + 'simple-base-string)) (defmethod create-test-object ((type (eql 'ascii-string)) &key) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") @@ -58,6 +61,12 @@ (defmethod create-test-object ((type (eql 'multibyte-string)) &key) "АБВГДΑΒΓΔΕΖΗΘΙΚΛαβаб广州话日本語ภาษาไทย한국어") +(defmethod create-test-object ((type (eql 'hash-table)) &key) + (load-time-value (make-hash-table :test 'equal :size 500))) + +(defmethod create-test-object ((type (eql 'complex-vector)) &key) + (load-time-value (make-array 10 :adjustable t :fill-pointer 5))) + (defun class-preallocation-test (storage) (loop for class in (storage-data storage) for length = (length (objects-of-class class)) diff --git a/disk.lisp b/disk.lisp index 0cf149a..fe8d1a9 100644 --- a/disk.lisp +++ b/disk.lisp @@ -475,34 +475,48 @@ ;;; Array -(defun boolify (x) - (if x - 1 - 0)) - (defmethod write-object ((array array) stream) (write-n-bytes #.(type-code 'array) 1 stream) - (write-object (array-dimensions array) stream) - (cond ((array-has-fill-pointer-p array) - (write-n-bytes 1 1 stream) - (write-n-bytes (fill-pointer array) +sequence-length+ stream)) - (t - (write-n-bytes 0 2 stream))) - (write-object (array-element-type array) stream) - (write-n-bytes (boolify (adjustable-array-p array)) 1 stream) - (loop for i below (array-total-size array) - do (write-object (row-major-aref array i) stream))) + (let ((byte 0) + (fp (adjustable-array-p array)) + (type (array-element-type array))) + (declare (type (unsigned-byte 8) byte)) + (when fp + (setf byte 1)) + (when (adjustable-array-p array) + (setf (ldb (byte 1 1) byte) 1)) + (when (eq type t) + (setf (ldb (byte 1 2) byte) 1)) + (write-n-bytes byte 1 stream) + (when fp + (write-n-bytes (fill-pointer array) +sequence-length+ stream)) + (unless (eq type t) + (write-object (array-element-type array) stream)) + (write-object (array-dimensions array) stream) + (loop for i below (array-total-size array) + do (write-object (row-major-aref array i) stream)))) -(defun read-array-fill-pointer (stream) - (if (plusp (read-n-bytes 1 stream)) - (read-n-bytes +sequence-length+ stream) - (not (read-n-bytes 1 stream)))) +(declaim (inline bit-test)) +(defun bit-test (byte index) + (declare (type (unsigned-byte 8) byte) + (type (integer 0 7) index)) + (ldb-test (byte 1 index) byte)) + +(declaim (inline read-array-fill-pointer)) +(defun read-array-fill-pointer (byte stream) + (declare (type (unsigned-byte 8) byte)) + (and (bit-test byte 0) + (read-n-bytes +sequence-length+ stream))) (defreader array (stream) - (let ((array (make-array (read-next-object stream) - :fill-pointer (read-array-fill-pointer stream) - :element-type (read-next-object stream) - :adjustable (plusp (read-n-bytes 1 stream))))) + (let* ((byte (read-n-bytes 1 stream)) + (fill-pointer (read-array-fill-pointer byte stream)) + (array (make-array (read-next-object stream) + :fill-pointer fill-pointer + :element-type (if (bit-test byte 2) + t + (read-next-object stream)) + :adjustable (bit-test byte 1)))) (loop for i below (array-total-size array) do (setf (row-major-aref array i) (read-next-object stream))) array)) diff --git a/io-sbcl.lisp b/io-sbcl.lisp index e363e64..9fd6e39 100644 --- a/io-sbcl.lisp +++ b/io-sbcl.lisp @@ -187,7 +187,6 @@ (declaim (inline advance-output-stream)) (defun advance-output-stream (n stream) (declare (optimize (safety 0)) - (type word n) (type output-stream stream) ((integer 1 4) n)) (let* ((sap (output-stream-buffer-position stream)) @@ -196,8 +195,8 @@ (cond ((> new-sap (output-stream-buffer-end stream)) (flush-buffer stream) (setf (output-stream-buffer-position stream) - (+ (output-stream-buffer-start stream) - n)) + (the word (+ (output-stream-buffer-start stream) + n))) (sb-sys:int-sap (output-stream-buffer-start stream))) (t (setf (output-stream-buffer-position stream)