From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 9 Mar 2004 14:45:37 +0000 (+0000)
Subject: 0.8.8.22:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=398c7bf8d47d979a1879cf67d596c2827a98b0d9;p=sbcl.git

0.8.8.22:
	Less pprint suboptimiality
	... s/simple-string/(simple-array character (*))/ and add
		explicit coercions;
	... this should remove most of the performance degradation in the
		pretty printer introduced around 0.8.1.x when (vector nil)
		was recognized as a string type.
---

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index b87e9ee..b9beee2 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -44,7 +44,7 @@
 	       :type column)
   ;; A simple string holding all the text that has been output but not yet
   ;; printed.
-  (buffer (make-string initial-buffer-size) :type simple-string)
+  (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
   ;; The index into BUFFER where more text should be put.
   (buffer-fill-pointer 0 :type index)
   ;; Whenever we output stuff from the buffer, we shift the remaining noise
@@ -75,12 +75,12 @@
   ;; Buffer holding the per-line prefix active at the buffer start.
   ;; Indentation is included in this. The length of this is stored
   ;; in the logical block stack.
-  (prefix (make-string initial-buffer-size) :type simple-string)
+  (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
   ;; Buffer holding the total remaining suffix active at the buffer start.
   ;; The characters are right-justified in the buffer to make it easier
   ;; to output the buffer. The length is stored in the logical block
   ;; stack.
-  (suffix (make-string initial-buffer-size) :type simple-string)
+  (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
   ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
   ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
   ;; cons. Adding things to the queue is basically (setf (cdr head) (list
@@ -134,7 +134,10 @@
 	   (type simple-string string)
 	   (type index start)
 	   (type (or index null) end))
-  (let ((end (or end (length string))))
+  (let* ((string (if (typep string '(simple-array character (*)))
+		     string
+		     (coerce string '(simple-array character (*)))))
+	 (end (or end (length string))))
     (unless (= start end)
       (let ((newline (position #\newline string :start start :end end)))
 	(cond
@@ -307,8 +310,8 @@
 (defstruct (block-start (:include section-start)
 			(:copier nil))
   (block-end nil :type (or null block-end))
-  (prefix nil :type (or null simple-string))
-  (suffix nil :type (or null simple-string)))
+  (prefix nil :type (or null (simple-array character (*))))
+  (suffix nil :type (or null (simple-array character (*)))))
 
 (defun start-logical-block (stream prefix per-line-p suffix)
   ;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
@@ -319,19 +322,19 @@
   ;; trivial, so it should always be a string.)
   (declare (type string suffix))
   (when prefix
-    (setq prefix (coerce prefix 'simple-string))
+    (setq prefix (coerce prefix '(simple-array character (*))))
     (pretty-sout stream prefix 0 (length prefix)))
   (let* ((pending-blocks (pretty-stream-pending-blocks stream))
 	 (start (enqueue stream block-start
 			 :prefix (and per-line-p prefix)
-			 :suffix (coerce suffix 'simple-string)
+			 :suffix (coerce suffix '(simple-array character (*)))
 			 :depth (length pending-blocks))))
     (setf (pretty-stream-pending-blocks stream)
 	  (cons start pending-blocks))))
 
 (defstruct (block-end (:include queued-op)
 		      (:copier nil))
-  (suffix nil :type (or null simple-string)))
+  (suffix nil :type (or null (simple-array character (*)))))
 
 (defun end-logical-block (stream)
   (let* ((start (pop (pretty-stream-pending-blocks stream)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 5203d4e..7dc6b0c 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.8.21"
+"0.8.8.22"