Changeset 15175 for trunk/source/level-1

Timestamp:

Jan 24, 2012, 2:22:19 PM (9 years ago)

Author:

gb

Message:

Use an idea suggested by gz to make various flavors of READ-LINE faster.

File:

• trunk/source/level-1/l1-streams.lisp (modified) (4 diffs)

trunk/source/level-1/l1-streams.lisp

@@ -100 +100 @@
 ;;; For input streams:
 
-;; From Shannon Spires, slightly modified.
+;;; From Shannon Spires, slightly modified.
 (defun generic-read-line (s)
-  (let* ((len 20)
-         (pos 0)
-         (str (make-array len :element-type 'base-char))
-         (eof nil))
-    (declare (fixnum pos len) (simple-string str))
-    (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
-         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
-          (values (subseq str 0 pos) eof))
-      (when (= pos len)
-        (setq len (* len 2)
-              str (%extend-vector 0 str len)))
-      (setf (schar str pos) ch
-            pos (1+ pos)))))
+  (collect ((chunks))
+    (let* ((pos 0)
+           (len 0)
+           (chunksize 8192)
+           (str (make-string chunksize))
+           (eof nil))
+      (declare (fixnum pos len chunksize)
+               (simple-string str)
+               (dynamic-extent str))
+      (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
+           ((or (eq ch #\newline) (setq eof (eq ch :eof)))
+            (if (zerop len)
+              (values (subseq str 0 pos) eof)
+              (let* ((outpos 0))
+                (setq len (+ len pos))
+                (let* ((out (make-string len)))
+                  (dolist (s (chunks))
+                    (%uvector-replace out outpos s 0 chunksize target::subtag-simple-base-string)
+                    (incf outpos chunksize))
+                  (%uvector-replace out outpos str 0 pos target::subtag-simple-base-string)
+                  (values out eof)))))
+        (when (= pos chunksize)
+          (chunks str)
+          (setq str (make-string chunksize)
+                len (+ len pos)
+                pos 0))
+        (setf (schar str pos) ch
+              pos (1+ pos))))))
+
 
 (defun generic-character-read-list (stream list count)
@@ -2298 +2314 @@
             (io-buffer-idx buf) 0)))
 
+
 (defun %ioblock-unencoded-read-line (ioblock)
-  (let* ((inbuf (ioblock-inbuf ioblock)))
-    (let* ((string "")
+  (declare (optimize (speed 3) (safety 0)))
+  (collect ((octet-vectors))
+    (let* ((inbuf (ioblock-inbuf ioblock))
            (len 0)
-           (eof nil)
-           (filled-buf 0)
-           (buf (io-buffer-buffer inbuf))
-           (newline (char-code #\newline)))
-      (declare (fixnum filled-buf))
+           (buf (io-buffer-buffer inbuf)))
+      (declare (fixnum len) (type (simple-array (unsigned-byte 8)(*)) buf))
       (let* ((ch (ioblock-untyi-char ioblock)))
         (when ch
@@ -2312 +2327 @@
           (if (eql ch #\newline)
             (return-from %ioblock-unencoded-read-line 
-              (values string nil))
+              (values "" nil))
             (progn
-              (setq string (make-string 1)
-                    len 1)
-              (setf (schar string 0) ch)))))
-      (loop
-        (let* ((more 0)
-               (idx (io-buffer-idx inbuf))
-               (count (io-buffer-count inbuf)))
-          (declare (fixnum idx count more filled-buf))
-          (if (= idx count)
-            (if eof
-              (return (values string t))
-              (progn
-                (setq eof t)
-                (incf filled-buf)
-                (%ioblock-advance ioblock t)))
-            (progn
-              (setq eof nil)
-              (let* ((pos (position newline buf :start idx :end count)))
-                (when pos
-                  (locally (declare (fixnum pos))
-                    (setf (io-buffer-idx inbuf) (the fixnum (1+ pos)))
-                    (setq more (- pos idx))
-                    (unless (zerop more)
-                      (setq string
-                            (%extend-vector
-                             0 string (the fixnum (+ len more)))))
-                    (%copy-u8-to-string
-                     buf idx string len more)
-                    (return (values string nil))))
-                ;; No #\newline in the buffer.  Read everything that's
-                ;; there into the string, and fill the buffer again.
-                (setf (io-buffer-idx inbuf) count)
-                (setq more (- count idx)
-                      string (%extend-vector
-                              0 string (the fixnum (+ len more))))
-                (%copy-u8-to-string
-                 buf idx string len more)
-                (incf len more))
-              (when (> filled-buf 1)
-                (let* ((pos len))
-                  (loop
-                    (%ioblock-advance ioblock t)
-                    (setq count (io-buffer-count inbuf))
-                    (when (zerop count)                        
-                      (return-from %ioblock-unencoded-read-line
-                        (values (if (= pos len)
-                                  string
-                                  (subseq string 0 pos))
-                                t)))
-                    (let* ((p (position newline buf :end count))
-                           (n (or p count))
-                           (room (- len pos)))
-                      (declare (fixnum n room))
-                      (when (< room n)
-                        (setq len (+ len (the fixnum (or p len)))
-                              string (%extend-vector 0 string len)))
-                      (%copy-u8-to-string buf 0 string pos n)
-                      (incf pos n)
-                      (when p
-                        (return-from %ioblock-unencoded-read-line
-                          (values (if (= pos len)
-                                    string
-                                    (subseq string 0 pos)) nil)))
-                      (setf (io-buffer-idx inbuf) count))))))))))))
+              (octet-vectors (make-array 1 :element-type '(unsigned-byte 8)
+                                         :initial-element (char-code ch)))
+              (setq len 1)))))
+      (do* ((done nil)
+            (idx (io-buffer-idx inbuf))
+            (count (io-buffer-count inbuf)))
+           (done (let* ((string (make-string len))
+                        (outpos 0))
+                   (declare (simple-string string) (fixnum outpos))
+                   (dolist (v (octet-vectors (values string (eq done :eof))))
+                     (let* ((vlen (length v)))
+                       (declare (fixnum vlen))
+                       (%copy-u8-to-string v 0 string outpos vlen)
+                       (incf outpos vlen)))))
+        (declare (fixnum idx count))
+        (when (= idx count)
+          (%ioblock-advance ioblock t)
+          (setq idx (io-buffer-idx inbuf)
+                count (io-buffer-count inbuf)
+                done (if (= idx count) :eof)))
+        (unless done
+          (let* ((p (do* ((i idx (1+ i)))
+                         ((= i count)
+                          (setf (io-buffer-idx inbuf) count)
+                          nil)
+                      (declare (fixnum i))
+                      (when (eql (aref buf i) (char-code #\newline))
+                        (setf (io-buffer-idx inbuf) (the fixnum (1+ i)))
+                        (setq done t)
+                        (return i))))
+                 (end (or p count))
+                 (n (- end idx)))
+            (declare (fixnum p end n))
+            (if (and p (eql len 0))
+              ;; Likely a fairly common case
+              (let* ((string (make-string n)))
+                (%copy-u8-to-string buf idx string 0 n)
+                (return-from %ioblock-unencoded-read-line
+                  (values string nil)))
+              (let* ((v (make-array n :element-type '(unsigned-byte 8))))
+                (%copy-ivector-to-ivector buf idx v 0 n)
+                (incf len n)
+                (octet-vectors v)
+                (setq idx count)))))))))
+
 
 ;;; There are lots of ways of doing better here, but in the most general
@@ -2383 +2379 @@
 ;;; whether there's a 1:1 mapping between code units and characters.
 (defun %ioblock-encoded-read-line (ioblock)
-  (let* ((pos 0)
-         (len 20)
-         (str (make-string len))
-         (rcf (ioblock-read-char-when-locked-function ioblock))
-         (eof nil))
-    (declare (fixnum pos len) (simple-string str))
-    (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
-         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
-          (values (subseq str 0 pos) eof))
-      (when (= pos len)
-        (setq len (* len 2) str (%extend-vector 0 str len)))
-      (setf (schar str pos) ch
-            pos (1+ pos)))))
+  (declare (optimize (speed 3) (safety 0)))
+  (collect ((chunks))
+    (let* ((pos 0)
+           (len 0)
+           (chunksize 8192)
+           (str (make-string chunksize))
+           (rcf (ioblock-read-char-when-locked-function ioblock))
+           (eof nil))
+      (declare (fixnum pos len chunksize)
+               (simple-string str)
+               (dynamic-extent str))
+      (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
+           ((or (eq ch #\newline) (setq eof (eq ch :eof)))
+            (if (zerop len)
+              (values (subseq str 0 pos) eof)
+              (let* ((outpos 0))
+                (declare (fixnum outpos))
+                (setq len (+ len pos))
+                (let* ((out (make-string len)))
+                  (dolist (s (chunks))
+                    (%copy-ivector-to-ivector s 0 out outpos (the fixnum (ash chunksize 2)))
+                    (incf outpos (ash chunksize 2)))
+                  (%copy-ivector-to-ivector str 0 out outpos (the fixnum (ash pos 2)))
+                  (values out eof)))))
+        (when (= pos chunksize)
+          (chunks str)
+          (setq str (make-string chunksize)
+                len (+ len pos)
+                pos 0))
+        (setf (schar str pos) ch
+              pos (1+ pos))))))
          
 (defun %ioblock-unencoded-character-read-vector (ioblock vector start end)