Added somewhat faster store / restore on specialized vectors for

non-sbcl lisps.

Introduce shifted interior fixnum encoding to save more space

Fixed long string bugs

Bugfixes for allegro

Author: ajberkley

README.md

@@ -65,8 +65,8 @@ git clone the repo into your local quicklisp directory (usually ~/quicklisp/loca
     CL-USER> (quicklisp:quickload "cl-binary-store")
     CL-USER> (in-package :cl-binary-store-user) ;  or (use-package :cl-binary-store-user)
     CL-BINARY-STORE-USER> (store nil (list "abcd" 1234))
-    #(32 210 30 212 97 98 99 100 1 210 4 5)    
-    ;; 32 = proper list, 210 = tiny integer length 2, 30 = simple-string, 212 = tiny integer length 4, 97 98 99 100 = abcd, 4 = cons 1 210 4 = 16 bit integer 1234, 5 = nil
+    #(32 6 30 8 97 98 99 100 1 210 4 5)    
+    ;; 32 = proper list, 6 = integer length 2, 30 = simple-string, 8 = integer length 4, 97 98 99 100 = abcd, 4 = cons 1 210 4 = 16 bit integer 1234, 5 = nil
 
     CL-BINARY-STORE-USER> (restore (store nil (list "abcd" 1234)))
     ("abcd" 1234)
@@ -76,7 +76,7 @@ git clone the repo into your local quicklisp directory (usually ~/quicklisp/loca
     CL-BINARY-STORE-USER> (restore "blarg.bin")
     HI
     CL-BINARY-STORE-USER> (store nil (make-string 1 :initial-element #\U+03b1))
-    #(30 210 206 177) ;; 31 is simple-string, 210 encoded length = 2, 206 117 = α
+    #(30 6 206 177) ;; 31 is simple-string, 6 encoded length = 2, 206 117 = α
 
     CL-BINARY-STORE-USER> (let* ((*print-circle* t)
                                  (u (make-array 1))

benchmarking.md

@@ -223,6 +223,26 @@ Here are simple-bit-vectors, one of my favorite data structures in Common Lisp
      WRITE: 664.40 ms at 60 MB/sec
      READ : 504.80 ms at 79 MB/sec
 
+Just all the specialized vectors I can think of.  It goes fast on sbcl.
+
+    CL-BINARY-STORE> (test-on-data (a-bunch-of-specialized-arrays 100000))
+    HYPERLUMINAL-MEM
+     OUTPUT SIZE: 12.81 MB
+     WRITE: 11.04 ms at 1161 MB/sec
+     READ : 9.64 ms at 1329 MB/sec
+    CL-BINARY-STORE
+     OUTPUT SIZE: 5.09 MB
+     WRITE: 0.32 ms at 15899 MB/sec
+     READ : 0.64 ms at 7949 MB/sec
+    CL-CONSPACK
+     OUTPUT SIZE: 5.70MB
+     WRITE: 58.00 ms at 98 MB/sec
+     READ : 47.20 ms at 121 MB/sec
+    CL-STORE
+     OUTPUT SIZE: 20.10MB
+     WRITE: 338.80 ms at 59 MB/sec
+     READ : 222.00 ms at 91 MB/sec
+
 The rest of the story is the same here, for specialized vectors and specialized arrays we are very very fast because we are just blitting them.  This means cl-binary-store is a good choice for serializing double float matrices, for example:
 
     CL-BINARY-STORE> (test-on-data (list-of-double-float-matrices))

benchmarks.lisp

@@ -1,5 +1,5 @@
 (quicklisp:quickload "cl-store")
-#-allegro(quicklisp:quickload "hyperluminal-mem")
+#-(or lispworks allegro)(quicklisp:quickload "hyperluminal-mem")
 (quicklisp:quickload "cl-conspack")
 #+sbcl (require 'sb-sprof)
 
@@ -21,7 +21,7 @@
                         "")))))))
 
 
-#-(or allegro abcl) ;; crashes on abcl
+#-(or allegro abcl lispworks) ;; crashes on abcl
 (defun test-hlmem-on-data (data &key (repeats 100))
   (let* ((words (hyperluminal-mem:msize 0 data))
          (output-size (/ (* 8 words) 1e6)))
@@ -130,7 +130,7 @@
           (dotimes (x repeats) (cl-store:restore "blarg.bin")))))))
 
 (defun test-on-data (data &key (hlmem t) (cl-store t) (cl-binary-store t) (conspack t))
-  #-(or allegro abcl)
+  #-(or allegro abcl lispworks)
   (when hlmem
     (test-hlmem-on-data data))
   (when cl-binary-store
@@ -295,6 +295,27 @@
 		  (svref a (random number))))
     a))
 
+(defun a-bunch-of-specialized-arrays (&optional (n 10000))
+  (loop for type in '((unsigned-byte 1)
+		      (unsigned-byte 2)
+		      (unsigned-byte 4)
+		      (unsigned-byte 8)
+		      (unsigned-byte 16)
+		      (unsigned-byte 32)
+		      fixnum
+		      (unsigned-byte 64)
+		      (signed-byte 8)
+		      (signed-byte 16)
+		      (signed-byte 32)
+		      (signed-byte 64)
+		      single-float
+		      double-float)
+	for elt in (list 1 2 15 255 65535 (1- (expt 2 32)) (expt 2 50) (1- (expt 2 64))
+		     -1 -128 -32768 -100000 1f0 -1d0)
+	collect
+	(make-array n :element-type type :initial-element elt)))
+
+
 (defstruct address
   (street "Ave Greene" :type simple-string)
   (state "QC" :type simple-string)

src/basic-codespace-codes.lisp

@@ -12,6 +12,12 @@
 (defconstant +ub16-code+ 1)
 (defconstant +ub32-code+ 2)
 (defconstant +fixnum-code+ 3)
+(defconstant +first-direct-unsigned-integer-interior-code+ 4)
+(defconstant +interior-coded-max-integer+ (- 255 +first-direct-unsigned-integer-interior-code+))
+;; Inside of another tag region, when encoding an unsigned integer, 0
+;; - 3 is a tag for an extended number, and 4-255 are direct coded
+;; lengths.  If 0-3 is used, then the number encoded is shifted down
+;; by +interior-coded-max-integer+.
 (defconstant +cons-code+ 4)
 (defconstant +nil-code+ 5)
 (defconstant +sb8-code+ 6)
@@ -68,3 +74,4 @@
 						    +small-integer-zero-code+))
 (defconstant +minimum-untagged-signed-integer+ (- +first-small-integer-code+
 						  +small-integer-zero-code+))
+

src/basic-codespace.lisp

@@ -141,9 +141,7 @@
       (restore-new-reference-indicator references restore-object))
 
   ;; SIMPLE VECTORS
-  #+sbcl
   (defstore (simple-array * (*)) (store-simple-specialized-vector obj storage) :check-for-ref-in eq-refs)
-  #+sbcl
   (defrestore +simple-specialized-vector-code+ (restore-simple-specialized-vector storage))
 
   (defstore simple-vector (store-simple-vector obj storage store-object) :check-for-ref-in eq-refs)

src/cons.lisp

@@ -44,7 +44,7 @@
 (defun store-cons/finite (cons storage eq-refs store-object assign-new-reference-id list-lengths)
   "This is called during the actual storage output phase if we have already computed the list
  length.  This is not called when *support-shared-list-structures* is true."
-  (declare (optimize (speed 3) (safety 0))
+  (declare (optimize (speed 3) (safety 3) (debug 3))
 	   (type write-storage storage) (type function store-object))
   (maybe-store-reference-instead (cons storage eq-refs assign-new-reference-id)
     (let ((length (or (and list-lengths (gethash cons list-lengths))
@@ -53,7 +53,7 @@
 	  (declare (type fixnum length))
 	(with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap)
 	  (set-sap-ref-8 sap offset +finite-length-list-code+))
-	(store-tagged-unsigned-fixnum length storage)
+	(store-tagged-unsigned-fixnum/interior length storage)
 	(dotimes (count length)
 	  (cond
 	    ((= count (- length 1))
@@ -141,7 +141,7 @@
 (declaim (inline restore-list/known-length))
 (defun restore-list/known-length (storage restore-object)
   (declare (optimize (speed 3) (safety 0)))
-  (let* ((length (restore-tagged-unsigned-fixnum storage)))
+  (let* ((length (restore-tagged-unsigned-fixnum/interior storage)))
     (let* ((head (make-list length))
 	   (cons head))
       (dotimes (count (1- length))

src/numbers.lisp

@@ -253,6 +253,41 @@
 	          (store-ub32 fixnum storage)
 	          (store-only-fixnum fixnum storage))))))
 
+(declaim (inline store-tagged-unsigned-fixnum/interior))
+(defun store-tagged-unsigned-fixnum/interior (fixnum storage)
+  "Use this paired with restore-tagged-unsigned-fixnum if you are inside another tagged
+ region for storing unsigned numbers.  Somewhat more dense as we only need tags 0-3 for
+ tagging unsigned numbers."
+  (declare (type fixnum fixnum) (type write-storage storage))
+  (if (<= fixnum +interior-coded-max-integer+)
+      (store-ub8/no-tag (+ +first-direct-unsigned-integer-interior-code+ fixnum)
+			storage) ;; direct coded
+      (let ((fixnum (- fixnum +interior-coded-max-integer+ 1))) ;; code shifted
+	(if (< fixnum 256)
+            (store-ub8/tag (truly-the fixnum fixnum) storage)
+            (if (< fixnum 65536)
+		(store-ub16 fixnum storage)
+		(if (< fixnum #.(expt 2 32))
+	            (store-ub32 fixnum storage)
+	            (store-only-fixnum fixnum storage)))))))
+
+
+(declaim (inline restore-tagged-unsigned-fixnum/interior))
+(defun restore-tagged-unsigned-fixnum/interior (storage)
+  "Use this if you know that this is an unsigned number (so after
+ another tag bit).  This opens up the direct coding space for up to
+ +interior-coded-max-integer+."
+  (declare (type read-storage storage))
+  (let ((tag (restore-ub8 storage)))
+    (if (> tag +first-direct-unsigned-integer-interior-code+)
+	(- tag +first-direct-unsigned-integer-interior-code+)
+	(+ (ecase tag
+	     (#.+ub8-code+ (restore-ub8 storage))
+	     (#.+ub16-code+ (restore-ub16 storage))
+	     (#.+ub32-code+ (restore-ub32 storage))
+	     (#.+fixnum-code+ (restore-fixnum storage)))
+	   +interior-coded-max-integer+ 1))))
+
 (declaim (ftype (function (read-storage)
 			  #+sbcl (values fixnum &optional)
 			  #-sbcl fixnum)
@@ -261,7 +296,6 @@
   "Read back a number written by `store-tagged-unsigned-fixnum'."
   (declare (optimize (speed 3) (safety 1)))
   (let ((tag (restore-ub8 storage)))
-    (declare (type (unsigned-byte 8) tag))
     (if (<= +small-integer-zero-code+ tag +last-small-integer-code+)
 	(- tag +small-integer-zero-code+)
 	(ecase tag
@@ -289,7 +323,7 @@
 
 (declaim (inline store-fixnum))
 (defun store-fixnum (fixnum storage)
-  "Store and tag a fixnum; "
+  "Store and tag a fixnum; if inside another tag"
   (declare (type fixnum fixnum) (optimize (speed 3) (safety 1)) (type write-storage storage))
   (if (>= fixnum 0)
       (store-tagged-unsigned-fixnum fixnum storage)

src/reference-coding.lisp

@@ -38,7 +38,7 @@
   "Number ranges from -16 to wherever.  This uses the reference-tag byte plus the tagged integer
  which can be anywhere from 1 byte direct tagged to arbitrarily large."
   (declare (optimize (speed 3) (safety 1)) (type fixnum number))
-  (truly-the fixnum
+  (the fixnum
     (+ (- +minimum-untagged-signed-integer+) number 1 +reference-two-byte-max-ref-id+)))
 
 (declaim (inline encode-reference-direct))

src/sap-ref.lisp

@@ -134,17 +134,80 @@
   (alexandria:once-only (x)
     `(logior ,x (- (mask-field (byte 1 (1- ,size)) ,x)))))
 
+(defmacro negative-to-twos-complement/8 (x)
+  (alexandria:once-only (x)
+    `(progn
+       (assert (< ,x 0))
+       (logand (+ 1 (logxor (- ,x) #xFF)) #xFF))))
+
+(defmacro negative-to-twos-complement/16 (x)
+  (alexandria:once-only (x)
+    `(progn
+       (assert (< ,x 0))
+       (logand (+ 1 (logxor (- ,x) #xFFFF)) #xFFFF))))
+
+(defmacro negative-to-twos-complement/32 (x)
+  (alexandria:once-only (x)
+    `(progn
+       (assert (< ,x 0))
+       (logand (+ 1 (logxor (- ,x) #xFFFFFFFF)) #xFFFFFFFF))))
+
 (defmacro negative-to-twos-complement/64 (x)
   (alexandria:once-only (x)
     `(progn
        (assert (< ,x 0))
        (logand (+ 1 (logxor (- ,x) #xFFFFFFFFFFFFFFFF)) #xFFFFFFFFFFFFFFFF))))
 
+(defmacro signed-sap-ref-8 (sap offset)
+  #+sbcl `(sb-sys:signed-sap-ref-8 ,sap ,offset)
+  #-(or sbcl allegro) `(cffi:mem-ref ,sap :int8 ,offset)
+  #+allegro `(mask-signed (sap-ref-8 ,sap ,offset) 8))
+
+(defmacro signed-sap-ref-16 (sap offset)
+  #+sbcl `(sb-sys:signed-sap-ref-16 ,sap ,offset)
+  #-(or sbcl allegro) `(cffi:mem-ref ,sap :int16 ,offset)
+  #+allegro `(mask-signed (sap-ref-16 ,sap ,offset) 16))
+
+(defmacro signed-sap-ref-32 (sap offset)
+  #+sbcl `(sb-sys:signed-sap-ref-32 ,sap ,offset)
+  #-(or sbcl allegro) `(cffi:mem-ref ,sap :int32 ,offset)
+  #+allegro `(mask-signed (sap-ref-32 ,sap ,offset) 32))
+
 (defmacro signed-sap-ref-64 (sap offset)
   #+sbcl `(sb-sys:signed-sap-ref-64 ,sap ,offset)
   #-(or sbcl allegro) `(cffi:mem-ref ,sap :int64 ,offset)
   #+allegro `(mask-signed (sap-ref-64 ,sap ,offset) 64))
 
+(defmacro set-signed-sap-ref-8 (sap offset value)
+  #+sbcl `(setf (sb-sys:signed-sap-ref-8 ,sap ,offset) ,value)
+  #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :int8 ,offset) ,value)
+  #+allegro
+  (alexandria:once-only (sap offset value)
+    ` (set-sap-ref-8 ,sap ,offset
+		      (if (< ,value 0)
+			  (negative-to-twos-complement/8 ,value)
+			  ,value))))
+
+(defmacro set-signed-sap-ref-16 (sap offset value)
+  #+sbcl `(setf (sb-sys:signed-sap-ref-16 ,sap ,offset) ,value)
+  #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :int16 ,offset) ,value)
+  #+allegro
+  (alexandria:once-only (sap offset value)
+    ` (set-sap-ref-16 ,sap ,offset
+		      (if (< ,value 0)
+			  (negative-to-twos-complement/16 ,value)
+			  ,value))))
+
+(defmacro set-signed-sap-ref-32 (sap offset value)
+  #+sbcl `(setf (sb-sys:signed-sap-ref-32 ,sap ,offset) ,value)
+  #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :int32 ,offset) ,value)
+  #+allegro
+  (alexandria:once-only (sap offset value)
+    ` (set-sap-ref-32 ,sap ,offset
+		      (if (< ,value 0)
+			  (negative-to-twos-complement/32 ,value)
+			  ,value))))
+
 (defmacro set-signed-sap-ref-64 (sap offset value)
   #+sbcl `(setf (sb-sys:signed-sap-ref-64 ,sap ,offset) ,value)
   #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :int64 ,offset) ,value)