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.
(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)
(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
(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
;; 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
(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)))
(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,
;; 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)))
(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))))))))
;;; 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"
projects / sbcl.git / commitdiff