Changeset 12842

Timestamp:

Sep 16, 2009, 8:17:59 AM (15 years ago)

Author:

Gary Byers

Message:

Add a slot to STRING-OUTPUT-STREAM-IOBLOCK; use it to try to ensure
that the thread-specific freelisting of these structures works safely.

File:

• trunk/source/level-1/l1-streams.lisp (modified) (3 diffs)

trunk/source/level-1/l1-streams.lisp

@@ -4233 +4233 @@
 
 (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 +4255 @@
 ;;; *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 +4305 @@
                      :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)