Skip to content

Commit

Permalink
io-sbcl: Some more refactoring.
Browse files Browse the repository at this point in the history
  • Loading branch information
@stassats
stassats committed May 11, 2012
1 parent 6362dbf commit a985ecb
Show file tree
Hide file tree
Showing 2 changed files with 84 additions and 86 deletions.
155 changes: 77 additions & 78 deletions io-sbcl-strings.lisp
View file
Expand Up @@ -7,15 +7,14 @@
from-memory)
(declare (type (integer 1 8) memory-char-size buffer-char-size)
(word string buffer buffer-end)
(optimize speed (safety 0))
(sb-ext:muffle-conditions sb-ext:compiler-note))
(when (= 1 memory-char-size buffer-char-size)
(setf memory-char-size sb-vm:n-word-bytes
buffer-char-size sb-vm:n-word-bytes))
(loop for string-index of-type word = string
then (+ string-index memory-char-size)
then (truly-the word (+ string-index memory-char-size))
for buffer-index of-type word = buffer
then (+ buffer-index buffer-char-size)
then (truly-the word (+ buffer-index buffer-char-size))
while (< buffer-index buffer-end)
do
(if from-memory
Expand All @@ -26,14 +25,35 @@
(n-mem-ref buffer-char-size buffer-index)
(mem-ref-word buffer-index))))))

(defun write-string-boundary (length string stream
position buffer-char-size memory-char-size)
(let* ((end (output-stream-buffer-end stream))
(space-in-buffer (- end position)))
(multiple-value-bind (quot rem)
(floor space-in-buffer buffer-char-size)
(let* ((start (output-stream-buffer-start stream))
(new-position (+ start (- length (- space-in-buffer rem))))
(adjusted-end (- end rem)))
(copy-string string position adjusted-end
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size
:from-memory t)
(flush-buffer stream (- adjusted-end start))
(copy-string (+ string (* quot memory-char-size))
start new-position
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size
:from-memory t)
(setf (output-stream-buffer-position stream)
new-position)))))

(declaim (inline write-optimized-string-generic))
(defun write-optimized-string-generic (string stream
&key (buffer-char-size 1)
(memory-char-size 1))
(declare (optimize speed)
(sb-ext:muffle-conditions sb-ext:compiler-note)
(simple-string string)
(type (integer 1 4) buffer-char-size memory-char-size))
(declare (simple-string string)
(type (integer 1 4) buffer-char-size memory-char-size)
(sb-ext:muffle-conditions sb-ext:compiler-note))
(sb-sys:with-pinned-objects (string)
(let* ((length (* (length string) buffer-char-size))
(position (output-stream-buffer-position stream))
Expand All @@ -48,45 +68,56 @@
(setf (output-stream-buffer-position stream)
new-position))
((<= length +buffer-size+)
(let ((left (truly-the
word
(- (output-stream-buffer-end stream) position))))
(declare (buffer-length left))
(multiple-value-bind (quot rem) (floor left buffer-char-size)
(let* ((start (output-stream-buffer-start stream))
(left (- left rem))
(left-length (- length left)))
(declare (word left left-length))
(copy-string string position (+ position left)
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size
:from-memory t)
(setf (output-stream-buffer-position stream)
(truly-the
word
(- (output-stream-buffer-end stream) rem)))
(flush-buffer stream)
(copy-string (+ string (* quot memory-char-size))
start (+ start left-length)
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size
:from-memory t)
(setf (output-stream-buffer-position stream)
(truly-the word (+ start left-length)))))))
(write-string-boundary length string stream
position buffer-char-size memory-char-size))
(t
(error "Strings of more than ~a are not supported yet."
+buffer-size+)))))
string)

;;; reading

(defun read-string-boundary (length string stream position
buffer-char-size memory-char-size)
(let ((left (- (input-stream-buffer-end stream) position)))
(multiple-value-bind (quot rem) (floor left buffer-char-size)
(let* ((start (input-stream-buffer-start stream))
(end (input-stream-buffer-end stream))
(left (- left rem))
(left-bytes (- buffer-char-size rem))
(left-length (- length left)))
(when (> left-length (input-stream-left stream))
(error "End of file ~a" stream))
(copy-string string position (+ position left)
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size)
(incf string (* quot memory-char-size))
(cond
((> rem 0)
(let ((left-char (n-mem-ref rem (- end rem))))
(decf left-length 3)
(fill-buffer stream 0)
(setf (mem-ref-32 string)
(logior left-char
(ash
(the (unsigned-byte 24)
(n-mem-ref left-bytes start))
(* rem 8))))
(setf start (+ start left-bytes))
(incf string memory-char-size)))
(t
(fill-buffer stream 0)))
(copy-string string start (+ start left-length)
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size)
(setf (input-stream-buffer-position stream) (+ start left-length))))))

(declaim (inline read-optimized-string-generic))
(defun read-optimized-string-generic (length string stream
&key (buffer-char-size 1)
(memory-char-size 1))
(declare (type sb-int:index length)
(type (integer 1 4) buffer-char-size memory-char-size)
(optimize speed)
(sb-ext:muffle-conditions sb-ext:compiler-note))
(sb-sys:with-pinned-objects (string)
(let* ((position (input-stream-buffer-position stream))
Expand All @@ -101,83 +132,51 @@
(setf (input-stream-buffer-position stream)
new-position))
((<= length +buffer-size+)
(let ((left (truly-the
word
(- (input-stream-buffer-end stream) position))))
(declare (buffer-length left))
(multiple-value-bind (quot rem) (floor left buffer-char-size)
(let* ((start (input-stream-buffer-start stream))
(end (input-stream-buffer-end stream))
(left (- left rem))
(left-bytes (- buffer-char-size rem))
(left-length (- length left)))
(declare (word left left-length)
(type (integer 0 3) left-bytes))
(when (> left-length (input-stream-left stream))
(error "End of file ~a" stream))
(copy-string string position (+ position left)
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size)
(incf string (* quot memory-char-size))
(cond
((> rem 0)
(let ((left-char
(truly-the
(unsigned-byte 24)
(n-mem-ref rem (- end rem)))))
(decf left-length 3)
(fill-buffer stream 0)
(setf (mem-ref-32 string)
(logior left-char
(ash
(the (unsigned-byte 24)
(n-mem-ref left-bytes start))
(* rem 8))))
(setf start
(truly-the word (+ start left-bytes)))
(incf string memory-char-size)))
(t
(fill-buffer stream 0)))
(copy-string string start (+ start left-length)
:buffer-char-size buffer-char-size
:memory-char-size memory-char-size)
(setf (input-stream-buffer-position stream)
(truly-the word (+ start left-length)))))))
(read-string-boundary length string stream position
buffer-char-size memory-char-size))
(t
(error "Strings of more than ~a are not supported yet."
+buffer-size+)))))
string)

(declaim (inline read-ascii-string-optimized))
(defun read-ascii-string-optimized (length string stream)
(declare (simple-string string)
(optimize speed))
(read-optimized-string-generic length string stream))

(declaim (inline write-ascii-string-optimized))
(defun write-ascii-string-optimized (string stream)
(declare (simple-string string))
(declare (simple-string string)
(optimize speed))
(write-optimized-string-generic string stream))

(declaim (inline write-ascii-non-base-string-optimized))
(defun write-ascii-non-base-string-optimized (string stream)
(declare (simple-string string)
(optimize speed))
(write-optimized-string-generic string stream :memory-char-size 4))

(declaim (inline read-multibyte-string-optimized))
(defun read-multibyte-string-optimized (length string stream)
(declare (simple-string string)
(optimize speed))
(read-optimized-string-generic length string stream
:buffer-char-size 3
:memory-char-size 4))

(declaim (inline write-multibyte-string-optimized))
(defun write-multibyte-string-optimized (string stream)
(declare (simple-string string)
(optimize speed))
(write-optimized-string-generic string stream
:buffer-char-size 3
:memory-char-size 4))
;;;

(declaim (inline optimized-ascii-string-p))
(defun optimized-ascii-string-p (string)
(declare (simple-string string)
(optimize speed))
(declare (simple-string string))
(let* ((start (vector-address string))
(end (truly-the word (+ start
(* (length string) 4)))))
Expand Down
15 changes: 7 additions & 8 deletions io-sbcl.lisp
View file
Expand Up @@ -25,7 +25,6 @@
(defun ,name (address &optional (offset 0))
(declare (type word address)
(fixnum offset)
(optimize speed)
(sb-ext:muffle-conditions sb-ext:compiler-note))
(,sb-sys (sb-sys:int-sap address) offset))

Expand All @@ -34,7 +33,6 @@
(declare (type (unsigned-byte ,bits) value)
(type word address)
(fixnum offset)
(optimize speed)
(sb-ext:muffle-conditions sb-ext:compiler-note))
(setf (,sb-sys (sb-sys:int-sap address) offset) value)))))

Expand All @@ -50,8 +48,7 @@

(declaim (inline mem-ref-24))
(defun mem-ref-24 (address &optional (offset 0))
(declare (optimize speed (safety 0))
(word address)
(declare (word address)
(fixnum offset))
(mask-field (byte 24 0) (mem-ref-32 address offset)))

Expand Down Expand Up @@ -215,7 +212,8 @@

(declaim (inline read-n-bytes))
(defun read-n-bytes (n stream)
(declare (type (integer 1 4) n))
(declare (type (integer 1 4) n)
(optimize speed))
(n-mem-ref n (advance-input-stream n stream)))

(declaim (inline read-n-signed-bytes))
Expand All @@ -233,11 +231,12 @@
(setf (n-signed-mem-ref n (advance-output-stream n stream)) value)
t)

(defun flush-buffer (stream)
(defun flush-buffer (stream &optional count)
(unix-write (output-stream-fd stream)
(output-stream-buffer-start stream)
(- (output-stream-buffer-position stream)
(output-stream-buffer-start stream))))
(or count
(- (output-stream-buffer-position stream)
(output-stream-buffer-start stream)))))

(declaim (inline advance-output-stream))
(defun advance-output-stream (n stream)
Expand Down

0 comments on commit a985ecb

Please sign in to comment.