From 7ebe82f662f0fd0038479cbb057ec77867ab6f7e Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Sun, 13 Nov 2005 05:22:19 +0000 Subject: [PATCH] 0.9.6.40: Fix a small pprint performance problem caused by the Unicode work. * Allow using SIMPLE-BASE-STRINGs directly as pprint suffix/prefix, instead of coercing them to (SIMPLE-ARRAY CHARACTER). * OOAOM the idiom used in for specializing a block of code for several types of strings. --- src/code/fd-stream.lisp | 164 ++++++++++++++++++++--------------------------- src/code/pprint.lisp | 84 ++++++++++++++---------- src/code/seq.lisp | 9 +++ version.lisp-expr | 2 +- 4 files changed, 129 insertions(+), 130 deletions(-) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 6e2b2b4..5546272 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -503,25 +503,19 @@ (declare (fixnum start end)) (if (stringp thing) (let ((last-newline - (flet ((do-it (string) - (and (find #\newline string :start start :end end) - ;; FIXME why do we need both calls? - ;; Is find faster forwards than - ;; position is backwards? - (position #\newline string - :from-end t - :start start - :end end)))) - (declare (inline do-it)) - ;; Specialize the common cases - (etypecase thing - (simple-base-string - (do-it (the simple-base-string thing))) - #!+sb-unicode - ((simple-array character) - (do-it (the (simple-array character) thing))) - (string - (do-it thing)))))) + (string-dispatch (simple-base-string + #!+sb-unicode + (simple-array character) + string) + thing + (and (find #\newline thing :start start :end end) + ;; FIXME why do we need both calls? + ;; Is find faster forwards than + ;; position is backwards? + (position #\newline thing + :from-end t + :start start + :end end))))) (if (and (typep thing 'base-string) (eq (fd-stream-external-format stream) :latin-1)) (ecase (fd-stream-buffering stream) @@ -1004,44 +998,33 @@ (do () ((= end start)) (setf (fd-stream-obuf-tail stream) - (flet ((do-it (string) - (let ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - (declare (type index tail) - ;; STRING bounds have already been checked. - (optimize (safety 0))) - (loop - (,@(if output-restart - `(catch 'output-nothing) - `(progn)) - (do* () - ((or (= start end) (< (- len tail) 4))) - (let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size) - (incf start))) - ;; Exited from the loop normally - (return-from do-it tail)) - ;; Exited via CATCH. Skip the current character - ;; and try the inner loop again. - (incf start))))) - (declare (inline do-it)) - ;; Specialized versions for the common cases of - ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) - ;; to avoid doing a generic AREF. - (etypecase string - (simple-base-string - (do-it (the simple-base-string string))) - #!+sb-unicode - ((simple-array character) - ;; For some reason the type information from the - ;; etypecase doesn't propagate through here without - ;; an explicit THE. - (do-it (the (simple-array character) string))) - (string - (do-it string))))) + (string-dispatch (simple-base-string + #!+sb-unicode + (simple-array character) + string) + string + (let ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (loop + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) + (let* ((byte (aref string start)) + (bits (char-code byte))) + ,out-expr + (incf tail ,size) + (incf start))) + ;; Exited from the loop normally + (return tail)) + ;; Exited via CATCH. Skip the current character + ;; and try the inner loop again. + (incf start))))) (when (< start end) (flush-output-buffer stream))) (when flush-p @@ -1131,45 +1114,34 @@ (do () ((= end start)) (setf (fd-stream-obuf-tail stream) - (flet ((do-it (string) - (let ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - (declare (type index tail) - ;; STRING bounds have already been checked. - (optimize (safety 0))) - (loop - (,@(if output-restart - `(catch 'output-nothing) - `(progn)) - (do* () - ((or (= start end) (< (- len tail) 4))) - (let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size) - (incf start))) - ;; Exited from the loop normally - (return-from do-it tail)) - ;; Exited via CATCH. Skip the current character - ;; and try the inner loop again. - (incf start))))) - (declare (inline do-it)) - ;; Specialized versions for the common cases of - ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) - ;; to avoid doing a generic AREF. - (etypecase string - (simple-base-string - (do-it (the simple-base-string string))) - #!+sb-unicode - ((simple-array character) - ;; For some reason the type information from the - ;; etypecase doesn't propagate through here without - ;; an explicit THE. - (do-it (the (simple-array character) string))) - (string - (do-it string))))) + (string-dispatch (simple-base-string + #!+sb-unicode + (simple-array character) + string) + string + (let ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (loop + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) + (let* ((byte (aref string start)) + (bits (char-code byte)) + (size ,out-size-expr)) + ,out-expr + (incf tail size) + (incf start))) + ;; Exited from the loop normally + (return tail)) + ;; Exited via CATCH. Skip the current character + ;; and try the inner loop again. + (incf start))))) (when (< start end) (flush-output-buffer stream))) (when flush-p diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index aadf41a..7331459 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -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-array character (*))) + (prefix (make-string initial-buffer-size) :type simple-string) ;; 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-array character (*))) + (suffix (make-string initial-buffer-size) :type simple-string) ;; 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,33 +134,48 @@ (type simple-string string) (type index start) (type (or index null) end)) - (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (end (or end (length string)))) + (let* ((end (or end (length string)))) (unless (= start end) - (let ((newline (position #\newline string :start start :end end))) - (cond - (newline - (pretty-sout stream string start newline) - (enqueue-newline stream :literal) - (pretty-sout stream string (1+ newline) end)) - (t - (let ((chars (- end start))) - (loop - (let* ((available (ensure-space-in-buffer stream chars)) - (count (min available chars)) - (fill-pointer (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-pointer count))) - (replace (pretty-stream-buffer stream) - string - :start1 fill-pointer :end1 new-fill-ptr - :start2 start) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf chars count) - (when (zerop count) - (return)) - (incf start count)))))))))) + (sb!impl::string-dispatch (simple-base-string + #!+sb-unicode + (simple-array character)) + string + ;; For POSITION transform + (declare (optimize (speed 2))) + (let ((newline (position #\newline string :start start :end end))) + (cond + (newline + (pretty-sout stream string start newline) + (enqueue-newline stream :literal) + (pretty-sout stream string (1+ newline) end)) + (t + (let ((chars (- end start))) + (loop + (let* ((available (ensure-space-in-buffer stream chars)) + (count (min available chars)) + (fill-pointer (pretty-stream-buffer-fill-pointer + stream)) + (new-fill-ptr (+ fill-pointer count))) + (if (typep string 'simple-base-string) + ;; FIXME: Reimplementing REPLACE, since it + ;; can't be inlined and we don't have a + ;; generic "simple-array -> simple-array" + ;; transform for it. + (loop for i from fill-pointer below new-fill-ptr + for j from start + with target = (pretty-stream-buffer stream) + do (setf (aref target i) + (aref string j))) + (replace (pretty-stream-buffer stream) + string + :start1 fill-pointer :end1 new-fill-ptr + :start2 start)) + (setf (pretty-stream-buffer-fill-pointer stream) + new-fill-ptr) + (decf chars count) + (when (zerop count) + (return)) + (incf start count))))))))))) (defun pretty-misc (stream op &optional arg1 arg2) (declare (ignore stream op arg1 arg2))) @@ -310,8 +325,8 @@ (defstruct (block-start (:include section-start) (:copier nil)) (block-end nil :type (or null block-end)) - (prefix nil :type (or null (simple-array character (*)))) - (suffix nil :type (or null (simple-array character (*))))) + (prefix nil :type (or null simple-string)) + (suffix nil :type (or null simple-string))) (defun start-logical-block (stream prefix per-line-p suffix) ;; (In the PPRINT-LOGICAL-BLOCK form which calls us, @@ -322,19 +337,22 @@ ;; trivial, so it should always be a string.) (declare (type string suffix)) (when prefix - (setq prefix (coerce prefix '(simple-array character (*)))) + (unless (typep prefix 'simple-string) + (setq prefix (coerce prefix '(simple-array character (*))))) (pretty-sout stream prefix 0 (length prefix))) + (unless (typep suffix 'simple-string) + (setq suffix (coerce suffix '(simple-array character (*))))) (let* ((pending-blocks (pretty-stream-pending-blocks stream)) (start (enqueue stream block-start :prefix (and per-line-p prefix) - :suffix (coerce suffix '(simple-array character (*))) + :suffix suffix :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-array character (*))))) + (suffix nil :type (or null simple-string))) (defun end-logical-block (stream) (let* ((start (pop (pretty-stream-pending-blocks stream))) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index d4026d3..64075ab 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -2387,3 +2387,12 @@ (seq-dispatch sequence2 (list-search sequence2 sequence1) (vector-search sequence2 sequence1)))) + +(sb!xc:defmacro string-dispatch ((&rest types) var &body body) + (let ((fun (gensym "STRING-DISPATCH-FUN-"))) + `(flet ((,fun (,var) + ,@body)) + (declare (inline ,fun)) + (etypecase ,var + ,@(loop for type in types + collect `(,type (,fun (the ,type ,var)))))))) diff --git a/version.lisp-expr b/version.lisp-expr index c140bf1..fcd86ec 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.9.6.39" +"0.9.6.40" -- 1.7.10.4