: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)
(= 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 "~@<Invalid qualifiers for standard method combination ~
- in method ~S:~2I~_~S.~@:>"
- 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 "~@<Invalid qualifiers for ~S method combination ~
- in method ~S:~2I~_~S.~@:>"
- 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 "~@<Invalid qualifiers for standard method ~
+ combination in method ~S:~2I~_~S.~@:>"
+ 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 "~@<Invalid qualifiers for ~S method combination ~
+ in method ~S:~2I~_~S.~@:>"
+ 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)
\f
(defun compute-applicable-methods-function (generic-function arguments)
;;; 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))
(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)))))))
\f
;;; 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.
(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)
(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))
(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)
projects / sbcl.git / commitdiff