Skip to content
Browse files

Optimize float i/o on SBCL.

  • Loading branch information...
1 parent 8b91182 commit 53aaf3d904b24051b05ec65e815e3c338dc03dc4 @stassats committed Aug 15, 2012
Showing with 99 additions and 37 deletions.
  1. +6 −0 benchmarks.lisp
  2. +4 −12 disk.lisp
  3. +28 −2 io-generic.lisp
  4. +3 −3 io-sbcl-strings.lisp
  5. +56 −19 io-sbcl.lisp
  6. +2 −1 storage.asd
View
6 benchmarks.lisp
@@ -77,6 +77,12 @@
(defmethod create-test-object ((type (eql 'bignum-ratio)) &key)
2333333331232/2333333331231)
+(defmethod create-test-object ((type (eql 'single-float)) &key)
+ 1s0)
+
+(defmethod create-test-object ((type (eql 'double-float)) &key)
+ -1d0)
+
(defun class-preallocation-test (storage)
(loop for class in (storage-data storage)
for length = (length (objects-of-class class))
View
16 disk.lisp
@@ -324,28 +324,20 @@
;;; Float
-(defun write-8-bytes (n stream)
- (write-n-bytes (ldb (byte 32 0) n) 4 stream)
- (write-n-bytes (ldb (byte 64 32) n) 4 stream))
-
-(defun read-8-bytes (stream)
- (logior (read-n-bytes 4 stream)
- (ash (read-n-bytes 4 stream) 32)))
-
(defmethod write-object ((float float) stream)
(etypecase float
(single-float
(write-n-bytes #.(type-code 'single-float) 1 stream)
- (write-n-bytes (ieee-floats:encode-float32 float) 4 stream))
+ (write-single-float float stream))
(double-float
(write-n-bytes #.(type-code 'double-float) 1 stream)
- (write-8-bytes (ieee-floats:encode-float64 float) stream))))
+ (write-double-float float stream))))
(defreader single-float (stream)
- (ieee-floats:decode-float32 (read-n-bytes 4 stream)))
+ (read-single-float stream))
(defreader double-float (stream)
- (ieee-floats:decode-float64 (read-8-bytes stream)))
+ (read-double-float stream))
;;; Complex
View
30 io-generic.lisp
@@ -11,6 +11,7 @@
(2 `(read-2-bytes ,stream))
(3 `(read-3-bytes ,stream))
(4 `(read-4-bytes ,stream))
+ (8 `(read-8-bytes ,stream))
(t form)))
(declaim (inline read-n-bytes))
@@ -19,14 +20,16 @@
(1 (read-byte stream))
(2 (read-2-bytes stream))
(3 (read-3-bytes stream))
- (4 (read-4-bytes stream))))
+ (4 (read-4-bytes stream))
+ (8 (read-8-bytes stream))))
(declaim (inline read-n-signed-bytes))
(defun read-n-signed-bytes (n stream)
(let ((byte (read-n-bytes n stream)))
(logior byte (- (mask-field (byte 1 (1- (* n 8))) byte)))))
-(declaim (inline read-2-bytes read-3-bytes read-4-bytes))
+(declaim (inline read-2-bytes read-3-bytes read-4-bytes
+ read-8-bytes))
(defun read-2-bytes (stream)
(declare (optimize speed))
(let ((1-byte (read-byte stream))
@@ -48,6 +51,10 @@
(4-byte (read-byte stream)))
(logior (ash 4-byte 24) (ash 3-byte 16) (ash 2-byte 8) 1-byte)))
+(defun read-8-bytes (stream)
+ (logior (read-4-bytes stream)
+ (ash (read-4-bytes stream) 32)))
+
(declaim (inline write-n-bytes))
(defun write-n-bytes (integer n stream)
(loop for low-bit to (* 8 (1- n)) by 8
@@ -57,6 +64,25 @@
(defun write-n-signed-bytes (integer n stream)
(write-n-bytes (ldb (byte (* n 8) 0) integer) n stream))
+;;; floats
+
+(declaim (inline read-single-float read-double-float
+ write-single-float write-double-float))
+
+(defun read-single-float (stream)
+ (ieee-floats:decode-float32 (read-n-bytes 4 stream)))
+
+(defun read-double-float (stream)
+ (ieee-floats:decode-float64 (read-n-bytes 8 stream)))
+
+(defun write-single-float (value stream)
+ (write-n-bytes (ieee-floats:encode-float32 value) 4 stream))
+
+(defun write-double-float (value stream)
+ (write-n-bytes (ieee-floats:encode-float64 value) 8 stream))
+
+;;;
+
(defmacro with-io-file ((stream file &key (direction :input) size) &body body)
(declare (ignore size))
`(with-open-file (,stream ,file
View
6 io-sbcl-strings.lisp
@@ -38,7 +38,7 @@
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size
:from-memory t)
- (flush-buffer stream (- adjusted-end start))
+ (flush-output-buffer stream (- adjusted-end start))
(copy-string (+ string (* quot memory-char-size))
start new-position
:buffer-char-size buffer-char-size
@@ -96,14 +96,14 @@
((> rem 0)
(let ((left-char (n-mem-ref rem (- end rem))))
(decf left-length 3)
- (fill-buffer stream 0)
+ (fill-input-buffer stream 0)
(setf (mem-ref-32 string)
(logior left-char
(ash (n-mem-ref left-bytes start) (* rem 8))))
(setf start (+ start left-bytes))
(incf string memory-char-size)))
(t
- (fill-buffer stream 0)))
+ (fill-input-buffer stream 0)))
(copy-string string start (+ start left-length)
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size)
View
75 io-sbcl.lisp
@@ -34,10 +34,16 @@
(declaim (inline (setf ,name)))
(defun (setf ,name) (value address &optional (offset 0))
- (declare (type (,(if signed
- 'signed-byte
- 'unsigned-byte)
- ,bits) value)
+ (declare (type ,(cond
+ ((eql bits 'double)
+ 'double-float)
+ ((eql bits 'single)
+ 'single-float)
+ (signed
+ `(signed-byte ,bits))
+ (t
+ `(unsigned-byte ,bits)))
+ value)
(type word address)
(fixnum offset)
(sb-ext:muffle-conditions sb-ext:compiler-note))
@@ -47,6 +53,8 @@
(define-sap-ref-wrapper 16)
(define-sap-ref-wrapper 32)
(define-sap-ref-wrapper #.sb-vm:n-word-bits :name word)
+(define-sap-ref-wrapper single)
+(define-sap-ref-wrapper double)
(define-sap-ref-wrapper 8 :signed t)
(define-sap-ref-wrapper 16 :signed t)
@@ -98,7 +106,7 @@
(sb-alien:make-alien char
;; alignment
(+ +buffer-size+
- sb-vm:n-word-bytes)))))
+ 8)))))
(defstruct (input-stream
(:predicate nil))
@@ -139,7 +147,7 @@
(input-stream-buffer-start stream)))
(defun close-output-stream (stream)
- (flush-buffer stream)
+ (flush-output-buffer stream)
(sb-alien:alien-funcall
(sb-alien:extern-alien "free"
(function (values) sb-alien:long))
@@ -169,7 +177,7 @@
sb-alien:int sb-alien:long sb-alien:int))
fd buf len))
-(defun fill-buffer (stream offset)
+(defun fill-input-buffer (stream offset)
(let ((length (unix-read (input-stream-fd stream)
(+ (input-stream-buffer-start stream) offset)
(- +buffer-size+ offset))))
@@ -178,33 +186,37 @@
(decf (input-stream-left stream) length))
t)
-(defun refill-buffer (n stream)
+(defun refill-input-buffer (n stream)
(declare (type word n)
(input-stream stream))
(let ((left-n-bytes (- (input-stream-buffer-end stream)
(input-stream-buffer-position stream))))
(when (> (- n left-n-bytes)
(input-stream-left stream))
(error "End of file ~a" stream))
- (unless (zerop left-n-bytes)
- (setf (mem-ref-word (input-stream-buffer-start stream))
- (n-mem-ref left-n-bytes
- (input-stream-buffer-position stream))))
- (fill-buffer stream left-n-bytes))
+ (loop for start from (input-stream-buffer-start stream)
+ by sb-vm:n-word-bytes
+ for position from (input-stream-buffer-position stream)
+ below (input-stream-buffer-end stream)
+ by sb-vm:n-word-bytes
+ do
+ (setf (mem-ref-word start)
+ (mem-ref-word position)))
+ (fill-input-buffer stream left-n-bytes))
(let ((start (input-stream-buffer-start stream)))
(setf (input-stream-buffer-position stream)
(+ start n)))
t)
(declaim (inline advance-input-stream))
(defun advance-input-stream (n stream)
- (declare (type (integer 1 4) n)
+ (declare (type (integer 1 8) n)
(type input-stream stream))
(let* ((sap (input-stream-buffer-position stream))
(new-sap (truly-the word (+ sap n))))
(declare (word sap new-sap))
(cond ((> new-sap (input-stream-buffer-end stream))
- (refill-buffer n stream)
+ (refill-input-buffer n stream)
(input-stream-buffer-start stream))
(t
(setf (input-stream-buffer-position stream)
@@ -232,7 +244,7 @@
(setf (n-signed-mem-ref n (advance-output-stream n stream)) value)
t)
-(defun flush-buffer (stream &optional count)
+(defun flush-output-buffer (stream &optional count)
(unix-write (output-stream-fd stream)
(output-stream-buffer-start stream)
(or count
@@ -243,14 +255,14 @@
(defun advance-output-stream (n stream)
(declare (optimize (safety 0))
(type output-stream stream)
- ((integer 1 4) n))
+ ((integer 1 8) n))
(let* ((sap (output-stream-buffer-position stream))
(new-sap (truly-the word (+ sap n))))
(declare (word sap new-sap))
(cond ((> new-sap (output-stream-buffer-end stream))
- (flush-buffer stream)
+ (flush-output-buffer stream)
(setf (output-stream-buffer-position stream)
- (+ n (output-stream-buffer-start stream)))
+ (truly-the word (+ n (output-stream-buffer-start stream))))
(output-stream-buffer-start stream))
(t
(setf (output-stream-buffer-position stream)
@@ -265,6 +277,31 @@
;;;
+(declaim (inline read-single-float))
+(defun read-single-float (stream)
+ (declare (optimize speed))
+ (mem-ref-single (advance-input-stream 4 stream)))
+
+(declaim (inline read-double-float))
+(defun read-double-float (stream)
+ (declare (optimize speed)
+ (sb-ext:muffle-conditions sb-ext:compiler-note))
+ (mem-ref-double (advance-input-stream 8 stream)))
+
+(declaim (inline write-single-float))
+(defun write-single-float (value stream)
+ (declare (optimize speed (safety 0)))
+ (setf (mem-ref-single (advance-output-stream 4 stream)) value)
+ t)
+
+(declaim (inline write-double-float))
+(defun write-double-float (value stream)
+ (declare (optimize speed (safety 0)))
+ (setf (mem-ref-double (advance-output-stream 8 stream)) value)
+ t)
+
+;;;
+
(defmacro with-io-file ((stream file
&key append (direction :input))
&body body)
View
3 storage.asd
@@ -4,7 +4,8 @@
:name "storage"
:serial t
:depends-on (alexandria
- closer-mop ieee-floats)
+ closer-mop
+ #-sbcl ieee-floats)
:components ((:file "packages")
#+(and sbcl (or x86 x86-64))
(:file "io-sbcl")

0 comments on commit 53aaf3d

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