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

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,14 +52,21 @@
   (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")
 
 (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))

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))

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)