Commit ffada140 authored by Stas Boukarev's avatar Stas Boukarev
Browse files

Use two's complement for storing fixnums.

parent 80137e77
......@@ -28,11 +28,23 @@
(loop repeat (read-next-object stream)
do (read-next-object stream)))))
(defun identity-test (x &optional (mode :both))
(when (member mode '(:both :write))
(with-io-file (stream *test-file* :direction :output
:size (object-size x))
(write-object x stream)))
(when (member mode '(:both :read))
(with-io-file (stream *test-file*)
(read-next-object stream))))
(defgeneric create-test-object (type &key &allow-other-keys))
(defmethod create-test-object ((type (eql 'cons)) &key object-size)
(make-list (or object-size 10000) :initial-element nil))
(defmethod create-test-object ((type (eql 'fixnum)) &key)
-1)
(defun class-preallocation-test (storage)
(loop for class in (storage-data storage)
for length = (length (objects-of-class class))
......
......@@ -166,10 +166,10 @@
(defmethod object-size ((object integer))
(+ 1 ;; tag
1 ;; sign
(typecase object
(storage-fixnum +fixnum-length+)
(t (+ 1 ;; size
(t (+ 1 ;; sign
1 ;; size
(* (ceiling (integer-length (abs object))
(* +fixnum-length+ 8))
+fixnum-length+))))))
......@@ -183,8 +183,7 @@
(defun write-fixnum (n stream)
(declare (storage-fixnum n))
(write-n-bytes #.(type-code 'fixnum) 1 stream)
(write-n-bytes (sign n) 1 stream)
(write-n-bytes (abs n) +fixnum-length+ stream))
(write-n-signed-bytes n +fixnum-length+ stream))
(defun write-bignum (n stream)
(declare ((and integer (not storage-fixnum)) n))
......@@ -223,8 +222,7 @@
(* sign integer)))
(defreader fixnum (stream)
(* (read-sign stream)
(read-n-bytes +fixnum-length+ stream)))
(read-n-signed-bytes +fixnum-length+ stream))
;;; Ratio
......
......@@ -14,13 +14,18 @@
(t form)))
(declaim (inline read-n-bytes))
(defun read-n-bytes (bytes stream)
(ecase bytes
(defun read-n-bytes (n stream)
(ecase n
(1 (read-byte stream))
(2 (read-2-bytes stream))
(3 (read-3-bytes stream))
(4 (read-4-bytes stream))))
(declaim (inline read-n-signed-bytes))
(defun read-n-signed-bytes (n stream)
(let ((byte (read-n-bytes n stream)))
(logior byte (- (logand byte (ash 1 (1- (* n 8))))))))
(declaim (inline read-2-bytes read-3-bytes read-4-bytes))
(defun read-2-bytes (stream)
(declare (optimize speed))
......@@ -44,10 +49,14 @@
(logior (ash 4-byte 24) (ash 3-byte 16) (ash 2-byte 8) 1-byte)))
(declaim (inline write-n-bytes))
(defun write-n-bytes (integer bytes stream)
(loop for low-bit to (* 8 (1- bytes)) by 8
(defun write-n-bytes (integer n stream)
(loop for low-bit to (* 8 (1- n)) by 8
do (write-byte (ldb (byte 8 low-bit) integer) stream)))
(declaim (inline write-n-signed-bytes))
(defun write-n-signed-bytes (integer n stream)
(write-n-bytes (ldb (byte (* n 8) 0) integer) n stream))
(defmacro with-io-file ((stream file &key (direction :input) size) &body body)
(declare (ignore size))
`(with-open-file (,stream ,file
......
......@@ -84,6 +84,19 @@
(advance-stream n stream)
0))
(declaim (inline read-n-signed-bytes))
(defun read-n-signed-bytes (n stream)
(declare (optimize speed)
(sb-ext:muffle-conditions sb-ext:compiler-note)
(type (integer 1 4) n))
(funcall (ecase n
(1 #'sb-sys:signed-sap-ref-8)
(2 #'sb-sys:signed-sap-ref-16)
;; (3 )
(4 #'sb-sys:signed-sap-ref-32))
(advance-stream n stream)
0))
(declaim (inline write-n-bytes))
(defun write-n-bytes (value n stream)
(declare (optimize speed)
......@@ -91,6 +104,20 @@
(setf (sb-sys:sap-ref-32 (advance-stream n stream) 0) value)
t)
(declaim (inline write-n-signed-bytes))
(defun write-n-signed-bytes (value n stream)
(declare (optimize speed)
(fixnum n))
(ecase n
(1 (setf (sb-sys:signed-sap-ref-8 (advance-stream n stream) 0)
value))
(2 (setf (sb-sys:signed-sap-ref-16 (advance-stream n stream) 0)
value))
;; (3 )
(4 (setf (sb-sys:signed-sap-ref-32 (advance-stream n stream) 0)
value)))
t)
(declaim (inline copy-mem))
(defun copy-mem (from to length)
(loop for i below length by sb-vm:n-word-bytes
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment