Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Compress fixnums better.

  • Loading branch information...
commit 5686b73f889e42522b2cc98755337ff5c4df44bd 1 parent 91ed2c4
@stassats authored
Showing with 56 additions and 1 deletion.
  1. +34 −1 disk.lisp
  2. +22 −0 io-sbcl.lisp
View
35 disk.lisp
@@ -26,7 +26,10 @@
vector
array
hash-table
- pathname)))
+ pathname
+ fixnum-1
+ fixnum-2
+ fixnum-3)))
(defvar *statistics* ())
(defun collect-stats (code)
@@ -252,6 +255,21 @@
(declare (storage-fixnum n))
(write-n-signed-bytes n +fixnum-length+ stream))
+(defun write-fixnum-1 (n stream)
+ (declare (storage-fixnum n))
+ (write-n-bytes #.(type-code 'fixnum-1) 1 stream)
+ (write-n-signed-bytes n 1 stream))
+
+(defun write-fixnum-2 (n stream)
+ (declare (storage-fixnum n))
+ (write-n-bytes #.(type-code 'fixnum-2) 1 stream)
+ (write-n-signed-bytes n 2 stream))
+
+(defun write-fixnum-3 (n stream)
+ (declare (storage-fixnum n))
+ (write-n-bytes #.(type-code 'fixnum-3) 1 stream)
+ (write-n-signed-bytes n 3 stream))
+
(declaim (inline sign))
(defun sign (n)
(if (minusp n)
@@ -272,6 +290,12 @@
(defmethod write-object ((object integer) stream)
(typecase object
+ ((signed-byte 8)
+ (write-fixnum-1 object stream))
+ ((signed-byte 16)
+ (write-fixnum-2 object stream))
+ ((signed-byte 24)
+ (write-fixnum-3 object stream))
(storage-fixnum
(write-n-bytes #.(type-code 'fixnum) 1 stream)
(write-fixnum object stream))
@@ -299,6 +323,15 @@
(defreader fixnum (stream)
(read-n-signed-bytes +fixnum-length+ stream))
+(defreader fixnum-1 (stream)
+ (read-n-signed-bytes 1 stream))
+
+(defreader fixnum-2 (stream)
+ (read-n-signed-bytes 2 stream))
+
+(defreader fixnum-3 (stream)
+ (read-n-signed-bytes 3 stream))
+
;;; Ratio
(defmethod write-object ((n ratio) stream)
View
22 io-sbcl.lisp
@@ -67,6 +67,26 @@
(fixnum offset))
(mask-field (byte 24 0) (mem-ref-32 address offset)))
+(declaim (inline signed-mem-ref-24))
+(defun signed-mem-ref-24 (address &optional (offset 0))
+ (declare (type word address)
+ (fixnum offset)
+ (sb-ext:muffle-conditions sb-ext:compiler-note)
+ (optimize speed))
+ (let ((byte (mask-field (byte 24 0)
+ (mem-ref-32 address offset))))
+ (logior byte (- (mask-field (byte 1 23) byte)))))
+
+(declaim (inline (setf signed-mem-ref-24)))
+(defun (setf signed-mem-ref-24) (value address &optional (offset 0))
+ (declare (type (signed-byte 24) value)
+ (type word address)
+ (fixnum offset)
+ (sb-ext:muffle-conditions sb-ext:compiler-note)
+ (optimize speed))
+ (setf (mem-ref-32 address offset)
+ (ldb (byte 24 0) value)))
+
(declaim (inline n-mem-ref))
(defun n-mem-ref (n address &optional (offset 0))
(declare (sb-ext:muffle-conditions sb-ext:compiler-note))
@@ -81,12 +101,14 @@
(ecase n
(1 (signed-mem-ref-8 address offset))
(2 (signed-mem-ref-16 address offset))
+ (3 (signed-mem-ref-24 address offset))
(4 (signed-mem-ref-32 address offset))))
(defun (setf n-signed-mem-ref) (value n address &optional (offset 0))
(ecase n
(1 (setf (signed-mem-ref-8 address offset) value))
(2 (setf (signed-mem-ref-16 address offset) value))
+ (3 (setf (signed-mem-ref-24 address offset) value))
(4 (setf (signed-mem-ref-32 address offset) value))))
(declaim (inline vector-address))
Please sign in to comment.
Something went wrong with that request. Please try again.