Microoptimize io-sbcl-strings.

stassats · Oct 5, 2013 · 80302ce · 80302ce
1 parent 6f1ccf6
commit 80302ce
Showing 1 changed file with 57 additions and 52 deletions.
diff --git a/io-sbcl-strings.lisp b/io-sbcl-strings.lisp
@@ -65,38 +65,45 @@
 
 (defun read-string-boundary (length string stream
                              buffer-char-size memory-char-size)
-  (declare (simple-string string))
-  (let* ((position (input-stream-buffer-position stream))
-         (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))
-             (string-address (vector-address string))
-             (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-address position (+ position left)
-                     :buffer-char-size buffer-char-size
-                     :memory-char-size memory-char-size)
-        (incf string-address (* quot memory-char-size))
-        (cond
-          ((> rem 0)
-           (let ((left-char (n-mem-ref rem (- end rem))))
-             (decf left-length 3)
-             (fill-input-buffer stream 0)
-             (setf (mem-ref-32 string-address)
-                   (logior left-char
-                           (ash (n-mem-ref left-bytes start) (* rem 8))))
-             (setf start (+ start left-bytes))
-             (incf string-address memory-char-size)))
-          (t
-           (fill-input-buffer stream 0)))
-        (copy-string string-address 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))))))
+  (declare (simple-string string)
+           ((integer 1 4) buffer-char-size memory-char-size)
+           (sb-int:index length))
+  (let ((length (* length buffer-char-size)))
+    (when (> length +buffer-size+)
+      (error "Strings of more than ~a are not supported yet."
+             +buffer-size+))
+    (let* ((position (input-stream-buffer-position stream))
+           (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))
+               (string-address (vector-address string))
+               (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-address position (+ position left)
+                       :buffer-char-size buffer-char-size
+                       :memory-char-size memory-char-size)
+          (incf string-address (* quot memory-char-size))
+          (cond
+            ((> rem 0)
+             (let ((left-char (n-mem-ref rem (- end rem))))
+               (decf left-length 3)
+               (fill-input-buffer stream 0)
+               (setf (mem-ref-32 string-address)
+                     (logior left-char
+                             (ash (n-mem-ref left-bytes start) (* rem 8))))
+               (setf start (+ start left-bytes))
+               (incf string-address memory-char-size)))
+            (t
+             (fill-input-buffer stream 0)))
+          (copy-string string-address 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))))))
+  string)
 
 (declaim (inline read-optimized-string-generic))
 (defun read-optimized-string-generic (length string stream
@@ -108,23 +115,20 @@
            (optimize speed))
   (sb-sys:with-pinned-objects (string)
     (let* ((position (input-stream-buffer-position stream))
-           (length (* length buffer-char-size))
+           (word-length (* length buffer-char-size))
            (string-address (vector-address string))
-           (new-position (truly-the word (+ position length))))
-      (declare (type word position new-position))
+           (new-position (truly-the word (+ position word-length))))
+      (declare (type word position new-position word-length))
       (cond ((<= new-position (input-stream-buffer-end stream))
              (copy-string string-address position new-position
                           :buffer-char-size buffer-char-size
                           :memory-char-size memory-char-size)
              (setf (input-stream-buffer-position stream)
-                   new-position))
-            ((<= length +buffer-size+)
-             (read-string-boundary length string stream
-                                   buffer-char-size memory-char-size))
+                   new-position)
+             string)
             (t
-             (error "Strings of more than ~a are not supported yet."
-                    +buffer-size+)))))
-  string)
+             (read-string-boundary length string stream
+                                   buffer-char-size memory-char-size))))))
 
 (declaim (inline read-ascii-string-optimized))
 (defun read-ascii-string-optimized (length string stream)
@@ -164,13 +168,14 @@
 (defun ascii-string-p (string)
   (declare (simple-string string)
            (optimize speed))
-  (let* ((start (vector-address string))
-         (end (truly-the word (+ start
-                                 (* (length string) 4)))))
-    (declare (word start end))
-    (loop for address of-type word = start
-          then (truly-the word (+ address sb-vm:n-word-bytes))
-          while (< address end)
-          never (logtest (mem-ref-word address)
-                         #+x86-64 #xFFFFFF80FFFFFF80
-                         #+x86 #xFFFFFF80))))
+  (sb-sys:with-pinned-objects (string)
+    (let* ((start (vector-address string))
+           (end (truly-the word (+ start
+                                   (* (length string) 4)))))
+      (declare (word start end))
+      (loop for address of-type word = start
+              then (truly-the word (+ address sb-vm:n-word-bytes))
+            while (< address end)
+            never (logtest (mem-ref-word address)
+                           #+x86-64 #xFFFFFF80FFFFFF80
+                           #+x86 #xFFFFFF80)))))