1.0.8.19: :dont-safe finalizers and fd-stream thread safety issues
authorNikodemus Siivola <nikodemus@random-state.net>
Thu, 9 Aug 2007 16:52:03 +0000 (16:52 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Thu, 9 Aug 2007 16:52:03 +0000 (16:52 +0000)
 * Add :DONT-SAVE keyword argument to FINALIZE, which causes the finalizer
   to be removed when core is saved: it is not amusing to have a finalizer
   that deallocates system memory to fire in a fresh image which happens
   to have freshly allocated memory in the same address. Also good for finalizers
   closing FDs.

   Use where appropiate.

 * Stream buffing should not use (INCF (BUFFER-FOO BUFFER) N), since if another
   thread has written to the buffer since we last looked at it this might take
   eg. the TAIL index beyond the end of the allocated memory area: by doing
   (let ((foo (buffer-foo buffer))) ... (setf (buffer-foo buffer) (+ foo n)) we might
   overwrite the data from another thread, but at least we won't trash memory.

 * Small graces: check that ALLOCATE-SYSTEM-MEMORY actually succeeds, don't accept
   finalizers for NIL (they would just run immediately on next GC, which is almost
   certainly not intended), take an extra mile to ensure old buffers from before
   SAVE-LISP-AND-DIE don't survive to the new image.

NEWS
src/code/cold-init.lisp
src/code/fd-stream.lisp
src/code/final.lisp
src/code/save.lisp
src/code/target-alieneval.lisp
src/runtime/gencgc.c
version.lisp-expr

diff --git a/NEWS b/NEWS
index c8e12de..163c373 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,9 @@
 ;;;; -*- 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.
+  * enhancement: SB-EXT:FINALIZE accepts a :DONT-SAVE keyword argument,
+    indicating the finalizer should be cancelled when SAVE-LISP-AND-DIE
+    is called.
   * 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
@@ -10,6 +13,8 @@ changes in sbcl-1.0.9 relative to sbcl-1.0.8:
   * 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.
+  * bug fix: multiple threads operating in parallel on the same stream
+    could cause buffer-overflows.
 
 changes in sbcl-1.0.8 relative to sbcl-1.0.7:
   * enhancement: experimental macro SB-EXT:COMPARE-AND-SWAP provides
index c9b734a..dd51ecf 100644 (file)
@@ -294,7 +294,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code."
   (without-gcing
     (os-cold-init-or-reinit)
     (thread-init-or-reinit)
-    (stream-reinit)
+    (stream-reinit t)
     #!-win32
     (signal-cold-init-or-reinit)
     (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
index 374d10b..b327e07 100644 (file)
 ;;;; Streams hold BUFFER objects, which contain a SAP, size of the
 ;;;; memory area the SAP stands for (LENGTH bytes), and HEAD and TAIL
 ;;;; indexes which delimit the "valid", or "active" area of the
-;;;; memory.
+;;;; memory. HEAD is inclusive, TAIL is exclusive.
 ;;;;
 ;;;; Buffers get allocated lazily, and are recycled by returning them
 ;;;; to the *AVAILABLE-BUFFERS* list. Every buffer has it's own
 ;;;; finalizer, to take care of releasing the SAP memory when a stream
 ;;;; is not properly closed.
+;;;;
+;;;; The code aims to provide a limited form of thread and interrupt
+;;;; safety: parallel writes and reads may lose output or input, cause
+;;;; interleaved IO, etc -- but they should not corrupt memory. The
+;;;; key to doing this is to read buffer state once, and update the
+;;;; state based on the read state:
+;;;;
+;;;; (let ((tail (buffer-tail buffer)))
+;;;;   ...
+;;;;   (setf (buffer-tail buffer) (+ tail n)))
+;;;;
+;;;; NOT
+;;;;
+;;;; (let ((tail (buffer-tail buffer)))
+;;;;   ...
+;;;;  (incf (buffer-tail buffer) n))
+;;;;
 
 (declaim (inline buffer-sap buffer-length buffer-head buffer-tail
                  (setf buffer-head) (setf buffer-tail)))
   (without-interrupts
     (let* ((sap (allocate-system-memory size))
            (buffer (%make-buffer sap size)))
+      (when (zerop (sap-int sap))
+        (error "Could not allocate ~D bytes for buffer." size))
       (finalize buffer (lambda ()
-                         (deallocate-system-memory sap size)))
+                         (deallocate-system-memory sap size))
+                :dont-save t)
       buffer)))
 
 (defun get-buffer ()
     (error ":END before :START!"))
   (when (> end start)
     ;; Copy bytes from THING to buffers.
-    (flet ((copy-to-buffer (buffer offset count)
-             (declare (buffer buffer) (index offset count))
+    (flet ((copy-to-buffer (buffer tail count)
+             (declare (buffer buffer) (index tail count))
              (aver (plusp count))
              (let ((sap (buffer-sap buffer)))
                (etypecase thing
                  (system-area-pointer
-                  (system-area-ub8-copy thing start sap offset count))
+                  (system-area-ub8-copy thing start sap tail count))
                  ((simple-unboxed-array (*))
-                  (copy-ub8-to-system-area thing start sap offset count))))
-             (incf (buffer-tail buffer) count)
+                  (copy-ub8-to-system-area thing start sap tail count))))
+             ;; Not INCF! If another thread has moved tail from under
+             ;; us, we don't want to accidentally increment tail
+             ;; beyond buffer-length.
+             (setf (buffer-tail buffer) (+ count tail))
              (incf start count)))
       (tagbody
          ;; First copy is special: the buffer may already contain
              (copy-to-buffer obuf tail (min space (- end start)))
              (go :more-output-p)))
        :flush-and-fill
-         ;; Later copies always have an empty buffer, since they are freshly
-         ;; flushed.
+         ;; Later copies should always have an empty buffer, since
+         ;; they are freshly flushed, but if another thread is
+         ;; stomping on the same buffer that might not be the case.
          (let* ((obuf (flush-output-buffer stream))
-                (offset (buffer-tail obuf)))
-           (aver (zerop offset))
-           (copy-to-buffer obuf offset (min (buffer-length obuf) (- end start))))
+                (tail (buffer-tail obuf))
+                (space (- (buffer-length obuf) tail)))
+           (copy-to-buffer obuf tail (min space (- end start))))
        :more-output-p
          (when (> end start)
            (go :flush-and-fill))))))
                (synchronize-stream-output stream)
                (let ((length (- tail head)))
                  (multiple-value-bind (count errno)
-                     (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf) head length)
+                     (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
+                                         head length)
                    (cond ((eql count length)
                           ;; Complete write -- we can use the same buffer.
                           (reset-buffer obuf))
                          (count
                           ;; Partial write -- update buffer status and queue.
-                          (incf (buffer-head obuf) count)
+                          ;; Do not use INCF! Another thread might have moved
+                          ;; head...
+                          (setf (buffer-head obuf) (+ count head))
                           (%queue-and-replace-output-buffer stream))
                          #!-win32
                          ((eql errno sb!unix:ewouldblock)
                           ;; Blocking, queue.
                           (%queue-and-replace-output-buffer stream))
                          (t
-                          (simple-stream-perror "Couldn't write to ~s" stream errno)))))))))))
+                          (simple-stream-perror "Couldn't write to ~s"
+                                                stream errno)))))))))))
 
 ;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer.
 (defun %queue-and-replace-output-buffer (stream)
               (head (buffer-head buffer))
               (length (- (buffer-tail buffer) head)))
          (declare (index head length))
+         (aver (>= length 0))
          (multiple-value-bind (count errno)
-            (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer) head length)
+             (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer)
+                                 head length)
            (cond ((eql count length)
                   ;; Complete write, see if we can do another right
                   ;; away, or remove the handler if we're done.
                  (count
                   ;; Partial write. Update buffer status and requeue.
                   (aver (< count length))
-                  (incf (buffer-head buffer) (or count 0))
+                  ;; Do not use INCF! Another thread might have moved head.
+                  (setf (buffer-head buffer) (+ head count))
                   (push buffer (fd-stream-output-queue stream)))
                  (not-first-p
                   ;; We tried to do multiple writes, and finally our
                   (simple-stream-perror "Couldn't write to ~S." stream errno)
                   #!-win32
                   (if (= errno sb!unix:ewouldblock)
-                      (bug "Unexpected blocking write in WRITE-OUTPUT-FROM-QUEUE.")
-                      (simple-stream-perror "Couldn't write to ~S" stream errno))))))))
+                      (bug "Unexpected blocking in WRITE-OUTPUT-FROM-QUEUE.")
+                      (simple-stream-perror "Couldn't write to ~S"
+                                            stream errno))))))))
   nil)
 
 ;;; Try to write THING directly to STREAM without buffering, if
 (defun fd-stream-output-finished-p (stream)
   (let ((obuf (fd-stream-obuf stream)))
     (or (not obuf)
-        (and (zerop (buffer-tail obuf)))
-        (not (fd-stream-output-queue stream)))))
+        (and (zerop (buffer-tail obuf))
+             (not (fd-stream-output-queue stream))))))
 
 (defmacro output-wrapper/variable-width ((stream size buffering restart)
                                          &body body)
   (let ((stream-var (gensym "STREAM")))
     `(let* ((,stream-var ,stream)
             (obuf (fd-stream-obuf ,stream-var))
+            (tail (buffer-tail obuf))
             (size ,size))
       ,(unless (eq (car buffering) :none)
-         `(when (< (buffer-length obuf)
-                   (+ (buffer-tail obuf) size))
-            (setf obuf (flush-output-buffer ,stream-var))))
+         `(when (<= (buffer-length obuf) (+ tail size))
+            (setf obuf (flush-output-buffer ,stream-var)
+                  tail (buffer-tail obuf))))
       ,(unless (eq (car buffering) :none)
          ;; FIXME: Why this here? Doesn't seem necessary.
          `(synchronize-stream-output ,stream-var))
       ,(if restart
            `(catch 'output-nothing
               ,@body
-              (incf (buffer-tail obuf) size))
+              (setf (buffer-tail obuf) (+ tail size)))
            `(progn
              ,@body
-             (incf (buffer-tail obuf) size)))
+             (setf (buffer-tail obuf) (+ tail size))))
       ,(ecase (car buffering)
          (:none
           `(flush-output-buffer ,stream-var))
 (defmacro output-wrapper ((stream size buffering restart) &body body)
   (let ((stream-var (gensym "STREAM")))
     `(let* ((,stream-var ,stream)
-            (obuf (fd-stream-obuf ,stream-var)))
+            (obuf (fd-stream-obuf ,stream-var))
+            (tail (buffer-tail obuf)))
       ,(unless (eq (car buffering) :none)
-         `(when (< (buffer-length obuf)
-                   (+ (buffer-tail obuf) ,size))
-            (setf obuf (flush-output-buffer ,stream-var))))
+         `(when (<= (buffer-length obuf) (+ tail ,size))
+            (setf obuf (flush-output-buffer ,stream-var)
+                  tail (buffer-tail obuf))))
       ;; FIXME: Why this here? Doesn't seem necessary.
       ,(unless (eq (car buffering) :none)
          `(synchronize-stream-output ,stream-var))
       ,(if restart
            `(catch 'output-nothing
               ,@body
-              (incf (buffer-tail obuf) ,size))
+              (setf (buffer-tail obuf) (+ tail ,size)))
            `(progn
              ,@body
-             (incf (buffer-tail obuf) ,size)))
+             (setf (buffer-tail obuf) (+ tail ,size))))
       ,(ecase (car buffering)
          (:none
           `(flush-output-buffer ,stream-var))
   (if (eql byte #\Newline)
       (setf (fd-stream-char-pos stream) 0)
       (incf (fd-stream-char-pos stream)))
-  (setf (sap-ref-8 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (sap-ref-8 (buffer-sap obuf) tail)
         (char-code byte)))
 
 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
                       nil
                       (:none (unsigned-byte 8))
                       (:full (unsigned-byte 8)))
-  (setf (sap-ref-8 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (sap-ref-8 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
                       nil
                       (:none (signed-byte 8))
                       (:full (signed-byte 8)))
-  (setf (signed-sap-ref-8 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (signed-sap-ref-8 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
                       nil
                       (:none (unsigned-byte 16))
                       (:full (unsigned-byte 16)))
-  (setf (sap-ref-16 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (sap-ref-16 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
                       nil
                       (:none (signed-byte 16))
                       (:full (signed-byte 16)))
-  (setf (signed-sap-ref-16 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (signed-sap-ref-16 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
                       nil
                       (:none (unsigned-byte 32))
                       (:full (unsigned-byte 32)))
-  (setf (sap-ref-32 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (sap-ref-32 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
                       nil
                       (:none (signed-byte 32))
                       (:full (signed-byte 32)))
-  (setf (signed-sap-ref-32 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (signed-sap-ref-32 (buffer-sap obuf) tail)
         byte))
 
 #+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
                         nil
                         (:none (unsigned-byte 64))
                         (:full (unsigned-byte 64)))
-    (setf (sap-ref-64 (buffer-sap obuf) (buffer-tail obuf))
+    (setf (sap-ref-64 (buffer-sap obuf) tail)
           byte))
   (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED"
                         8
                         nil
                         (:none (signed-byte 64))
                         (:full (signed-byte 64)))
-    (setf (signed-sap-ref-64 (buffer-sap obuf) (buffer-tail obuf))
+    (setf (signed-sap-ref-64 (buffer-sap obuf) tail)
           byte)))
 
 ;;; the routine to use to output a string. If the stream is
                    (output-wrapper (stream (/ i 8) (:none) nil)
                      (loop for j from 0 below (/ i 8)
                            do (setf (sap-ref-8 (buffer-sap obuf)
-                                               (+ j (buffer-tail obuf)))
+                                               (+ j tail))
                                     (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                 (:full
                  (lambda (stream byte)
                    (output-wrapper (stream (/ i 8) (:full) nil)
                      (loop for j from 0 below (/ i 8)
                            do (setf (sap-ref-8 (buffer-sap obuf)
-                                               (+ j (buffer-tail obuf)))
+                                               (+ j tail))
                                     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
               `(unsigned-byte ,i)
               (/ i 8))))
                    (output-wrapper (stream (/ i 8) (:none) nil)
                      (loop for j from 0 below (/ i 8)
                            do (setf (sap-ref-8 (buffer-sap obuf)
-                                               (+ j (buffer-tail obuf)))
+                                               (+ j tail))
                                     (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                 (:full
                  (lambda (stream byte)
                    (output-wrapper (stream (/ i 8) (:full) nil)
                      (loop for j from 0 below (/ i 8)
                            do (setf (sap-ref-8 (buffer-sap obuf)
-                                               (+ j (buffer-tail obuf)))
+                                               (+ j tail))
                                     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
               `(signed-byte ,i)
               (/ i 8)))))
                             (buffer-head ibuf) head
                             tail n
                             (buffer-tail ibuf) tail)))))
-
            (setf (fd-stream-listen stream) nil)
            (setf (values count errno)
                  (sb!unix:unix-read fd (sap+ sap tail) (- length tail)))
                   (/show0 "THROWing EOF-INPUT-CATCHER")
                   (throw 'eof-input-catcher nil))
                  (t
-                  ;; Success!
-                  (incf (buffer-tail ibuf) count))))))
+                  ;; Success! (Do not use INCF, for sake of other threads.)
+                  (setf (buffer-tail ibuf) (+ count tail)))))))
     count))
 
 ;;; Make sure there are at least BYTES number of bytes in the input
                   (sb!unix:unix-close fd)
                   #!+sb-show
                   (format *terminal-io* "** closed file descriptor ~W **~%"
-                          fd))))
+                          fd))
+                :dont-save t))
     stream))
 
 ;;; Pick a name to use for the backup file for the :IF-EXISTS
   (setf *trace-output* *standard-output*)
   (values))
 
+(defun stream-deinit ()
+  ;; Unbind to make sure we're not accidently dealing with it
+  ;; before we're ready (or after we think it's been deinitialized).
+  (with-available-buffers-lock ()
+    (without-package-locks
+        (makunbound '*available-buffers*))))
+
 ;;; This is called whenever a saved core is restarted.
-(defun stream-reinit ()
-  (setf *available-buffers* nil)
+(defun stream-reinit (&optional init-buffers-p)
+  (when init-buffers-p
+    (with-available-buffers-lock ()
+      (aver (not (boundp '*available-buffers*)))
+      (setf *available-buffers* nil)))
   (with-output-to-string (*error-output*)
     (setf *stdin*
           (make-fd-stream 0 :name "standard input" :input t :buffering :line
index d6619ed..c2ef070 100644 (file)
                                       *finalizer-store-lock*
                                       t))
 
-(defun finalize (object function)
+(defun finalize (object function &key dont-save)
   #!+sb-doc
   "Arrange for the designated FUNCTION to be called when there
 are no more references to OBJECT, including references in
 FUNCTION itself.
 
+If DONT-SAVE is true, the finalizer will be cancelled when
+SAVE-LISP-AND-DIE is called: this is useful for finalizers
+deallocating system memory, which might otherwise be called
+with addresses from the old image.
+
 In a multithreaded environment FUNCTION may be called in any
 thread. In both single and multithreaded environments FUNCTION
 may be called in any dynamic scope: consequences are unspecified
@@ -62,11 +67,19 @@ Examples:
     (finalize \"oops\" #'oops)
     (oops)) ; causes GC and re-entry to #'oops due to the finalizer
             ; -> ERROR, caught, WARNING signalled"
+  (unless object
+    (error "Cannot finalize NIL."))
   (with-finalizer-store-lock
-      (push (cons (make-weak-pointer object) function)
-            *finalizer-store*))
+    (push (list (make-weak-pointer object) function dont-save)
+          *finalizer-store*))
   object)
 
+(defun deinit-finalizers ()
+  ;; remove :dont-save finalizers
+  (with-finalizer-store-lock
+    (setf *finalizer-store* (delete-if #'third *finalizer-store*)))
+  nil)
+
 (defun cancel-finalization (object)
   #!+sb-doc
   "Cancel any finalization for OBJECT."
@@ -76,18 +89,18 @@ Examples:
     (with-finalizer-store-lock
         (setf *finalizer-store*
               (delete object *finalizer-store*
-                      :key (lambda (pair)
-                             (weak-pointer-value (car pair))))))
+                      :key (lambda (list)
+                             (weak-pointer-value (car list))))))
     object))
 
 (defun run-pending-finalizers ()
   (let (pending)
     (with-finalizer-store-lock
         (setf *finalizer-store*
-              (delete-if  (lambda (pair)
-                            (when (null (weak-pointer-value (car pair)))
-                              (push (cdr pair) pending)
-                              t))
+              (delete-if (lambda (list)
+                           (when (null (weak-pointer-value (car list)))
+                             (push (second list) pending)
+                             t))
                           *finalizer-store*)))
     ;; We want to run the finalizer bodies outside the lock in case
     ;; finalization of X causes finalization to be added for Y.
index 4aa940a..bb0bcc5 100644 (file)
@@ -152,10 +152,9 @@ sufficiently motivated to do lengthy fixes."
       (funcall hook)))
   (when (rest (sb!thread:list-all-threads))
     (error "Cannot save core with multiple threads running."))
-  #!-win32
-  (when (fboundp 'cancel-finalization)
-    (cancel-finalization sb!sys:*tty*))
   (float-deinit)
   (profile-deinit)
   (debug-deinit)
-  (foreign-deinit))
+  (foreign-deinit)
+  (stream-deinit)
+  (deinit-finalizers))
index 37600b6..1f34143 100644 (file)
@@ -446,7 +446,8 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
      (lambda ()
        (alien-funcall
         (extern-alien "free" (function (values) system-area-pointer))
-        alien-sap)))
+        alien-sap))
+     :dont-save t)
     alien))
 
 (defun note-local-alien-type (info alien)
index 3161230..7091554 100644 (file)
@@ -4682,7 +4682,7 @@ alloc(long nbytes)
  * catch GENCGC-related write-protect violations
  */
 
-void unhandled_sigmemoryfault(void);
+void unhandled_sigmemoryfault(void* addr);
 
 /* Depending on which OS we're running under, different signals might
  * be raised for a violation of write protection in the heap. This
@@ -4709,7 +4709,7 @@ gencgc_handle_wp_violation(void* fault_addr)
 
         /* It can be helpful to be able to put a breakpoint on this
          * case to help diagnose low-level problems. */
-        unhandled_sigmemoryfault();
+        unhandled_sigmemoryfault(fault_addr);
 
         /* not within the dynamic space -- not our responsibility */
         return 0;
@@ -4740,7 +4740,7 @@ gencgc_handle_wp_violation(void* fault_addr)
  * are about to let Lisp deal with it. It's basically just a
  * convenient place to set a gdb breakpoint. */
 void
-unhandled_sigmemoryfault()
+unhandled_sigmemoryfault(void *addr)
 {}
 
 void gc_alloc_update_all_page_tables(void)
index e63ab44..1b0ee49 100644 (file)
@@ -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.18"
+"1.0.8.19"