diff --git a/benchmarks/finalize.lisp b/benchmarks/finalize.lisp new file mode 100644 index 000000000..6349de924 --- /dev/null +++ b/benchmarks/finalize.lisp @@ -0,0 +1,41 @@ +(defun make-threads (semaphore nwriters nobjects) + (loop for i below nwriters + collect + (let ((list (loop repeat nobjects for j from 1 + collect (cons i j)))) + (sb-thread:make-thread + (lambda (things) + (sb-thread:wait-on-semaphore semaphore) + (dolist (thing things) + (finalize thing #'+)) ; a no-op finalizer + (mapc #'cancel-finalization things)) + :arguments (list list) + :name (format nil "worker ~D" i))))) + +(defun test-finalize+cancel (ntrials nwriters nobjects) + (dotimes (i ntrials) + (let* ((sem (sb-thread:make-semaphore)) + (threads (make-threads sem nwriters nobjects))) + (sb-thread:signal-semaphore sem nwriters) + (mapc #'sb-thread:join-thread threads)))) + +(time (test-finalize+cancel 100 4 10000)) ; 100 trials, 4 threads, 10k objects per thread +#| +;; Old: +Evaluation took: + 4.100 seconds of real time + 10.704615 seconds of total run time (10.585181 user, 0.119434 system) + [ Run times consist of 0.017 seconds GC time, and 10.688 seconds non-GC time. ] + 261.10% CPU + 9,841,747,312 processor cycles + 203,244,640 bytes consed + +;; New: +Evaluation took: + 1.179 seconds of real time + 2.874184 seconds of total run time (2.756504 user, 0.117680 system) + [ Run times consist of 0.041 seconds GC time, and 2.834 seconds non-GC time. ] + 243.77% CPU + 2,830,553,292 processor cycles + 353,720,608 bytes consed +|# diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 961112ef0..96ce3684f 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -404,8 +404,6 @@ process to continue normally." (sb-thread::init-main-thread) #+x86-64 (sb-vm::validate-asm-routine-vector) (rebuild-package-vector)) - ;; Initializing the standard streams calls ALLOC-BUFFER which calls FINALIZE - (finalizers-reinit) ;; Initialize streams next, so that any errors can be printed (stream-reinit t) (rebuild-pathname-cache) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index c8560d460..326badae3 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -18,7 +18,6 @@ (let ((args (copy-list args))) (remf args :weakness) (remf args :synchronized) - (remf args :finalizer) (let ((hash-fun (getf args :hash-function))) (when hash-fun (assert (eq (getf args :test) 'eq)) diff --git a/src/code/final.lisp b/src/code/final.lisp index ea050b969..326941cab 100644 --- a/src/code/final.lisp +++ b/src/code/final.lisp @@ -1,4 +1,4 @@ -;;;; finalization based on weak-keyed hash-table +;;;; finalization based on weak Split-Ordered Lists ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -11,36 +11,130 @@ (in-package "SB-IMPL") -(defmacro with-finalizer-store ((var) &body body) - `(with-system-mutex ((hash-table-lock (finalizer-id-map **finalizer-store**))) - ;; Grab the global var inside the lock in case the array was enlarged - ;; after we referenced the mutex but before we acquired it. - ;; It's OK to reference the FINALIZER-ID-MAP because that is always - ;; in element 1 of the array regardless of what happens to the array. - (let ((,var **finalizer-store**)) - ,@body))) +;;; Finalizer table keys are fixnums - NOT objects or SB-VM:WORD - representing +;;; the aligned base address of a lisp object. This is purposely opaque to GC +;;; so that we don't need a special variant of lockfree list that adds weakness. +;;; GC understands the untagged pointer nature of the keys in this table +;;; in exactly the one place that it needs to. +(define-load-time-global **finalizer-store** (sb-lockless:make-so-map/addr)) +(declaim (type sb-lockless::split-ordered-list **finalizer-store**)) -(defmacro finalizer-recycle-bin (store) `(cdr (elt ,store 0))) -(defmacro finalizer-id-map (store) `(elt ,store 1)) -(defmacro finalizer-max-id (store) `(elt ,store 2)) +;;; A mutex is used during rehash due to key movement, but NOT if rehashing +;;; due to table growth. (If growing organically, hashes are valid, so you'll +;;; find what you're looking for if it's there. Invalid hashes are trickier) +(define-load-time-global *finalizer-lock* (sb-thread:make-mutex :name "finalizer")) +(declaim (type sb-thread:mutex *finalizer-lock*)) -(defun make-finalizer-store (array-length) - (let* ((v (make-array (the index array-length) :initial-element 0)) - (ht (make-system-hash-table :test 'eq :weakness :key :synchronized nil - :finalizer t))) - ;; The recycle bin has a dummy item in front so that the simple-vector - ;; is growable without messing up RUN-PENDING-FINALIZERS when it atomically - ;; pushes items into the recycle bin - it is unaffected by looking at - ;; an obsolete **FINALIZER-STORE** if FINALIZE has assigned a new one. - (setf (elt v 0) (list 0) - (finalizer-id-map v) ht - (finalizer-max-id v) 2) - v)) +;;; List of nodes removed from the split-ordered list due to key movement. +;;; These get reinserted when searching the table. +;;; It is built of lockfree list nodes without using the full algorithm of Harris, +;;; and has _two_ possible empty list markers: +TAIL+ indicates that rehashing +;;; reached the last worklist item and is nominally still processing; while NIL +;;; indicates no work to be done at all. +(declaim (type (or null sb-lockless::list-node) *finalizer-rehashlist*)) +(define-load-time-global *finalizer-rehashlist* nil) -(defconstant +finalizers-initial-size+ 50) ; arbitrary -(define-load-time-global **finalizer-store** - (make-finalizer-store +finalizers-initial-size+)) -(declaim (simple-vector **finalizer-store**)) +;;; List of all nodes whose finalizer(s) should be invoked. +;;; This is an ordinary list. Only the front node can be pushed/popped. +(declaim (type list *finalizers-triggered*)) +(define-load-time-global *finalizers-triggered* nil) + +;;; Side note: just about every compare-and-swap in this file would be better off +;;; as a "weak" compare-and-swap if we had such thing. When spurious failure +;;; occurs, we're already inside a loop, and will retry the CAS anyway. + +;;; Rehashing due to key movement is synchronized by the finalizer-lock. +;;; When adding or canceling a finalizer, we first have to handle the possibility +;;; that GC moved the object of interest from FINALIZER-STORE into FINALIZER-REHASHLIST. +;;; All those keys have to be re-inserted, otherwise there's no way to know the +;;; disposition of a CANCEL-FINALIZATION request. +;;; Even if users are always careful never to operate on one object from two different +;;; threads - so they never introduce a data race between FINALIZE and CANCEL - +;;; we could, if rehashing in multiple threads, create a data race between a user +;;; trying to CANCEL, and a different thread processing the rehashlist and inserting +;;; the canceled key. To prevent that, only one thread will rehash if keys moved. +;;; +;;; Note: Other keys could appear in the FINALIZER-REHASHLIST _after_ we test +;;; whether it is equal to +TAIL+. This can occur because we're not synchronized +;;; with GC. But that's OK - we pin OBJECT before entering the mutex scope, +;;; therefore it can not move to the rehashlist. So upon seeing the alleged end of the +;;; rehashlist, OBJECT can not be in it. But it could actually be in the FINALIZER-STORE +;;; already because if two threads observe *FINALIZER-REHASHLIST* to be non-nil, they'll +;;; both try to rehash, and presumably one will have no work to do. (Unless GC moves +;;; even more things after the first thread to rehash leaves its mutex scope) +(macrolet + ((base-pointer (k) ; Cast K to fixnum in the DESCRIPTOR-SAP representation. + `(%make-lisp-obj (logandc2 (get-lisp-obj-address ,k) sb-vm:lowtag-mask))) + (insert (k v) + `(with-pinned-objects (,k) + (prog1 (sb-lockless:so-insert table (base-pointer ,k) ,v) + (sb-thread:barrier (:write))))) + (get-table () + ;; The global var itself is actually invariant, but I suspect that lookups + ;; need to ensure that writes became visible. + `(progn (sb-thread:barrier (:read)) **finalizer-store**)) + (with-rehashing (result-expression) + `(progn + ;; Must not observe *FINALIZER-REHASHLIST* until _after_ we've pinned OBJECT. + ;; Otherwise, for a relaxed-memory-order CPU you could read the rehashlist, + ;; see NIL, store to *PINNED-OBJECTS*, but in between the read and your store, + ;; GC moved the OBJECT you want to lookup into the rehashlist. + (sb-thread:barrier (:read)) + (when *finalizer-rehashlist* + (with-system-mutex (*finalizer-lock*) + (let* ((found (%finalizers-rehash object table)) + (result ,result-expression)) + ;; Regardless of what %finalizers-rehash did, try to change +TAIL+ to NIL + ;; so that threads don't attempt to acquire the mutex until after next GC. + (cas *finalizer-rehashlist* sb-lockless:+tail+ nil) + result)))))) + +;;; Scan the rehashlist looking for KEY, stopping and returning its list node if found. +;;; Each node seen prior to stopping will be reinserted into either the triggered +;;; list or the finalizer store. +;;; There's no race with other threads now, except for a GCing thread. +;;; Thus we need atomic operations despite the mutex. +;;; Possible TODO: 'target-hash-table' uses WITH-PINNED-OBJECT-ITERATOR +;;; which on the precise stack platforms is slightly preferable +;;; to repeated binds and unbinds of *PINNED-OBJECTS. +(defun %finalizers-rehash (key table) + (let ((node *finalizer-rehashlist*)) + (loop + ;; Instead of setting *FINALIZER-REHASHLIST* to NIL on the last item, + ;; it becomes +TAIL+ which forces other threads to wait on the mutex. + ;; Otherwise they have no guarantee that the item of interest + ;; to them isn't the one which is currently in flight in this loop. + (when (or (eq node sb-lockless:+tail+) (null node)) + (return)) + (let* ((next (sb-lockless:%node-next (the sb-lockless::so-data-node node))) + (actual (cas *finalizer-rehashlist* node next))) ; like ATOMIC-POP + (if (eq node actual) + (let* ((weakptr (the weak-pointer (sb-lockless:so-key node))) + (obj (weak-pointer-value weakptr))) + (cond ((null obj) ; broken ptr, transfer to triggered list + (atomic-push (sb-lockless:so-data node) *finalizers-triggered*) + (setf (sb-lockless:so-key node) 0)) ; don't need the weak-pointer + ((neq obj key) ; re-insert + ;; GC has a nonzero amount of extra work for each weak-pointer + ;; but not if the value in it is NIL + (%primitive sb-c:set-slot weakptr nil 'setf sb-vm:weak-pointer-value-slot + sb-vm:other-pointer-lowtag) + (insert obj (sb-lockless:so-data node))) + (t ; This is the _least_ likely case, so test it last + (return node))) ; FOUND + (setq node next)) + (setq node actual)))))) + +(defun finalizers-rehash () + ;; won't find T in the rehashlist, so this rehashes everything + (%finalizers-rehash t (get-table))) + +;;; For debugging/regression testing +(export '%lookup-finalizer) +(defun %lookup-finalizer (x) + (with-pinned-objects (x) + (finalizers-rehash) + (sb-lockless:so-find (get-table) (base-pointer x)))) (defun finalize (object function &key dont-save &aux (function (%coerce-callable-to-fun function))) @@ -101,217 +195,157 @@ Examples: ;; silently discard finalizers on file streams in arenas I guess (progn ; (warn "Will not finalize ~S." object) (return-from finalize object))))) - (let ((item (if dont-save (list function) function))) - (with-finalizer-store (store) - (let ((id (gethash object (finalizer-id-map store)))) - (cond - (id ; object already has at least one finalizer - ;; Multiple finalizers are invoked in the order added. - (let* ((old (svref store id)) - (new (make-array (if (simple-vector-p old) - (1+ (length old)) ; already > 1 - 2)))) ; was singleton - (if (= (length new) 2) - (setf (aref new 0) old) ; upgrade singleton to vector - (replace new old)) - (setf (aref new (1- (length new))) item - (svref store id) new))) - (t ; assign the next available ID to this object - (cond ((finalizer-recycle-bin store) - ;; We must operate atomically with respect to producers, - ;; because RUN-PENDING-FINALIZERS is lock-free. - ;; The initial test above said that the bin is nonempty, - ;; so we can't fail to obtain an item, as the list can't - ;; shrink except through here, which is mutually exclusive - ;; with other consumers of recycled items. - (setq id (atomic-pop (finalizer-recycle-bin store)))) - (t - (setq id (incf (finalizer-max-id store))) - (unless (< id (length store)) - (sb-thread:barrier (:write) - ;; We must completely copy the old vector into the new - ;; before publishing the new in **FINALIZER-STORE**. - ;; Perhaps a cleverer way to size up is to have a tree - ;; of vectors; never remove cells already created, - ;; but simply graft new limbs on to the tree. - (setq store (adjust-array store (* (length store) 2) - :initial-element 0))) - (setq **finalizer-store** store)))) - ;; Clear out lingering junk from (SVREF STORE ID) before - ;; establishing that OBJECT maps to that index. - (setf (svref store id) item - (gethash object (finalizer-id-map store)) id)))))) - object) - -(defun invalidate-fd-streams () - (with-finalizer-store (store) - (maphash (lambda (object id) - (declare (ignore id)) - (when (fd-stream-p object) - (push (list object - (ansi-stream-in object) - (ansi-stream-bin object) - (ansi-stream-n-bin object) - (ansi-stream-out object) - (ansi-stream-bout object) - (ansi-stream-sout object) - (ansi-stream-misc object)) - *streams-closed-by-slad*) - ;; Nobody asked us to actually close the fd, - ;; so just make it unusable. - (set-closed-flame-by-slad object))) - (finalizer-id-map store)))) - -(defun finalizers-deinit () - ;; remove :dont-save finalizers - ;; Renumber the ID range as well, but leave the array size as-is. We could - ;; probably delete *all* finalizers prior to image dump, because saved - ;; finalizers can in practice almost never be run, as pseudo-static objects - ;; don't die, making this more-or-less an exercise in futility. - (with-finalizer-store (old-store) - ;; This doesn't need WITHOUT-GCING. MAPHASH will never present its funarg - ;; with a culled entry. GC during the MAPHASH could remove some items - ;; before we get to them, and that's fantastic. - (let ((new-store - (make-finalizer-store (max (1+ (finalizer-max-id old-store)) - +finalizers-initial-size+))) - (old-objects (finalizer-id-map old-store))) - (maphash (lambda (object old-id &aux (old (svref old-store old-id))) - ;; OLD is either a vector of finalizers or a single finalizer. - ;; Each finalizer is either a callable (a symbol or function) - ;; or a singleton list of a callable. - ;; Delete any finalizer wrapped in a cons, meaning "don't save". - (awhen (cond ((simple-vector-p old) - (let ((new (remove-if #'consp old))) - (case (length new) - (0 nil) ; all deleted - (1 (svref new 0)) ; reduced to singleton - (t new)))) - ((atom old) old)) ; a single finalizer to be saved - (let ((new-id (incf (finalizer-max-id new-store)))) - (setf (gethash object (finalizer-id-map new-store)) new-id - (svref new-store new-id) it)))) - old-objects) - (clrhash old-objects) - (fill old-store 0) - (setq **finalizer-store** new-store)))) - -;;; Replace the finalizer store with a copy. Tenured (gen6 = pseudo-static) -;;; vectors are problematic in many ways for gencgc, unless immutable. -;;; Among the problems is this: after sizing **FINALIZER-STORE** up, -;;; Lisp doesn't know when there are no readers of the old vector -;;; (due to the lock-free algorithm for RUN-PENDING-FINALIZERS), -;;; so we can't safely zero-fill the old vector. Making sure that it -;;; is not immortal (i.e. not in gen6), is a reasonable workaround. -;;; [Actually, in this particular algorithm, it is slightly OK to zero-fill -;;; due to the fact that 0 is not a list; therefore if (SVREF V INDEX) is 0, -;;; we can chase down the correct value by reloading **FINALIZER-STORE**. -;;; Of course the zero-fill noise is itself a workaround for accidental -;;; transitive immortalization, which is issue that merits a general fix] -(defun finalizers-reinit () - ;; This must be called inside WITHOUT-GCING and with no other threads. - (aver *gc-inhibit*) - (let* ((old-store **finalizer-store**) - (new-store (make-finalizer-store (length old-store))) - (old-objects (finalizer-id-map old-store)) - (new-objects (finalizer-id-map new-store))) - ;; Copy the max-id and all the finalizers. - ;; The recycle bin is empty, and the hash-table is newly consed. - (replace new-store old-store :start1 2 :start2 2) - ;; Copy the hash-table. - ;; Or should the old just be assigned into the new finalizer-store? - ;; Probably not, because immortable hash-tables have a similar - ;; problem as cited above, unless strictly constant. - ;; (Though mitigated by a FILL in REHASH) - (maphash (lambda (object id) (setf (gethash object new-objects) id)) - old-objects) - (clrhash old-objects) - (fill old-store 0) - (setq **finalizer-store** new-store))) + (let* ((node + (with-pinned-objects (object) + (let ((table (get-table))) + ;; Attempt 1: optimistically look in the solist assuming valid hashes + (or (sb-lockless:so-find table (base-pointer object)) + ;; Attempt 2: perform rehashing and examine each key while looping + (with-rehashing (when found + (insert object (sb-lockless:so-data found)))) + ;; Attempt 3: another thread could have done all the rehashing and + ;; inserted OBJECT. If not, this will insert a new node. + (insert object nil))))) + ;; Conditionally wrapping a VALUE-CELL around FUNCTION is a means to indicate + ;; the :DONT-SAVE option without inventing a struct of a function and boolean. + ;; I believe that most finalizers will *not* have the :DONT-SAVE flag set. + ;; As evidence the https://github.com/trivial-garbage/trivial-garbage portability + ;; library does not offer a way to specify :DONT-SAVE. + (action + (if dont-save (sb-sys:%primitive sb-vm::make-value-cell function nil) function)) + (old-data (sb-lockless:so-data node))) + (loop + ;; Decide how to represent NEW-DATA + ;; choice (a) FUNCTION | VALUE-CELL = just one finalizer + ;; choice (b) LIST of (OR FUNCTION VALUE-CELL) = more than one + (let ((new-data (if old-data (cons action (ensure-list old-data)) action))) + (when (eq old-data + (setf old-data (cas (sb-lockless:so-data node) old-data new-data))) + (return object)))))) (defun cancel-finalization (object) - "Cancel all finalizations for OBJECT." - (when object - (with-finalizer-store (store) - (let ((hashtable (finalizer-id-map store))) - (awhen (gethash object hashtable) - (remhash object hashtable) - ;; Clear old function(s) before publishing the ID as available. - ;; Not strictly necessary to do this: the next FINALIZE claiming - ;; the same ID would assign a fresh list anyway. - (setf (svref store it) 0) - (locally (declare (sb-c::tlab :system)) - (atomic-push it (finalizer-recycle-bin store))))))) - object) + "Cancel all finalizations for OBJECT, returning T if it had a finalizer." + (when (and object (heap-allocated-p object)) + (with-pinned-objects (object) + (let ((table (get-table))) + ;; Attempt 1: optimistically look in the solist assuming valid hashes + (or (sb-lockless:so-delete table (base-pointer object)) + ;; Attempt 2: perform rehashing and examine each key while looping + (with-rehashing found) ; implies no re-insert, so we're done + ;; Attempt 3: Give it another chance. Third time's a charm? + ;; (Technically do not need this if current thread rehashed? not sure) + (sb-lockless:so-delete table (base-pointer object))))))) +) ; end MACROLET +;;; FIXME: probably want vop for this, it's just PSEUDO-ATOMIC wrapped around +;;; reconstitute-object, but I don't want to hand-write all that assembly. +;;; So for now: MUST be wrapped in WITHOUT-GCING by calling code +(export 'finalizer-object) ; for regression test +(defun finalizer-object (node) + (sb-vm::reconstitute-object (sb-lockless:so-key node))) + +(defun finalizers-deinit () + (when (null *finalizer-rehashlist*) + (setq *finalizer-rehashlist* sb-lockless:+tail+)) + ;; invalidate fd-streams + (flet ((flameout (object) + (push (list object + (ansi-stream-in object) + (ansi-stream-bin object) + (ansi-stream-n-bin object) + (ansi-stream-out object) + (ansi-stream-bout object) + (ansi-stream-sout object) + (ansi-stream-misc object)) + *streams-closed-by-slad*) + ;; Nobody asked us to actually close the fd, + ;; so just make it unusable. + (set-closed-flame-by-slad object))) + (do ((node *finalizer-rehashlist* (sb-lockless:%node-next node))) + ((eq node sb-lockless:+tail+)) + (let ((object (weak-pointer-value (sb-lockless:so-key node)))) + (when (fd-stream-p object) + (flameout object)))) + (let* ((table **finalizer-store**) + ;; Avoid consing inside SO-MAPLIST + (array (make-array (sb-lockless::so-count table))) + (n 0)) + (without-gcing + (sb-lockless:so-maplist + (lambda (node) + (let ((object (finalizer-object node))) + (when (fd-stream-p object) + (setf (aref array n) object) + (incf n)))) + table)) + (dotimes (i n) + (flameout (aref array i))))) + ;; remove :dont-save finalizers + (flet ((filter-actions (node &aux (actions (sb-lockless:so-data node))) + (cond ((listp actions) + ;; (NOT FUNCTIONP) implies :DONT-SAVE + (let ((new (delete-if-not #'functionp actions))) + ;; If SINGLETON-P then just store the one. NIL stays as-is + (setf (sb-lockless:so-data node) (if (cdr new) new (car new))))) + ((functionp actions) actions)))) + ;; Process the need-rehash items, leaving them in that list if applicable. + ;; Nodes already in rehashlist might actually be subject to removal + ;; either because the object died, or all its actions are :DONT-SAVE. + (do ((prev nil) ; no dummy node, you dummy + (this *finalizer-rehashlist*)) + ((eq this sb-lockless:+tail+)) + (let ((next (sb-lockless:%node-next this))) + (cond ((and (filter-actions this) + (weak-pointer-value (sb-lockless:so-key this))) + (setf prev this this next)) ; keep + (t ; discard + (setf this next) + (if prev + (setf (sb-lockless:%node-next prev) this) + (setf *finalizer-rehashlist* this)))))) + ;; Process the hashed items, moving them to the rehash list if applicable. + ;; Safely resurrecting objects by their address requires WITHOUT-GCING. + (without-gcing + (sb-lockless:so-maplist + (lambda (node) + (when (filter-actions node) + ;; re-use the node + (setf (sb-lockless:so-key node) (make-weak-pointer (finalizer-object node)) + (sb-lockless:%node-next node) *finalizer-rehashlist* + *finalizer-rehashlist* node))) + **finalizer-store**))) + ;; We don't promise to execute pending actions on save-lisp-and-die. + ;; Could we? Should we? + (setq *finalizers-triggered* nil) + ;; Create an empty table. FINALIZE will reinsert things when next called. + (setf **finalizer-store** (sb-lockless::make-so-map/addr))) + +(defvar *in-a-finalizer* nil) +(define-load-time-global *user-finalizer-runcount* 0) +(defun run-user-finalizer () ; Return T if this did anything + (let* ((data (atomic-pop *finalizers-triggered*)) + (data-list (list data))) + ;; DATA could already be a list. This is basically a no-consing ENSURE-LIST + (declare (truly-dynamic-extent data-list)) + (dolist (finalizer (if (listp data) data data-list) (not (null data))) + ;; :DONT-SAVE finalizers are wrapped in value-cells. Unwrap as necessary + (let ((fun (the function (if (functionp finalizer) + finalizer + (value-cell-ref finalizer))))) + ;; Binding *IN-A-FINALIZER* prevents recursive run-pending-finalizers + ;; if #-sb-thread. #+sb-thread probably doesn't require it. + (handler-case (let ((*in-a-finalizer* t)) (funcall fun)) + (error (c) (warn "Error calling finalizer ~S:~% ~S" fun c))))))) + +#+sb-thread (define-alien-variable finalizer-thread-runflag int) ;;; Drain the queue of finalizers and return when empty. ;;; Concurrent invocations of this function in different threads are ok. ;;; Nested invocations (from a GC forced by a finalizer) are not ok. ;;; See the trace at the bottom of this file. -(defvar *in-a-finalizer* nil) -#+sb-thread (define-alien-variable finalizer-thread-runflag int) - -(defun run-user-finalizer (&aux (hashtable (finalizer-id-map **finalizer-store**))) - ;; This never acquires the finalizer store lock. Code accordingly. - (let ((cell (hash-table-culled-values hashtable))) - ;; This is like atomic-pop, but its obtains the first cons cell - ;; in the list, not the car of the first cons. - ;; Possible TODO: when no other work remains, free the *JOINABLE-THREADS*, - ;; though MAKE-THREAD and JOIN-THREAD do that also, so there's no memory leak. - (loop (unless cell (return)) - (let ((actual (cas (hash-table-culled-values hashtable) - cell (cdr cell)))) - (if (eq actual cell) (return) (setq cell actual)))) - (when cell - (let* ((id (the index (car cell))) - ;; No other thread can modify **FINALIZER-STORE** at index ID - ;; because the table no longer contains an object mapping to - ;; that element; however the vector could be grown at any point, - ;; so always load the vector again before dereferencing. - (store **finalizer-store**) - ;; I don't think we need a barrier; this has a data dependency - ;; on (CAR CELL) and STORE. - (finalizers (svref store id))) ; [1] load - (setf (svref store id) 0) ; [2] store - ;; The ID can be reused right away. Link it into the recycle list, - ;; which has an extra NIL at the head so that we can use RPLACD, - ;; making this operation agnostic of whether the vector was switched. - (let* ((list (svref store 0)) - (old (cdr list))) - (loop (let ((actual (cas (cdr list) old (rplacd cell old)))) - (if (eq actual old) (return) (setq old actual))))) - ;; Now call the function(s) - (flet ((call (finalizer) - (let ((fun (if (consp finalizer) (car finalizer) finalizer))) - (handler-case (let ((*in-a-finalizer* t)) (funcall fun)) - (error (c) - (warn "Error calling finalizer ~S:~% ~S" fun c)))))) - (if (simple-vector-p finalizers) - (map nil #'call finalizers) - (call finalizers))) - ;; While the assignment to (SVREF STORE ID) should have been adequate, - ;; we don't know that the vector is current - a new vector could have - ;; gotten assigned into **FINALIZER-STORE** in between [1] and [2], - ;; in which case the store was performed into the wrong vector. - ;; It doesn't actually matter. Using CAS isn't an improvement, because - ;; the vector itself is potentially wrong. But the load was valid - ;; because the the cell's value is frozen, just duplicated into more - ;; than one vector (in fact, an arbitrary number of vectors). - ;; A reductio ad absurdum argument shows this: - ;; - if you had a way to alter the contents of (SVREF STORE ID), - ;; then you must have been able to find via the hash-table the - ;; object that maps to that index, which means it wasn't dead, - ;; so we must not be here trying to call finalizers for it. - ;; Smashing 'finalizers' is a good extra step in terms of - ;; removing dangling references, but if it's just a function, - ;; there's nothing to smash. - (cond ((simple-vector-p finalizers) (fill finalizers 0)) - ((consp finalizers) (rplaca finalizers 0)))) - t))) - (define-load-time-global *bg-compiler-function* nil) (defun run-pending-finalizers (&aux (system-finalizer-scratchpad (list 0))) (declare (truly-dynamic-extent system-finalizer-scratchpad)) + (finalizers-rehash) (loop ;; Perform no further work if trying to stop the thread, even if there is work. #+sb-thread (when (zerop finalizer-thread-runflag) (return)) @@ -375,6 +409,22 @@ Examples: (sb-thread:join-thread thread))) ) +(export 'show-finalizers) +(defun show-finalizers (&aux (*print-pretty* nil)) + (flet ((display (key) + (if key + (format t "~D ~X ~S~%" (generation-of key) (get-lisp-obj-address key) key) + (format t "~%")))) + (format t "~&Unhashed:~%") + (do ((node (or *finalizer-rehashlist* sb-lockless:+tail+) + (sb-lockless:%node-next node))) + ((eq node sb-lockless:+tail+)) + (display (weak-pointer-value (sb-lockless:so-key node)))) + (format t "~&Hashed:~%") + (sb-lockless:so-maplist (lambda (node) + (display (without-gcing (finalizer-object node)))) + **finalizer-store**))) + #| ;;; This is a display produced by annotating parts of gc-common.c and ;;; interrupt.c with each thread's output in its own column. diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 3b3f76244..02c5132df 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -269,8 +269,7 @@ run in any thread.") ;; interrupts, which is precisely the thing we need to NOT do if already ;; in post-GC code of any kind (be it finalizer or other). (when (and *allow-with-interrupts* - (or (and (sb-impl::hash-table-culled-values - (sb-impl::finalizer-id-map sb-impl::**finalizer-store**)) + (or (and sb-impl::*finalizers-triggered* (not sb-impl::*in-a-finalizer*)) *after-gc-hooks*)) (sb-thread::without-thread-waiting-for () diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp index 0c9f364a7..7b3b518aa 100644 --- a/src/code/hash-table.lisp +++ b/src/code/hash-table.lisp @@ -108,12 +108,11 @@ ;; +MAGIC-HASH-VECTOR-VALUE+ represents address-based hashing on the ;; respective key. (hash-vector nil :type (or null (simple-array hash-table-index (*)))) - ;; flags: WEAKNESS | KIND | WEAKP | FINALIZERSP | USERFUNP | SYNCHRONIZED + ;; flags: WEAKNESS | KIND | WEAKP | {notused} | USERFUNP | SYNCHRONIZED ;; WEAKNESS is 2 bits, KIND is 2 bits, the rest are 1 bit each ;; - WEAKNESS : {K-and-V, K, V, K-or-V}, irrelevant unless WEAKP ;; - KIND : {EQ, EQL, EQUAL, EQUALP}, irrelevant if USERFUNP ;; - WEAKP : table is weak - ;; - FINALIZERSP : table is the global finalizer store ;; - USERFUNP : table has a nonstandard hash function ;; - SYNCHRONIZED : all operations are automatically guarded by a mutex ;; If you change these, be sure to check the definition of hash_table_weakp() @@ -201,11 +200,7 @@ (smashed-cells nil) ;; This slot is used to link weak hash tables during GC. When the GC ;; isn't running it is always NIL. - (next-weak-hash-table nil :type null) - ;; List of values (i.e. the second half of the k/v pair) culled out during - ;; GC, used only by the finalizer hash-table. This informs Lisp of the IDs - ;; (small fixnums) of the finalizers that need to run. - (culled-values nil :type list)) + (next-weak-hash-table nil :type null)) (sb-xc:defmacro hash-table-lock (table) `(let ((ht ,table)) (or (hash-table-%lock ht) (install-hash-table-lock ht)))) diff --git a/src/code/maphash.lisp b/src/code/maphash.lisp index a1c9048e0..1b9b00df9 100644 --- a/src/code/maphash.lisp +++ b/src/code/maphash.lisp @@ -137,7 +137,6 @@ for." form))) (defconstant hash-table-weak-flag 8) -(defconstant hash-table-finalizer-flag 4) ;;; USERFUN-FLAG implies a nonstandard hash function. Such tables may also have ;;; a custom comparator. But you can't have a custom comparator without a custom ;;; hash, because there's no way in general to produce a compatible hash. @@ -157,7 +156,7 @@ for." (defconstant +min-hash-table-size+ 7) (defconstant default-rehash-size $1.5)) -(defmacro make-system-hash-table (&key test synchronized weakness finalizer) +(defmacro make-system-hash-table (&key test synchronized weakness) (multiple-value-bind (kind args) (cond ((equal test '(quote eq)) (values 0 '('eq #'eq #'eq-hash))) ((equal test '(quote eql)) (values 1 '('eql #'eql #'eql-hash))) @@ -169,8 +168,7 @@ for." (:key '(pack-ht-flags-weakness +ht-weak-key+)) (:value '(pack-ht-flags-weakness +ht-weak-value+))) (pack-ht-flags-kind ,kind) - ,(if synchronized 'hash-table-synchronized-flag 0) - ,(if finalizer 'hash-table-finalizer-flag 0)) + ,(if synchronized 'hash-table-synchronized-flag 0)) ,@args ,+min-hash-table-size+ ,default-rehash-size diff --git a/src/code/save.lisp b/src/code/save.lisp index 8928fca85..a19d7c05b 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -346,7 +346,6 @@ sufficiently motivated to do lengthy fixes." ;; Perform static linkage. Functions become un-statically-linked ;; on demand, for TRACE, redefinition, etc. #+immobile-code (sb-vm::statically-link-core) - (invalidate-fd-streams) (finalizers-deinit) ;; Try to shrink the pathname cache. It might be largely nulls (rebuild-pathname-cache) diff --git a/src/cold/undefined-fun-allowlist.lisp-expr b/src/cold/undefined-fun-allowlist.lisp-expr index e3076eab2..6f10b347d 100644 --- a/src/cold/undefined-fun-allowlist.lisp-expr +++ b/src/cold/undefined-fun-allowlist.lisp-expr @@ -178,6 +178,7 @@ sb-impl::bytes-per-utf8-character-aref sb-impl::bytes-per-utf8-character-sap-ref-8 sb-impl::user-homedir-namestring + sb-lockless:make-so-map/addr sb-c::apply-core-fixups sb-c::compiled-debug-info-char-offset sb-c::compiled-debug-info-tlf-number diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp index 2dc6b01d5..c099a28b7 100644 --- a/src/compiler/generic/parms.lisp +++ b/src/compiler/generic/parms.lisp @@ -222,12 +222,9 @@ *immobile-codeblob-tree* ; for generations 0 through 5 inclusive *immobile-codeblob-vector* ; for pseudo-static-generation *dynspace-codeblob-tree* - ;; these are here because I encountered "cannot encode immediate operand" - ;; on 32-bit arm when adding 3 static symbols in a large change. - ;; I want to disentangle that problem from the actual change. - *ss-pad1* - *ss-pad2* - *ss-pad3* + sb-impl::**finalizer-store** + sb-impl::*finalizer-rehashlist* + sb-impl::*finalizers-triggered* ;; stack pointers #-sb-thread *binding-stack-start* ; a thread slot if #+sb-thread diff --git a/src/runtime/fullcgc.c b/src/runtime/fullcgc.c index a8e03ccb3..e818bf2da 100644 --- a/src/runtime/fullcgc.c +++ b/src/runtime/fullcgc.c @@ -152,6 +152,10 @@ static inline int pointer_survived_gc_yet(lispobj pointer) return (fullcgcmarks[mark_index / N_WORD_BITS] >> (mark_index % N_WORD_BITS)) & 1; } +int fullcgc_lispobj_livep(lispobj pointer) { + return pointer_survived_gc_yet(pointer); +} + void dump_marked_objects() { fprintf(stderr, "Marked objects:\n"); page_index_t first = 0; @@ -590,6 +594,7 @@ void execute_full_sweep_phase() local_smash_weak_pointers(); gc_dispose_private_pages(); cull_weak_hash_tables(alivep_funs); + scan_finalizers(); memset(words_zeroed, 0, sizeof words_zeroed); #ifdef LISP_FEATURE_IMMOBILE_SPACE diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index bedba2b2e..4c69993a1 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -45,6 +45,7 @@ #include "genesis/layout.h" #include "genesis/hash-table.h" #include "genesis/list-node.h" +#include "genesis/split-ordered-list.h" #define WANT_SCAV_TRANS_SIZE_TABLES #include "gc-internal.h" #include "gc-private.h" @@ -1718,7 +1719,6 @@ cull_weak_hash_table_bucket(struct hash_table *hash_table, uint32_t *next_vector, uint32_t *hash_vector, int (*alivep_test)(lispobj,lispobj), void (*fix_pointers)(lispobj[2]), - boolean save_culled_values, boolean rehash) { const lispobj empty_symbol = UNBOUND_MARKER_WIDETAG; @@ -1737,22 +1737,6 @@ cull_weak_hash_table_bucket(struct hash_table *hash_table, gc_assert(value != empty_symbol); if (!alivep_test(key, value)) { gc_assert(hash_table->_count > 0); - if (save_culled_values) { - lispobj val = kv_vector[2 * index + 1]; - gc_assert(!is_lisp_pointer(val)); - struct cons *cons = (struct cons*) - gc_general_alloc(cons_region, sizeof(struct cons), PAGE_TYPE_CONS); - // Lisp code which manipulates the culled_values slot must use - // compare-and-swap, but C code need not, because GC runs in one - // thread and has stopped the Lisp world. - cons->cdr = hash_table->culled_values; - cons->car = val; - lispobj list = make_lispobj(cons, LIST_POINTER_LOWTAG); - notice_pointer_store(hash_table, &hash_table->culled_values); - hash_table->culled_values = list; - // ensure this cons doesn't get smashed into (0 . 0) by full gc - if (!compacting_p()) gc_mark_obj(list); - } kv_vector[2 * index] = empty_symbol; kv_vector[2 * index + 1] = empty_symbol; ensure_non_ptr_word_writable(&hash_table->_count); @@ -1815,7 +1799,6 @@ cull_weak_hash_table (struct hash_table *hash_table, SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG); boolean rehash = 0; - boolean save_culled_values = (hash_table->flags & make_fixnum(4)) != 0; // I'm slightly confused as to why we can't (or don't) compute the // 'should rehash' flag while scavenging the weak k/v vector. // I believe the explanation is this: for weak-key-AND-value tables, the vector @@ -1827,7 +1810,7 @@ cull_weak_hash_table (struct hash_table *hash_table, if (cull_weak_hash_table_bucket(hash_table, i, index_vector[i], kv_vector, next_vector, hash_vector, alivep_test, fix_pointers, - save_culled_values, rehash)) + rehash)) rehash = 1; } /* If an EQ-based key has moved, mark the hash-table for rehash */ @@ -1881,7 +1864,7 @@ void cull_weak_hash_tables(int (*alivep[4])(lispobj,lispobj)) * which is what an extra reset would do if it saw no inserts. */ if (weak_objects.count) hopscotch_reset(&weak_objects); - // Close the region used when pushing items to the finalizer queue + // Close the region used when pushing into hash_table->smashed_cells ensure_region_closed(cons_region, PAGE_TYPE_CONS); } @@ -2637,6 +2620,145 @@ scavenge_interrupt_contexts(struct thread *th) #endif /* !REG_CODE */ #endif /* x86oid targets */ +/* Finalizer table based on Split-Ordered Lists */ +typedef struct { + struct list_node lfnode; + lispobj hash; + lispobj key; + lispobj data; + // padding word, only if #+compact-instance-header +} so_node; + +static inline int dummy_node_p(so_node* node) { + return (node->hash & make_fixnum(1)) == 0; +} + +static inline int lispobj_livep(lispobj obj_base) { + extern int fullcgc_lispobj_livep(lispobj); + lispobj obj = compute_lispobj((lispobj*)obj_base); + return compacting_p() ? pointer_survived_gc_yet(obj) : fullcgc_lispobj_livep(obj); +} + +static void push_in_lockfree_list(struct symbol* list_holder, + so_node* this, lispobj key, lispobj data) +{ + // Using the so_node type for the rehash list is slightly wasteful of space + // but I don't feel like inventing another type just to eliminate the 'hash' slot. + // It is, however, imperative that we create new objects, because + // the lockfree algorithm crashes if nodes are mutated. + so_node* node = + gc_general_alloc(mixed_region, ALIGN_UP(sizeof (so_node), 2*N_WORD_BYTES), + PAGE_TYPE_MIXED); + const unsigned int header_low = + (((sizeof (so_node) / N_WORD_BYTES) - 1) << INSTANCE_LENGTH_SHIFT) + | INSTANCE_WIDETAG; +#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER + node->lfnode.header = ((this->lfnode.header >> 32) << 32) | header_low; + *(&node->data + 1) = 0; // padding words +#else + node->lfnode.header = header_low; + node->lfnode._layout = this->lfnode._layout; +#endif + node->hash = 0; + node->key = key; + node->data = data; + lispobj old = list_holder->value; + node->lfnode._node_next = old != NIL ? old : LFLIST_TAIL_ATOM; + // This __sync_val_compare_and_swap can not fail. + // On the machines that have spurious failure, it is not exposed, + // unlike in C++ where you can choose compare_exchange_{weak|strong} + lispobj new = make_lispobj(node, INSTANCE_POINTER_LOWTAG); + lispobj actual = __sync_val_compare_and_swap(&list_holder->value, old, new); + gc_assert(actual == old); + if (!compacting_p()) gc_mark_obj(new); +} +static void push_in_ordinary_list(struct symbol* list_holder, lispobj element) +{ + struct cons* cons = gc_general_alloc(cons_region, 2*N_WORD_BYTES, PAGE_TYPE_CONS); + cons->car = element; + lispobj old = list_holder->value; + cons->cdr = old; + lispobj new = make_lispobj(cons, LIST_POINTER_LOWTAG); + lispobj actual = __sync_val_compare_and_swap(&list_holder->value, old, new); + gc_assert(actual == old); + if (!compacting_p()) gc_mark_obj(new); +} + +/* Scan the finalizer table and take action on each node as follows: + * - dummy nodes are ignored + * - nodes marked for deletion (by CANCEL-FINALIZATION) are culled + * - transported keys are moved to the "rehash" list + * - dead keys are moved to the "triggered" list + * - all other live keys are left alone + */ +void scan_finalizers() +{ + // NOTE: we do NOT need to invoke notice_pointer_store() on the global values + // of REHASHLIST or TRIGGERED because those are static symbols. + lispobj finalizer_store = SYMBOL(FINALIZER_STORE)->value; + gc_assert(lowtag_of(finalizer_store) == INSTANCE_POINTER_LOWTAG); + struct split_ordered_list* solist = (void*)native_pointer(finalizer_store); + so_node* prev = (void*)native_pointer(solist->head); + // SO-HEAD can not possibly be marked for deletion, therefore %NODE-NEXT + // returns a valid node. + lispobj node = prev->lfnode._node_next; + while (node != LFLIST_TAIL_ATOM) { + // At each iteration, 'this' is the node whose disposition we're pondering, + // and 'prev' is its immediate predecessor, always a valid non-deleted node. + so_node* this = (so_node*)(node-INSTANCE_POINTER_LOWTAG); + // To determine if 'this' is pending deletion, read the bits of its 'next' + lispobj next = this->lfnode._node_next; + if (dummy_node_p(this)) { + // Case 1: split-order dummy node + gc_assert(!fixnump(next)); // 'this' can not be marked for impending deletion + prev = this, node = next; + continue; + } else if (fixnump(next)) { + // Case 2: logically deleted regular node- "help" the lisp code along + // by completing this deletion. Lisp will decrement SO-COUNT (I hope!) + } else if (forwarding_pointer_p((lispobj*)this->key)) { + // Case 3: live object moved + // Get the moved object and construct a weak pointer to it. + // If the new object were directly stored in node->key, that would create + // a strong reference which not delays finalization, but also transitively + // enlivens anything it reaches. + struct weak_pointer* weakptr = + gc_general_alloc(mixed_region, + ALIGN_UP(sizeof (struct weak_pointer), 2*N_WORD_BYTES), + PAGE_TYPE_MIXED); + weakptr->header = ((WEAK_POINTER_SIZE-1) << N_WIDETAG_BITS) | WEAK_POINTER_WIDETAG; + weakptr->value = forwarding_pointer_value((lispobj*)this->key); +#ifndef LISP_FEATURE_64_BIT + // 64-bit weak-pointers are 2 words, but 32-bit are 4 words because there + // is a GC-use field. In 64-bit, that field fits in the header. + memset(&weakptr->next, 0, 2*N_WORD_BYTES); // Will crash without this +#endif + if (!compacting_p()) gc_mark_obj(make_lispobj(weakptr, OTHER_POINTER_LOWTAG)); + push_in_lockfree_list(SYMBOL(FINALIZER_REHASHLIST), + this, make_lispobj(weakptr, OTHER_POINTER_LOWTAG), + this->data); + this->key = 0; // clobber dangling reference + --solist->uw_count; + } else if (!lispobj_livep(this->key)) { + // Case 4: dead object + push_in_ordinary_list(SYMBOL(FINALIZERS_TRIGGERED), this->data); + this->key = 0; // clobber dangling reference + --solist->uw_count; + } else { + // Case 5: ordinary node, live unmoved object + prev = this, node = next; + continue; + } + // Cases 2 through 4 all delete 'this' from the list + node = next | INSTANCE_POINTER_LOWTAG; // restore lowtag on 'next' for case 2 + notice_pointer_store(prev, &prev->lfnode._node_next); + prev->lfnode._node_next = node; + } + // Close the region + ensure_region_closed(mixed_region, PAGE_TYPE_MIXED); + ensure_region_closed(cons_region, PAGE_TYPE_CONS); +} + /* Our own implementation of heapsort, because some C libraries have a qsort() * that calls malloc() apparently, which we MUST NOT do. */ diff --git a/src/runtime/gc-private.h b/src/runtime/gc-private.h index b64ddc026..fcc45aaca 100644 --- a/src/runtime/gc-private.h +++ b/src/runtime/gc-private.h @@ -111,6 +111,7 @@ extern sword_t scavenge(lispobj *start, sword_t n_words); extern void scavenge_interrupt_contexts(struct thread *thread); extern void scav_binding_stack(lispobj*, lispobj*, void(*)(lispobj)); extern void scan_binding_stack(void); +extern void scan_finalizers(); extern void cull_weak_hash_tables(int (*[4])(lispobj,lispobj)); extern void smash_weak_pointers(void); extern boolean scan_weak_hashtable(struct hash_table *hash_table, diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index ebcf89c64..d701cefa9 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -4304,6 +4304,7 @@ garbage_collect_generation(generation_index_t generation, int raise, /* Return private-use pages to the general pool so that Lisp can have them */ gc_dispose_private_pages(); cull_weak_hash_tables(weak_ht_alivep_funs); + scan_finalizers(); obliterate_nonpinned_words(); // Do this last, because until obliterate_nonpinned_words() happens, diff --git a/tests/autoclose-stream.impure.lisp b/tests/autoclose-stream.impure.lisp index d51a60153..e19a04278 100644 --- a/tests/autoclose-stream.impure.lisp +++ b/tests/autoclose-stream.impure.lisp @@ -6,11 +6,10 @@ #-unix (invoke-restart 'run-tests::skip-file) (defun fd-has-finalizer-p (fd) - ;; Finalizer function can be: - ;; 1. a function - finalizer that was not created with :DONT-SAVE. - ;; 2. a single list of a function - a finalizer that was created with :DONT-SAVE - ;; 3. a vector - more than one finalizer, each being form 1 or form 2. (flet ((checkit (thing) + ;; Return T if THING is a closure created in MAKE-FD-STREAM + ;; (which is assumed to be a stream finalizer) whose payload + ;; contains the integer FD. (when (and (sb-kernel:closurep thing) (eql (sb-kernel:%closure-index-ref thing 0) fd)) (let ((underlying (sb-kernel:%closure-fun thing))) @@ -18,16 +17,11 @@ (equal (sb-kernel:%simple-fun-name underlying) '(lambda () :in sb-sys:make-fd-stream))) (return-from fd-has-finalizer-p t)))))) - (let ((v sb-impl::**finalizer-store**)) - (loop for i from 3 below (length v) - do - (let ((entry (aref v i))) - (typecase entry - (list (checkit (car entry))) - (function (checkit entry)) - (vector - (sb-int:dovector (entry entry) - (checkit (if (listp entry) (car entry) entry)))))))))) + (sb-lockless:so-maplist + (lambda (node) + (dolist (f (sb-int:ensure-list (sb-lockless:so-data node))) + (checkit (if (functionp f) f (sb-kernel:value-cell-ref f))))) + sb-impl::**finalizer-store**))) (defvar *fds*) (defun make-streams () diff --git a/tests/finalize.impure.lisp b/tests/finalize.impure.lisp index 85b5cfb35..d3c527dd7 100644 --- a/tests/finalize.impure.lisp +++ b/tests/finalize.impure.lisp @@ -71,17 +71,13 @@ (with-test (:name :finalizers-dont-nest-garbage-collections) (assert (<= *maxdepth* 1))) -;;; Regardless of anything else, check representational invariants. -;;; - each ID in the id-recycle-list is not a value in the hash-table -;;; - each value in the hash-table is not in the id-recycle-list -(with-test (:name :finalizer-id-uniqueness) - (let* ((hash-table (elt sb-impl::**finalizer-store** 1)) - (used-ids (loop for v being each hash-value of hash-table - collect v)) - (available-ids (cdr (elt sb-impl::**finalizer-store** 0)))) - (assert (null (intersection used-ids available-ids))))) - (with-test (:name :finalizers-ran) + ;; Finalizers won't have run for keys needing to be rehashed. + (unless (null sb-impl::*finalizer-rehashlist*) + (format t "~&::: INFO: rehashing finalizer store~%") + (sb-impl::finalizers-rehash) + (gc) + (sb-impl::run-pending-finalizers)) ;; expect that 97% of the finalizers ran (assert (>= *count* (* *n-finalized-things* 97/100))) #+gencgc @@ -97,12 +93,20 @@ (setq *weak-pointers* (delete-if (lambda (x) (null (weak-pointer-value x))) *weak-pointers*)) - (let ((hash-table (elt sb-impl::**finalizer-store** 1))) - (loop for k being each hash-key of hash-table - when (and (symbolp k) (not (symbol-package k))) - do (assert (find k *weak-pointers* :key #'weak-pointer-value))) - (dolist (wp *weak-pointers*) - (assert (gethash (weak-pointer-value wp) hash-table))))) + (let ((solist sb-impl::**finalizer-store**)) + (sb-lockless:so-maplist + (lambda (node) + (let ((k (sb-sys:without-gcing (sb-impl::finalizer-object node)))) + (when (and (symbolp k) (not (symbol-package k))) + (assert (find k *weak-pointers* :key #'weak-pointer-value))))) + solist) + (sb-sys:without-gcing + (dolist (wp *weak-pointers*) + (let ((addr (sb-kernel:%make-lisp-obj + (logandc2 (sb-kernel:get-lisp-obj-address + (weak-pointer-value wp)) + sb-vm:lowtag-mask)))) + (assert (sb-lockless:so-find solist addr))))))) ;;; A super-smart GC and/or compiler might prove that the object passed to ;;; FINALIZE is instantly garbage. Like maybe (FINALIZE (CONS 1 2) 'somefun) diff --git a/tests/gc.impure.lisp b/tests/gc.impure.lisp index e9a6b8b0c..8e1f19426 100644 --- a/tests/gc.impure.lisp +++ b/tests/gc.impure.lisp @@ -105,7 +105,7 @@ ;; but seems like it'll be OK for a while. ;; I see only 4 weak pointers in the baseline image. ;; Really we could just assert /= 1000. - (assert (< (length l) 15)))) + (assert (< (length l) 60)))) ;; check that WITHOUT-INTERRUPTS doesn't block SIG_STOP_FOR_GC (with-test (:name :gc-without-interrupts diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index 6cb50e8b2..1f7414b28 100644 --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -198,11 +198,12 @@ `(sb-c::*code-serialno* sb-c::*compile-elapsed-time* sb-c::*compile-file-elapsed-time* + sb-impl::*finalizer-rehashlist* + sb-impl::*finalizers-triggered* sb-impl::*package-names-cookie* sb-impl::*available-buffers* sb-impl::*token-buf-pool* sb-impl::*user-hash-table-tests* - sb-impl::**finalizer-store** sb-impl::*pn-dir-table* sb-impl::*pn-table* sb-vm::*immobile-codeblob-tree*