* last vestiges of before GC hooks have been removed.
* after GC hooks are now left for user-code.
* call UNSAFE-CLEAR-ROOTS before GC proper as the moral replacement
of old before GC hooks for internal use only: on unithread SBCL
scrub the stack and clear ctype-of cache, on threaded just scrub the
stack.
* finalizers and after GC hooks moved outside the GC proper, with
interrupts enabled and all threads[1] running; it is now safe to
allocate in them as re-entry to GC is possible.
* put a lock on the global finalizers list, as per Gabor Mellis'
patch. Gratuitiously change the name of the selfsame global variable
to flush out anyone diddling with it.
* tighten the finalizer spec with a note that they may run in any
thread.
* add a stress-test for finalizers.
[1. Not actually tested on threaded SBCL.]
* incompatible change: the --noprogrammer option, deprecated since
version 0.7.5, has been removed. Please use the equivalent
--disable-debugger option instead.
+ * incompatible change: finalizers and *AFTER-GC-HOOKS* are now run with
+ interrupts enabled.
+ * incompatible change: support for *BEFORE-GC-HOOKS* (that have been
+ inoperational for a while now) has been completely removed.
* Null lexical environments are now printed as #<NULL-LEXENV>,
significantly reducing the amount of clutter in typical backtraces.
* optimization: REPLACE on declared (UNSIGNED-BYTE 8) vectors, as well
as other specialized array types, is much faster. SUBSEQ and
COPY-SEQ on such arrays have also been sped up.
+ * fixed bug: finalizers are now thread-safe. (thanks to Gabor Mellis)
+ * fixed bug: finalizers and after GC hooks that cause consing are now
+ safe.
* fixed bug: compiler error messages and summaries are now printed to
*ERROR-OUTPUT*, not *STANDARD-OUTPUT*.
* fixed inference of the upper bound of an iteration variable.
"POSIX-GETENV" "POSIX-ENVIRON"
;; People have various good reasons to mess with the GC.
- "*AFTER-GC-HOOKS*" "*BEFORE-GC-HOOKS*"
+ "*AFTER-GC-HOOKS*"
"*GC-NOTIFY-AFTER*" "*GC-NOTIFY-BEFORE*" "*GC-NOTIFY-STREAM*"
"BYTES-CONSED-BETWEEN-GCS"
"GC" "GC-OFF" "GC-ON" "GET-BYTES-CONSED"
#!+(or x86 x86-64) "*PSEUDO-ATOMIC-INTERRUPTED*"
"PUNT-PRINT-IF-TOO-LONG" "READER-IMPOSSIBLE-NUMBER-ERROR"
"READER-PACKAGE-ERROR" "READER-EOF-ERROR"
- "RESTART-DESIGNATOR" "SCALE-DOUBLE-FLOAT"
+ "RESTART-DESIGNATOR"
+ "RUN-PENDING-FINALIZERS"
+ "SCALE-DOUBLE-FLOAT"
#!+long-float "SCALE-LONG-FLOAT"
"SCALE-SINGLE-FLOAT" "SEQUENCE-COUNT" "SEQUENCE-END"
"SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE"
;; !UNIX-COLD-INIT. And *TYPE-SYSTEM-INITIALIZED* could be changed to
;; *TYPE-SYSTEM-INITIALIZED-WHEN-BOUND* so that it doesn't need to
;; be explicitly set in order to be meaningful.
- (setf *before-gc-hooks* nil
- *after-gc-hooks* nil
+ (setf *after-gc-hooks* nil
*gc-inhibit* 1
*need-to-collect-garbage* nil
sb!unix::*interrupts-enabled* t
(defmacro without-interrupts (&rest forms)
`(progn ,@forms))
-;;; When we're running as a cross-compiler in an arbitrary host ANSI
-;;; Lisp, we shouldn't be doing anything which is sensitive to GC.
-;;; KLUDGE: I (WHN 19990131) think the proper long-term solution would
-;;; be to remove any operations from cross-compiler source files
-;;; (putting them in target-only source files) if they refer to these
-;;; hooks. This is a short-term hack.
-(defvar *before-gc-hooks* nil)
-(defvar *after-gc-hooks* nil)
-
;;; The GENESIS function works with fasl code which would, in the
;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended
;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a
(in-package "SB!IMPL")
-(defvar *objects-pending-finalization* nil)
+(defvar *finalizer-store* nil)
+
+(defvar *finalizer-store-lock*
+ (sb!thread:make-mutex :name "Finalizer store lock."))
(defun finalize (object function)
- (declare (type function function))
- #!+sb-doc
- "Arrange for FUNCTION to be called when there are no more references to
- OBJECT."
- (declare (type function function))
- (sb!sys:without-gcing
- (push (cons (make-weak-pointer object) function)
- *objects-pending-finalization*))
+ #!+sb-doc
+ "Arrange for the designated FUNCTION to be called when there
+are no more references to OBJECT. In a multithreaded environment
+the finalizer may run in any thread."
+ (sb!thread:with-mutex (*finalizer-store-lock*)
+ (push (cons (make-weak-pointer object) function)
+ *finalizer-store*))
object)
(defun cancel-finalization (object)
#!+sb-doc
- "Cancel any finalization registers for OBJECT."
+ "Cancel any finalization for OBJECT."
+ ;; Check for NIL to avoid deleting finalizers that are waiting to be
+ ;; run.
(when object
- ;; We check to make sure object isn't nil because if there are any
- ;; broken weak pointers, their value will show up as nil. Therefore,
- ;; they would be deleted from the list, but not finalized. Broken
- ;; weak pointers shouldn't be left in the list, but why take chances?
- (sb!sys:without-gcing
- (setf *objects-pending-finalization*
- (delete object *objects-pending-finalization*
- :key (lambda (pair)
- (values (weak-pointer-value (car pair))))))))
- nil)
+ (sb!thread:with-mutex (*finalizer-store-lock*)
+ (setf *finalizer-store*
+ (delete object *finalizer-store*
+ :key (lambda (pair)
+ (weak-pointer-value (car pair))))))
+ object))
-(defun finalize-corpses ()
- (setf *objects-pending-finalization*
- (delete-if (lambda (pair)
- (multiple-value-bind (object valid)
- (weak-pointer-value (car pair))
- (declare (ignore object))
- (unless valid
- (funcall (the function (cdr pair)))
- t)))
- *objects-pending-finalization*))
+(defun run-pending-finalizers ()
+ (let (pending)
+ (sb!thread:with-mutex (*finalizer-store-lock*)
+ (setf *finalizer-store*
+ (delete-if (lambda (pair)
+ (when (null (weak-pointer-value (car pair)))
+ (push (cdr pair) 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.
+ (dolist (fun pending)
+ (handler-case
+ (funcall fun)
+ (error (c)
+ (warn "Error calling finalizer ~S:~% ~S" fun c)))))
nil)
-
-(pushnew 'finalize-corpses *after-gc-hooks*)
\f
;;;; GC hooks
-(defvar *before-gc-hooks* nil ; actually initialized in cold init
- #!+sb-doc
- "A list of functions that are called before garbage collection occurs.
- The functions are run with interrupts disabled and all other threads
- paused. They should take no arguments.")
-
-(defvar *after-gc-hooks* nil ; actually initialized in cold init
- #!+sb-doc
- "A list of functions that are called after garbage collection occurs.
- The functions are run with interrupts disabled and all other threads
- paused. They should take no arguments.")
+(defvar *after-gc-hooks* nil
+ "Called after each garbage collection. In a multithreaded
+environment these hooks may run in any thread.")
;;;; The following specials are used to control when garbage
;;;; collection occurs.
\f
;;;; SUB-GC
-;;; This is used to carefully invoke hooks.
-(eval-when (:compile-toplevel :execute)
- (sb!xc:defmacro carefully-funcall (function &rest args)
- `(handler-case (funcall ,function ,@args)
- (error (cond)
- (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
- nil))))
-
;;; SUB-GC does a garbage collection. This is called from three places:
;;; (1) The C runtime will call here when it detects that we've consed
;;; enough to exceed the gc trigger threshold. This is done in
(defvar *already-in-gc*
(sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC")
-(defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage)))
- (let ((me (sb!thread:current-thread-id)))
- (when (eql (sb!thread::mutex-value *already-in-gc*) me)
- (return-from sub-gc nil))
+(defun sub-gc (&key (gen 0))
+ (unless (eql (sb!thread:current-thread-id)
+ (sb!thread::mutex-value *already-in-gc*))
(setf *need-to-collect-garbage* t)
(when (zerop *gc-inhibit*)
- (loop
- (sb!thread:with-mutex (*already-in-gc*)
- (unless *need-to-collect-garbage* (return-from sub-gc nil))
- (without-interrupts
- (gc-stop-the-world)
- (collect-garbage gen)
- (incf *n-bytes-freed-or-purified*
- (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
- (scrub-control-stack)
- (setf *need-to-collect-garbage* nil)
- (dolist (h *after-gc-hooks*) (carefully-funcall h))
- (gc-start-the-world))
- (sb!thread::reap-dead-threads))))))
+ (sb!thread:with-mutex (*already-in-gc*)
+ (let ((old-usage (dynamic-usage))
+ (new-usage 0))
+ (unsafe-clear-roots)
+ ;; We need to disable interrupts for GC, but we also want
+ ;; to run as little as possible without them.
+ (without-interrupts
+ (gc-stop-the-world)
+ (collect-garbage gen)
+ (setf *need-to-collect-garbage* nil
+ new-usage (dynamic-usage))
+ (gc-start-the-world))
+ ;; Interrupts re-enabled, but still inside the mutex.
+ ;; In a multithreaded environment the other threads will
+ ;; see *n-b-f-o-p* change a little late, but that's OK.
+ (let ((freed (- old-usage new-usage)))
+ ;; GENCGC occasionally reports negative here, but the
+ ;; current belief is that it is part of the normal order
+ ;; of things and not a bug.
+ (when (plusp freed)
+ (incf *n-bytes-freed-or-purified* freed)))
+ (sb!thread::reap-dead-threads)))
+ ;; Outside the mutex, these may cause another GC.
+ (run-pending-finalizers)
+ (dolist (hook *after-gc-hooks*)
+ (handler-case
+ (funcall hook)
+ (error (c)
+ (warn "Error calling after GC hook ~S:~% ~S" hook c)))))))
;;; This is the user-advertised garbage collection function.
(defun gc (&key (gen 0) (full nil) &allow-other-keys)
generational garbage collectors, but is ignored in this implementation."
(sub-gc :gen (if full 6 gen)))
+(defun unsafe-clear-roots ()
+ ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
+ ;; as having these cons more then we have space left leads to huge
+ ;; badness.
+ (scrub-control-stack)
+ ;; FIXME: CTYPE-OF-CACHE-CLEAR isn't thread-safe.
+ #!-sb-thread
+ (ctype-of-cache-clear))
+
\f
;;;; auxiliary functions
(sb!alien:unsigned 32))
val))
+;;; FIXME: Aren't these utterly wrong if called inside WITHOUT-GCING?
+;;; Unless something that works there too can be deviced this fact
+;;; should be documented.
(defun gc-on ()
#!+sb-doc
"Enable the garbage collector."
(specifier-type 'character))
(t
(classoid-of x))))
-
-;;; Clear this cache on GC so that we don't hold onto too much garbage.
-(pushnew 'ctype-of-cache-clear *before-gc-hooks*)
\f
(!defun-from-collected-cold-init-forms !target-type-cold-init)
;;; FIXME: These could be converted to DEFVARs.
(declaim (special *gc-inhibit* *need-to-collect-garbage*
- *before-gc-hooks* *after-gc-hooks*
+ *after-gc-hooks*
#!+x86 *pseudo-atomic-atomic*
#!+x86 *pseudo-atomic-interrupted*
sb!unix::*interrupts-enabled*
--- /dev/null
+#!/bin/sh
+#
+# This test is as convoluted as it is to avoid having failing tests
+# hang the test-suite, as the typical failure mode used to be SBCL
+# hanging uninterruptible in GC.
+
+echo //entering finalize.test.sh
+
+rm -f finalize-test-passed finalize-test-failed
+
+${SBCL:-sbcl} <<EOF > /dev/null &
+(defvar *tmp* 0.0)
+(defvar *count* 0)
+
+(defun foo (_)
+ (declare (ignore _))
+ nil)
+
+(let ((junk (mapcar (lambda (_)
+ (declare (ignore _))
+ (let ((x (gensym)))
+ (finalize x (lambda ()
+ ;; cons in finalizer
+ (setf *tmp* (make-list 10000))
+ (incf *count*)))
+ x))
+ (make-list 10000))))
+ (setf junk (foo junk))
+ (foo junk))
+
+(gc :full t)
+(gc :full t)
+
+(if (= *count* 10000)
+ (with-open-file (f "finalize-test-passed" :direction :output)
+ (write-line "OK" f))
+ (with-open-file (f "finalize-test-failed" :direction :output)
+ (format f "OOPS: ~A~%" *count*)))
+
+(sb-ext:quit)
+EOF
+
+SBCL_PID=$!
+WAITED=0
+
+echo "Waiting for SBCL to finish stress-testing finalizers"
+while true; do
+ if [ -f finalize-test-passed ]; then
+ echo "OK"
+ exit 104 # Success
+ elif [ -f finalize-test-failed ]; then
+ echo "Failed"
+ exit 1 # Failure
+ fi
+ sleep 1
+ WAITED=$(($WAITED+1))
+ if (($WAITED>60)); then
+ echo
+ echo "timeout, killing SBCL"
+ kill -9 $SBCL_PID
+ exit 1 # Failure, SBCL probably hanging in GC
+ fi
+done
+
;;; 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".)
-"0.8.21.22"
-
+"0.8.21.23"
projects / sbcl.git / commitdiff