Skip to content
Browse files

Pack information about non-simple arrays into a single bit.

  • Loading branch information...
1 parent 5594732 commit 84ba65ff8a508590c57ed3d4354ad80a7f2870bc @stassats committed
Showing with 58 additions and 36 deletions.
  1. +19 −10 benchmarks.lisp
  2. +37 −23 disk.lisp
  3. +2 −3 io-sbcl.lisp
View
29 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))
View
60 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))
View
5 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)

0 comments on commit 84ba65f

Please sign in to comment.
Something went wrong with that request. Please try again.