mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Speed up FINALIZE and CANCEL-FINALIZATION w/ many threads
This replaces the usual hash-table with a new storage representation that is almost always lockfree, and removes all complexity around assigning a unique ID to each finalized object. The ugly hack in cull_weak_hash_table_bucket() is no more. As the benchmark shows, with 4 threads we can create finalizers about 3x faster at the cost of about 1.5x more memory. Fixes lp#1998064 where finalizers are concerned, but if the bug exists more generally, this doesn't do anything for it.
This commit is contained in:
Douglas Katzman
parent
1218556a86
commit
f16af319fa
41
benchmarks/finalize.lisp
Normal file
41
benchmarks/finalize.lisp
Normal file
|
|
@ -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
|
||||
|#
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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 "<triggered-finalizer>~%"))))
|
||||
(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.
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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*
|
||||
|
|
|
|||
Loading…
Reference in a new issue