1.0.8.16: refactored fd-stream buffering

Thanks to David Smith and Andreas Bogkt who diagnosed the memory
 leaks this patch fixes.

 * Instead of having FD-STREAM objects directly hold onto input and
   output buffer SAPs and head/tail indexes, use BUFFER objects which
   contain the SAP, size of the memory area, head/tail indexes, and
   are have finalizers to deallocate the system memory assosicated
   with the SAP. (This fixes system memory leaks when streams are not
   properly closed.)

 * Make CLOSE :ABORT release the output queue associated with the
   stream. (This was another memory leak in the old system: now
   the finalizers make not doing this safe, but it's still better
   to recycle the buffers.)

 * Slightly reduce lock contention by grabbing the *AVAILABLE-BUFFERS*
   lock only if there is something there right before the lock is
   taken, and by doing allocation outside the lock.

 * Rename and refactor FROB-OUTPUT and friends:

     BUFFER-OUTPUT is the main interface function, which always
       adds new output to the current buffer / output queue.

     WRITE-OR-BUFFER-OUTPUT tries to write immediately, falling
       back to buffering if writing is not possible.

     WRITE-OUTPUT-FROM-QUEUE is called by the SERVE-EVENT
       system to deal with output queue.

     FLUSH-OUTPUT-BUFFER writes the current buffer out if possible,
       queues it otherwise. Ensures that the output buffer of
       the stream is empty on return (and returns that buffer).

 * Deprecate SB-SYS:OUTPUT-RAW-BYTES. There doesn't seem to be any
   real reason to export this kind of stuff.

 * Increment the fasl version.

NEWS

@@ -1,9 +1,15 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-1.0.9 relative to sbcl-1.0.8:
+  * minor incompatible change: SB-SYS:OUTPUT-RAW-BYTES is deprecated.
   * bug fix: new compiler transforms for MEMBER and ASSOC were affected
     by printer control variables. (reported by Dan Corkill)
   * bug fix: system leaked memory when delayed output was performed by
     the OS in smaller chunks then expected. (thanks to David Smith)
+  * bug fix: system leaked memory when file streams were not closed 
+    properly.
+  * bug fix: large objects written to slow streams that were modified
+    after the write could end up with the modified state written to
+    the underlying file descriptor.
 
 changes in sbcl-1.0.8 relative to sbcl-1.0.7:
   * enhancement: experimental macro SB-EXT:COMPARE-AND-SWAP provides

contrib/sb-simple-streams/internal.lisp

@@ -44,22 +44,19 @@
 (defun buffer-copy (src soff dst doff length)
   (declare (type simple-stream-buffer src dst)
            (type fixnum soff doff length))
-  (sb-sys:without-gcing ;; is this necessary??
+  ;; FIXME: Should probably be with-pinned-objects
+  (sb-sys:without-gcing
    (sb-kernel:system-area-ub8-copy (buffer-sap src) soff
                                    (buffer-sap dst) doff
                                    length)))
 
 (defun allocate-buffer (size)
-  (if (= size sb-impl::bytes-per-buffer)
-      (sb-impl::next-available-buffer)
-      (make-array size :element-type '(unsigned-byte 8))))
+  (make-array size :element-type '(unsigned-byte 8)))
 
 (defun free-buffer (buffer)
-  (when (sb-sys:system-area-pointer-p buffer)
-    (push buffer sb-impl::*available-buffers*))
+  (sb-int:aver (typep buffer '(simple-array (unsigned-byte 8) (*))))
   t)
 
-
 (defun make-control-table (&rest inits)
   (let ((table (make-array 32 :initial-element nil)))
     (do* ((char (pop inits) (pop inits))

contrib/sb-simple-streams/terminal.lisp

@@ -53,9 +53,9 @@
 
 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
   (unless buffer-only
-    (let ((buffer (allocate-buffer sb-impl::bytes-per-buffer)))
+    (let ((buffer (allocate-buffer sb-impl::+bytes-per-buffer+)))
       (unwind-protect
            (loop until (<= (read-octets stream buffer
-                                        0 sb-impl::bytes-per-buffer nil)
+                                        0 sb-impl::+bytes-per-buffer+ nil)
                            0))
         (free-buffer buffer)))))

src/code/stream.lisp

@@ -2058,7 +2058,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
                     (funcall write-function stream (aref data i))))))
            (if (and (fd-stream-p stream)
                     (compatible-vector-and-stream-element-types-p data stream))
-               (output-raw-bytes stream data offset-start offset-end)
+               (buffer-output stream data offset-start offset-end)
                (output-seq-in-loop)))))))
   seq)
 

src/code/thread.lisp

@@ -91,6 +91,15 @@ provided the default value is used for the mutex."
         (without-interrupts
           (allow-with-interrupts (funcall function)))))
 
+  (defun call-with-system-spinlock (function spinlock &optional without-gcing-p)
+    (declare (ignore spinlock)
+             (function function))
+    (if without-gcing-p
+        (without-gcing
+          (funcall function))
+        (without-interrupts
+          (allow-with-interrupts (funcall function)))))
+
   (defun call-with-recursive-system-spinlock (function lock
                                               &optional without-gcing-p)
     (declare (ignore lock)
@@ -138,6 +147,21 @@ provided the default value is used for the mutex."
           (without-interrupts
             (allow-with-interrupts (%call-with-system-mutex))))))
 
+  (defun call-with-system-spinlock (function spinlock &optional without-gcing-p)
+    (declare (function function))
+    (flet ((%call-with-system-spinlock ()
+             (dx-let (got-it)
+               (unwind-protect
+                    (when (setf got-it (get-spinlock spinlock))
+                      (funcall function))
+                 (when got-it
+                   (release-spinlock spinlock))))))
+      (if without-gcing-p
+          (without-gcing
+            (%call-with-system-spinlock))
+          (without-interrupts
+            (allow-with-interrupts (%call-with-system-spinlock))))))
+
   (defun call-with-recursive-system-spinlock (function lock
                                               &optional without-gcing-p)
     (declare (function function))

src/compiler/target-dump.lisp

@@ -33,7 +33,8 @@
 ;;; vector-like thing that we can BLT from.
 (defun dump-raw-bytes (vec n fasl-output)
   (declare (type index n) (type fasl-output fasl-output))
-  (sb!sys:output-raw-bytes (fasl-output-stream fasl-output) vec 0 n)
+  ;; FIXME: Why not WRITE-SEQUENCE?
+  (sb!impl::buffer-output (fasl-output-stream fasl-output) vec 0 n)
   (values))
 
 ;;; Dump a multi-dimensional array. Note: any displacements are folded out.

tests/external-format.impure.lisp

@@ -35,7 +35,9 @@
     (with-open-file (s "external-format-test.txt" :direction :input
                      :external-format xf)
       (loop for character across standard-characters
-            do (assert (eql (read-char s) character))))))
+            do (let ((got (read-char s)))
+                 (unless (eql character got)
+                   (error "wanted ~S, got ~S" character got)))))))
 
 (delete-file "external-format-test.txt")
 #-sb-unicode
@@ -53,14 +55,16 @@
                        :if-exists :supersede :external-format :utf-8)
         (dotimes (n offset)
           (write-char #\a s))
-        (dotimes (n 4097)
+        (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
           (write-char character s)))
       (with-open-file (s "external-format-test.txt" :direction :input
                        :external-format :utf-8)
         (dotimes (n offset)
           (assert (eql (read-char s) #\a)))
-        (dotimes (n 4097)
-          (assert (eql (read-char s) character)))
+        (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
+          (let ((got (read-char s)))
+            (unless (eql got character)
+              (error "wanted ~S, got ~S (~S)" character got n))))
         (assert (eql (read-char s nil s) s))))))
 
 ;;; Test character decode restarts.

tests/stream.impure.lisp

@@ -91,7 +91,10 @@
     (with-standard-io-syntax
       (prin1 'insert s)))
   (with-open-file (s p)
-    (assert (string= (read-line s) "THESE INSERTMBOLS")))
+    (let ((line (read-line s))
+          (want "THESE INSERTMBOLS"))
+      (unless (equal line want)
+        (error "wanted ~S, got ~S" want line))))
   (delete-file p))
 
 ;;; :DIRECTION :IO didn't work on non-existent pathnames

tests/stream.pure.lisp

@@ -307,7 +307,7 @@
 ;;; improperly.
 ;;;
 ;;; This test assumes that buffering is still done until a buffer of
-;;; SB-IMPL::BYTES-PER-BUFFER bytes is filled up, that the buffer may
+;;; SB-IMPL::+BYTES-PER-BUFFER+ bytes is filled up, that the buffer may
 ;;; immediately be completely filled for normal files, and that the
 ;;; buffer-fill routine is responsible for figuring out when we've
 ;;; reached EOF.
@@ -316,8 +316,8 @@
         ;; If non-NIL, size (in bytes) of the file that will exercise
         ;; the LISTEN problem.
         (bytes-per-buffer-sometime
-         (and (boundp 'sb-impl::bytes-per-buffer)
-              (symbol-value 'sb-impl::bytes-per-buffer))))
+         (and (boundp 'sb-impl::+bytes-per-buffer+)
+              (symbol-value 'sb-impl::+bytes-per-buffer+))))
     (when bytes-per-buffer-sometime
       (unwind-protect
            (progn

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".)
-"1.0.8.15"
+"1.0.8.16"