From fd526bc66c53616a2e757323cbda0271c72b3d54 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 8 Apr 2005 12:30:13 +0000 Subject: [PATCH] 0.8.21.23: rewritten SUB-GC & finalization * 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.] --- NEWS | 7 ++++ package-data-list.lisp-expr | 6 ++-- src/code/cold-init.lisp | 3 +- src/code/cross-misc.lisp | 9 ----- src/code/final.lisp | 68 ++++++++++++++++++----------------- src/code/gc.lisp | 83 ++++++++++++++++++++++++------------------- src/code/target-type.lisp | 3 -- src/code/toplevel.lisp | 2 +- tests/finalize.test.sh | 64 +++++++++++++++++++++++++++++++++ version.lisp-expr | 3 +- 10 files changed, 161 insertions(+), 87 deletions(-) create mode 100644 tests/finalize.test.sh diff --git a/NEWS b/NEWS index 1f29261..ef3df1b 100644 --- a/NEWS +++ b/NEWS @@ -2,11 +2,18 @@ changes in sbcl-0.8.22 relative to sbcl-0.8.21: * 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 #, 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. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 418a9a9..0820a6f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -551,7 +551,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "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" @@ -1345,7 +1345,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." #!+(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" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 262e296..1e31f57 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -92,8 +92,7 @@ ;; !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 diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index fa6ac68..440c037 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -31,15 +31,6 @@ (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 diff --git a/src/code/final.lisp b/src/code/final.lisp index b4a920f..a2adcaf 100644 --- a/src/code/final.lisp +++ b/src/code/final.lisp @@ -11,44 +11,48 @@ (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*) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 98c4e4c..dcab2ea 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -139,17 +139,9 @@ and submit it as a patch." ;;;; 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. @@ -200,14 +192,6 @@ and submit it as a patch." ;;;; 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 @@ -226,25 +210,40 @@ and submit it as a patch." (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) @@ -256,6 +255,15 @@ and submit it as a patch." 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)) + ;;;; auxiliary functions @@ -272,6 +280,9 @@ and submit it as a patch." (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." diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index f8dccd3..5639b78 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -196,8 +196,5 @@ (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*) (!defun-from-collected-cold-init-forms !target-type-cold-init) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 43a5c0b..d9348ab 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -26,7 +26,7 @@ ;;; 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* diff --git a/tests/finalize.test.sh b/tests/finalize.test.sh new file mode 100644 index 0000000..222f1fb --- /dev/null +++ b/tests/finalize.test.sh @@ -0,0 +1,64 @@ +#!/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} < /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 + diff --git a/version.lisp-expr b/version.lisp-expr index ddb271b..6637cf0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,5 +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".) -"0.8.21.22" - +"0.8.21.23" -- 1.7.10.4