Index: /branches/working-0711/ccl/level-1/l1-streams.lisp
===================================================================
--- /branches/working-0711/ccl/level-1/l1-streams.lisp	(revision 12969)
+++ /branches/working-0711/ccl/level-1/l1-streams.lisp	(revision 12970)
@@ -4233,5 +4233,6 @@
 
 (defstruct (string-output-stream-ioblock (:include string-stream-ioblock))
-  (index 0))
+  (index 0)
+  freelist)
 
 (defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream))
@@ -4254,9 +4255,23 @@
 ;;; *string-output-stream-class* 
 (defun %close-string-output-stream (stream ioblock)
-  (when (eq (basic-stream.wrapper stream)
-            *string-output-stream-class-wrapper*)
+  (let* ((pool %string-output-stream-ioblocks%))
+    (when (and pool
+               (eq (basic-stream.wrapper stream)
+                   *string-output-stream-class-wrapper*)
+               (eq (string-output-stream-ioblock-freelist ioblock) pool))
     (without-interrupts
-     (setf (ioblock-stream ioblock) (pool.data %string-output-stream-ioblocks%)
-           (pool.data %string-output-stream-ioblocks%) ioblock))))
+     (setf (ioblock-stream ioblock) (pool.data pool)
+           (pool.data pool) ioblock)))))
+
+;;; If this is the sort of string stream whose ioblock we recycle and
+;;; there's a thread-local binding of the variable we use for a freelist,
+;;; return the value of that binding.
+(defun %string-stream-ioblock-freelist (stream)
+  (and stream
+       (eq (basic-stream.wrapper stream)
+           *string-output-stream-class-wrapper*)
+       (let* ((loc (%tcr-binding-location (%current-tcr) '%string-output-stream-ioblocks%)))
+         (and loc (%fixnum-ref loc)))))
+
 
 (defun create-string-output-stream-ioblock (&rest keys &key stream &allow-other-keys)
@@ -4290,4 +4305,5 @@
                      :write-simple-string-function write-string-function
                      :force-output-function #'false
+                     :freelist (%string-stream-ioblock-freelist stream)
                      :close-function #'%close-string-output-stream)))
       (setf (basic-stream.state stream) ioblock)