[Openmcl-devel] with-output-to-string performance patch

[Alan Ruttenberg]

I was poking around with shark looking at some code I use and one of 
the places it was spending a lot of time in was writing string output 
streams.

This code improves performance by about a factor of 2 for (prin1 100) 
and almost 2 1/2 for writing a short string and reduces consing.
Substantial improvements for using ppcre::regex-replace as well.

(let ((a nil)) (time (dotimes (i 50000) (setq a (with-output-to-string 
(s) (write-string "foo" s))))) a)
(DOTIMES (I 50000) (SETQ A (WITH-OUTPUT-TO-STRING (S) (WRITE-STRING 
"foo" S)))) took 3,795 milliseconds (3.795 seconds) to run.
Of that, 3,120 milliseconds (3.120 seconds) were spent in user mode
          140 milliseconds (0.140 seconds) were spent in system mode
          535 milliseconds (0.535 seconds) were spent executing other OS 
processes.
41 milliseconds (0.041 seconds) was spent in GC.
  12,000,000 bytes of memory allocated.

? (load "openmcl-string-output-stream.lisp")

? (let ((a nil)) (time (dotimes (i 50000) (setq a 
(with-output-to-string (s) (write-string "foo" s))))) a)
(DOTIMES (I 50000) (SETQ A (WITH-OUTPUT-TO-STRING (S) (WRITE-STRING 
"foo" S)))) took 1,481 milliseconds (1.481 seconds) to run.
Of that, 1,290 milliseconds (1.290 seconds) were spent in user mode
          40 milliseconds (0.040 seconds) were spent in system mode
          151 milliseconds (0.151 seconds) were spent executing other OS 
processes.
17 milliseconds (0.017 seconds) was spent in GC.
  5,200,000 bytes of memory allocated.

---

openmcl-string-output-stream.lisp

;; cut through the gunk when you know you created the stream
(defun %get-output-stream-string (s)
   (let ((string (%string-stream-string s)))
     (prog1
	(%copy-array #.(element-type-subtype (type-specifier 
(array-ctype-element-type (specifier-type 'ccl::simple-string))))
		     string)
       (setf (fill-pointer string) 0))))

;; use %get-output-stream-string
(defmacro with-output-to-string ((var &optional string &key 
(element-type 'base-char element-type-p))
                                  &body body
                                  &environment env)
   (multiple-value-bind (forms decls) (parse-body body env nil)
     `(let ((,var ,(if string
                     `(%make-string-output-stream ,string)
                     `(make-string-output-stream :element-type ,(if 
element-type-p element-type `'base-char)))))
        , at decls
        (unwind-protect
          (progn
            , at forms
            ,@(if string () `((%get-output-stream-string ,var))))
          (close ,var)))))

;; cut out a bunch of gf dispatches
(defmethod stream-write-string ((s string-output-stream) string 
&optional (start 0) (end (length string)))
   (declare (optimize (speed 3)))
   (let ((oss (string-stream-string s)))
     (multiple-value-bind (vect offset) (array-data-and-offset string)
       (declare (fixnum offset))
       (unless (zerop offset)
	(setq start offset)
	(setq end offset))
       (do* ((i start (the fixnum (1+ i))))
	   ((= i end) string)
	(declare (fixnum i))
	(let ((char (%schar vect i)))
	  (if (eq char #\newline)
	      (setf (%stream-column s) 0)
	      (incf (%stream-column s)))
	  (vector-push-extend char oss))))))