From 617d4fa1db5a4a11564e7c59bfb684c7eb25633d Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 8 Jun 2007 20:38:21 +0000 Subject: [PATCH] 1.0.6.38: thread and interrupt safe ADD/REMOVE-METHOD * ADD/REMOVE-METHOD need to grab the GF lock and disable interrupts. * ADD/REMOVE-DIRECT-METHOD, and SPECIALIZER-DIRECT-GENERIC-FUNCTIONS need a lock as well, but instead of adding per-specializer lock just use one global one: contention should be minimal here. * INTERN-EQL-SPECIALIZER needs a lock. * Fix non-threaded build. * Delete dead NAME variables from ADD/REMOVE-METHOD. * Tests. --- NEWS | 2 + src/code/fd-stream.lisp | 3 +- src/code/thread.lisp | 16 +++- src/code/timer.lisp | 2 - src/pcl/defs.lisp | 12 ++- src/pcl/methods.lisp | 209 +++++++++++++++++++++++-------------------- src/pcl/std-class.lisp | 92 +++++++++++++------ tests/clos-cache.impure.lisp | 10 ++- version.lisp-expr | 2 +- 9 files changed, 210 insertions(+), 138 deletions(-) diff --git a/NEWS b/NEWS index 69f3111ac..b50e994f5 100644 --- a/NEWS +++ b/NEWS @@ -25,6 +25,8 @@ changes in sbcl-1.0.7 relative to sbcl-1.0.6: * bug fix: generic function dispatch function updating is now thread and interrupt safe (in the sense that the known issues have been fixed.) + * bug fix: ADD/REMOVE-METHOD is now thread and interrupt safe. + * bug fix: interning EQL-specializers is now thread and interrupt safe. changes in sbcl-1.0.6 relative to sbcl-1.0.5: * new contrib: sb-cover, an experimental code coverage tool, is included diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 50665f71a..d87be01ff 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -18,9 +18,8 @@ (defvar *available-buffers* () #!+sb-doc "List of available buffers. Each buffer is an sap pointing to - bytes-per-buffer of memory.") +bytes-per-buffer of memory.") -#!+sb-thread (defvar *available-buffers-mutex* (sb!thread:make-mutex :name "lock for *AVAILABLE-BUFFERS*") #!+sb-doc diff --git a/src/code/thread.lisp b/src/code/thread.lisp index f0c51103e..7cf49b8e4 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -37,6 +37,12 @@ and the mutex is in use, sleep until it is available" ,value ,wait-p)) +(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing) &body body) + `(call-with-system-mutex + (lambda () ,@body) + ,mutex + ,without-gcing)) + (sb!xc:defmacro with-recursive-lock ((mutex) &body body) #!+sb-doc "Acquires MUTEX for the dynamic scope of BODY. Within that scope @@ -52,6 +58,13 @@ provided the default value is used for the mutex." (lambda () ,@body) ,spinlock)) +(sb!xc:defmacro with-recursive-system-spinlock ((spinlock &key without-gcing) + &body body) + `(call-with-recursive-system-spinlock + (lambda () ,@body) + ,spinlock + ,without-gcing)) + (sb!xc:defmacro with-spinlock ((spinlock) &body body) `(call-with-spinlock (lambda () ,@body) @@ -72,7 +85,8 @@ provided the default value is used for the mutex." (without-interrupts (funcall function)))) - (defun call-with-system-spinlock (function lock &optional without-gcing-p) + (defun call-with-recursive-system-spinlock (function lock + &optional without-gcing-p) (declare (ignore lock) (function function)) (if without-gcing-p diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 7862876e5..774ee2b4a 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -135,8 +135,6 @@ ;; FUNCTION until the other is called, from when it does nothing. (let ((mutex (sb!thread:make-mutex)) (cancelled-p nil)) - #!-sb-thread - (declare (ignore mutex)) (list #'(lambda () (sb!thread:with-recursive-lock (mutex) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 3bf72dbe3..882a37faf 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -571,10 +571,16 @@ (defvar *eql-specializer-table* (make-hash-table :test 'eql)) +(defvar *eql-specializer-table-lock* + (sb-thread::make-spinlock :name "EQL-specializer table lock")) + (defun intern-eql-specializer (object) - (or (gethash object *eql-specializer-table*) - (setf (gethash object *eql-specializer-table*) - (make-instance 'eql-specializer :object object)))) + ;; Need to lock, so that two threads don't get non-EQ specializers + ;; for an EQL object. + (sb-thread::with-spinlock (*eql-specializer-table-lock*) + (or (gethash object *eql-specializer-table*) + (setf (gethash object *eql-specializer-table*) + (make-instance 'eql-specializer :object object))))) (defclass class (dependent-update-mixin definition-source-mixin diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 954619a5c..36fb2c036 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -230,6 +230,7 @@ :generic-function-class (class-of existing-gf)) (ensure-generic-function generic-function-name))) (proto (method-prototype-for-gf generic-function-name))) + ;; FIXME: Destructive modification of &REST list. (setf (getf (getf other-initargs 'plist) :name) (make-method-spec generic-function qualifiers specializers)) (let ((new (apply #'make-instance (class-of proto) @@ -448,107 +449,119 @@ (= a-nopt b-nopt) (eq (or a-keyp a-restp) (or b-keyp b-restp))))))) - (let* ((name (generic-function-name generic-function)) - (qualifiers (method-qualifiers method)) - (specializers (method-specializers method)) - (existing (get-method generic-function - qualifiers - specializers - nil))) - - ;; If there is already a method like this one then we must get - ;; rid of it before proceeding. Note that we call the generic - ;; function REMOVE-METHOD to remove it rather than doing it in - ;; some internal way. - (when (and existing (similar-lambda-lists-p existing method)) - (remove-method generic-function existing)) - - ;; KLUDGE: We have a special case here, as we disallow - ;; specializations of the NEW-VALUE argument to (SETF - ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is - ;; the optimizing function here: it precomputes the effective - ;; method, assuming that there is no dispatch to be done on - ;; the new-value argument. - (when (and (eq generic-function #'(setf slot-value-using-class)) - (not (eq *the-class-t* (first specializers)))) - (error 'new-value-specialization - :method method)) - - (setf (method-generic-function method) generic-function) - (pushnew method (generic-function-methods generic-function)) - (dolist (specializer specializers) - (add-direct-method specializer method)) - - ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for - ;; detecting attempts to add methods with incongruent lambda - ;; lists. However, according to Gerd Moellmann on cmucl-imp, - ;; it also depends on the new method already having been added - ;; to the generic function. Therefore, we need to remove it - ;; again on error: - (let ((remove-again-p t)) - (unwind-protect - (progn - (set-arg-info generic-function :new-method method) - (setq remove-again-p nil)) - (when remove-again-p - (remove-method generic-function method)))) - - ;; KLUDGE II: ANSI saith that it is not an error to add a - ;; method with invalid qualifiers to a generic function of the - ;; wrong kind; it's only an error at generic function - ;; invocation time; I dunno what the rationale was, and it - ;; sucks. Nevertheless, it's probably a programmer error, so - ;; let's warn anyway. -- CSR, 2003-08-20 - (let ((mc (generic-function-method-combination generic-functioN))) - (cond - ((eq mc *standard-method-combination*) - (when (and qualifiers - (or (cdr qualifiers) - (not (memq (car qualifiers) - '(:around :before :after))))) - (warn "~@" - method qualifiers))) - ((short-method-combination-p mc) - (let ((mc-name (method-combination-type-name mc))) - (when (or (null qualifiers) - (cdr qualifiers) - (and (neq (car qualifiers) :around) - (neq (car qualifiers) mc-name))) - (warn "~@" - mc-name method qualifiers)))))) - - (unless skip-dfun-update-p - (update-ctors 'add-method - :generic-function generic-function - :method method) - (update-dfun generic-function)) - (map-dependents generic-function - (lambda (dep) - (update-dependent generic-function - dep 'add-method method))) - generic-function))) + (let ((lock (gf-lock generic-function))) + ;; HANDLER-CASE takes care of releasing the lock and enabling + ;; interrupts before going forth with the error. + (handler-case + ;; System lock because interrupts need to be disabled as + ;; well: it would be bad to unwind and leave the gf in an + ;; inconsistent state. + (sb-thread::with-recursive-system-spinlock (lock) + (let* ((qualifiers (method-qualifiers method)) + (specializers (method-specializers method)) + (existing (get-method generic-function + qualifiers + specializers + nil))) + + ;; If there is already a method like this one then we must get + ;; rid of it before proceeding. Note that we call the generic + ;; function REMOVE-METHOD to remove it rather than doing it in + ;; some internal way. + (when (and existing (similar-lambda-lists-p existing method)) + (remove-method generic-function existing)) + + ;; KLUDGE: We have a special case here, as we disallow + ;; specializations of the NEW-VALUE argument to (SETF + ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is + ;; the optimizing function here: it precomputes the effective + ;; method, assuming that there is no dispatch to be done on + ;; the new-value argument. + (when (and (eq generic-function #'(setf slot-value-using-class)) + (not (eq *the-class-t* (first specializers)))) + (error 'new-value-specialization :method method)) + + (setf (method-generic-function method) generic-function) + (pushnew method (generic-function-methods generic-function)) + (dolist (specializer specializers) + (add-direct-method specializer method)) + + ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for + ;; detecting attempts to add methods with incongruent lambda + ;; lists. However, according to Gerd Moellmann on cmucl-imp, + ;; it also depends on the new method already having been added + ;; to the generic function. Therefore, we need to remove it + ;; again on error: + (let ((remove-again-p t)) + (unwind-protect + (progn + (set-arg-info generic-function :new-method method) + (setq remove-again-p nil)) + (when remove-again-p + (remove-method generic-function method)))) + + ;; KLUDGE II: ANSI saith that it is not an error to add a + ;; method with invalid qualifiers to a generic function of the + ;; wrong kind; it's only an error at generic function + ;; invocation time; I dunno what the rationale was, and it + ;; sucks. Nevertheless, it's probably a programmer error, so + ;; let's warn anyway. -- CSR, 2003-08-20 + (let ((mc (generic-function-method-combination generic-functioN))) + (cond + ((eq mc *standard-method-combination*) + (when (and qualifiers + (or (cdr qualifiers) + (not (memq (car qualifiers) + '(:around :before :after))))) + (warn "~@" + method qualifiers))) + ((short-method-combination-p mc) + (let ((mc-name (method-combination-type-name mc))) + (when (or (null qualifiers) + (cdr qualifiers) + (and (neq (car qualifiers) :around) + (neq (car qualifiers) mc-name))) + (warn "~@" + mc-name method qualifiers)))))) + + (unless skip-dfun-update-p + (update-ctors 'add-method + :generic-function generic-function + :method method) + (update-dfun generic-function)) + (map-dependents generic-function + (lambda (dep) + (update-dependent generic-function + dep 'add-method method))))) + (serious-condition (c) + (error c))))) + generic-function) (defun real-remove-method (generic-function method) (when (eq generic-function (method-generic-function method)) - (let* ((name (generic-function-name generic-function)) - (specializers (method-specializers method)) - (methods (generic-function-methods generic-function)) - (new-methods (remove method methods))) - (setf (method-generic-function method) nil) - (setf (generic-function-methods generic-function) new-methods) - (dolist (specializer (method-specializers method)) - (remove-direct-method specializer method)) - (set-arg-info generic-function) - (update-ctors 'remove-method - :generic-function generic-function - :method method) - (update-dfun generic-function) - (map-dependents generic-function - (lambda (dep) - (update-dependent generic-function - dep 'remove-method method))))) + (let ((lock (gf-lock generic-function))) + ;; System lock because interrupts need to be disabled as well: + ;; it would be bad to unwind and leave the gf in an inconsistent + ;; state. + (sb-thread::with-recursive-system-spinlock (lock) + (let* ((specializers (method-specializers method)) + (methods (generic-function-methods generic-function)) + (new-methods (remove method methods))) + (setf (method-generic-function method) nil + (generic-function-methods generic-function) new-methods) + (dolist (specializer (method-specializers method)) + (remove-direct-method specializer method)) + (set-arg-info generic-function) + (update-ctors 'remove-method + :generic-function generic-function + :method method) + (update-dfun generic-function) + (map-dependents generic-function + (lambda (dep) + (update-dependent generic-function + dep 'remove-method method))))))) generic-function) (defun compute-applicable-methods-function (generic-function arguments) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 8721509ae..8b9b93915 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -173,15 +173,40 @@ ;;; In each case, we maintain one value which is a cons. The car is the list ;;; methods. The cdr is a list of the generic functions. The cdr is always ;;; computed lazily. + +;;; This needs to be used recursively, in case a non-trivial user +;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another +;;; function using the same lock. +(defvar *specializer-lock* (sb-thread::make-spinlock :name "Specializer lock")) + +(defmethod add-direct-method :around ((specializer specializer) method) + ;; All the actions done under this lock are done in an order + ;; that is safe to unwind at any point. + (sb-thread::with-recursive-spinlock (*specializer-lock*) + (call-next-method))) + +(defmethod remove-direct-method :around ((specializer specializer) method) + ;; All the actions done under this lock are done in an order + ;; that is safe to unwind at any point. + (sb-thread::with-recursive-spinlock (*specializer-lock*) + (call-next-method))) + (defmethod add-direct-method ((specializer class) (method method)) - (with-slots (direct-methods) specializer - (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH - (cdr direct-methods) ())) + (let ((cell (slot-value specializer 'direct-methods))) + ;; We need to first smash the CDR, because a parallel read may + ;; be in progress, and because if an interrupt catches us we + ;; need to have a consistent state. + (setf (cdr cell) () + (car cell) (adjoin method (car cell)))) method) + (defmethod remove-direct-method ((specializer class) (method method)) - (with-slots (direct-methods) specializer - (setf (car direct-methods) (remove method (car direct-methods)) - (cdr direct-methods) ())) + (let ((cell (slot-value specializer 'direct-methods))) + ;; We need to first smash the CDR, because a parallel read may + ;; be in progress, and because if an interrupt catches us we + ;; need to have a consistent state. + (setf (cdr cell) () + (car cell) (remove method (car cell)))) method) (defmethod specializer-direct-methods ((specializer class)) @@ -189,15 +214,19 @@ (car direct-methods))) (defmethod specializer-direct-generic-functions ((specializer class)) - (with-slots (direct-methods) specializer - (or (cdr direct-methods) - (setf (cdr direct-methods) - (let (collect) - (dolist (m (car direct-methods)) - ;; the old PCL code used COLLECTING-ONCE which used - ;; #'EQ to check for newness - (pushnew (method-generic-function m) collect :test #'eq)) - (nreverse collect)))))) + (let ((cell (slot-value specializer 'direct-methods))) + ;; If an ADD/REMOVE-METHOD is in progress, no matter: either + ;; we behave as if we got just first or just after -- it's just + ;; for update that we need to lock. + (or (cdr cell) + (sb-thread::with-spinlock (*specializer-lock*) + (setf (cdr cell) + (let (collect) + (dolist (m (car cell)) + ;; the old PCL code used COLLECTING-ONCE which used + ;; #'EQ to check for newness + (pushnew (method-generic-function m) collect :test #'eq)) + (nreverse collect))))))) ;;; This hash table is used to store the direct methods and direct generic ;;; functions of EQL specializers. Each value in the table is the cons. @@ -215,12 +244,17 @@ (let* ((object (specializer-object specializer)) (table (specializer-method-table specializer)) (entry (gethash object table))) + ;; This table is shared between multiple specializers, but + ;; no worries as (at least for the time being) our hash-tables + ;; are thread safe. (unless entry - (setq entry - (setf (gethash object table) - (cons nil nil)))) - (setf (car entry) (adjoin method (car entry)) - (cdr entry) ()) + (setf entry + (setf (gethash object table) (cons nil nil)))) + ;; We need to first smash the CDR, because a parallel read may + ;; be in progress, and because if an interrupt catches us we + ;; need to have a consistent state. + (setf (cdr entry) () + (car entry) (adjoin method (car entry))) method)) (defmethod remove-direct-method ((specializer specializer-with-object) @@ -228,8 +262,11 @@ (let* ((object (specializer-object specializer)) (entry (gethash object (specializer-method-table specializer)))) (when entry - (setf (car entry) (remove method (car entry)) - (cdr entry) ())) + ;; We need to first smash the CDR, because a parallel read may + ;; be in progress, and because if an interrupt catches us we + ;; need to have a consistent state. + (setf (cdr entry) () + (car entry) (remove method (car entry)))) method)) (defmethod specializer-direct-methods ((specializer specializer-with-object)) @@ -242,11 +279,12 @@ (entry (gethash object (specializer-method-table specializer)))) (when entry (or (cdr entry) - (setf (cdr entry) - (let (collect) - (dolist (m (car entry)) - (pushnew (method-generic-function m) collect :test #'eq)) - (nreverse collect))))))) + (sb-thread::with-spinlock (*specializer-lock*) + (setf (cdr entry) + (let (collect) + (dolist (m (car entry)) + (pushnew (method-generic-function m) collect :test #'eq)) + (nreverse collect)))))))) (defun map-specializers (function) (map-all-classes (lambda (class) diff --git a/tests/clos-cache.impure.lisp b/tests/clos-cache.impure.lisp index e7a2971bf..4959a3f8e 100644 --- a/tests/clos-cache.impure.lisp +++ b/tests/clos-cache.impure.lisp @@ -64,9 +64,9 @@ (write-line string))))) (defun test-loop () - (note "/~S waiting for permission to run" sb-thread:*current-thread*) + (note "/~S waiting for permission to run" sb-thread:*current-thread*) (loop until *run-cache-test*) - (note "/~S joining the tundering herd" sb-thread:*current-thread*) + (note "/~S joining the thundering herd" sb-thread:*current-thread*) (handler-case (loop repeat 1024 do (test-cache)) (error (e) @@ -82,8 +82,10 @@ (mapcar #'sb-thread:join-thread threads)) #-sb-thread -(loop repeat 4 - do (test-loop)) +(progn + (setf *run-cache-test* t) + (loop repeat 4 + do (test-loop))) ;;; Check that the test tests what it was supposed to test: the cache. (assert (sb-pcl::cache-p (sb-pcl::gf-dfun-cache #'cache-test))) diff --git a/version.lisp-expr b/version.lisp-expr index 754ab6147..f0503a595 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.6.37" +"1.0.6.38" -- 2.11.4.GIT