X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=5532c12f1f9d653285195be9e00c4591e5062bfd;hb=ed891a4fd882d1b9fe066ab14bcf2107aea95baa;hp=3b02ee4586c00d672f6b9849ddbbd4f6b844dc24;hpb=62f25b3b18b66ae67d555ca8a05026dbf03d89e1;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3b02ee4..5532c12 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -260,8 +260,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; This is the most general case. In this case, the accessor ;;; generic function has seen more than one class of argument and ;;; more than one slot index. A cache vector stores the wrappers -;;; and corresponding slot indexes. Because each cache line is -;;; more than one element long, a cache lock count is used. +;;; and corresponding slot indexes. + (defstruct (dfun-info (:constructor nil) (:copier nil)) (cache nil)) @@ -1280,8 +1280,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (writer (cadr specializers)))) (specl-cpl (if early-p (early-class-precedence-list specl) - (and (class-finalized-p specl) - (class-precedence-list specl)))) + (when (class-finalized-p specl) + (class-precedence-list specl)))) (so-p (member *the-class-standard-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) @@ -1296,17 +1296,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; all of its subclasses. If either SPECL or one of the subclasses ;; is not a standard-class, bail out. (labels ((aux (class) - ;; FIND-SLOT-DEFINITION might not be defined yet - (let ((slotd (find-if (lambda (x) - (eq (sb-pcl::slot-definition-name x) - slot-name)) - (sb-pcl::class-slots class)))) + (let ((slotd (find-slot-definition class slot-name))) (when slotd - (unless (or early-p - (slot-accessor-std-p slotd type)) + (unless (or early-p (slot-accessor-std-p slotd type)) (return-from make-accessor-table nil)) (push (cons specl slotd) (gethash class table)))) (dolist (subclass (sb-pcl::class-direct-subclasses class)) + (unless (class-finalized-p subclass) + (return-from make-accessor-table nil)) (aux subclass)))) (aux specl)))) (maphash (lambda (class specl+slotd-list) @@ -1416,9 +1413,17 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (t specl2))) (class-eq (case (car type2) (eql specl2) + ;; FIXME: This says that all CLASS-EQ + ;; specializers are equally specific, which + ;; is fair enough because only one CLASS-EQ + ;; specializer can ever be appliable. If + ;; ORDER-SPECIALIZERS should only ever be + ;; called on specializers from applicable + ;; methods, we could replace this with a BUG. (class-eq nil) (class type1))) (eql (case (car type2) + ;; similarly. (eql nil) (t specl1)))))))) @@ -1635,12 +1640,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 root))) nil)) -;;; FIXME: Needs a lock. +;;; Not synchronized, as all the uses we have for it are multiple ones +;;; and need WITH-LOCKED-HASH-TABLE in any case. +;;; +;;; FIXME: Is it really more efficient to store this stuff in a global +;;; table instead of having a slot in each method? +;;; +;;; FIXME: This table also seems to contain early methods, which should +;;; presumably be dropped during the bootstrap. (defvar *effective-method-cache* (make-hash-table :test 'eq)) (defun flush-effective-method-cache (generic-function) - (dolist (method (generic-function-methods generic-function)) - (remhash method *effective-method-cache*))) + (let ((cache *effective-method-cache*)) + (with-locked-hash-table (cache) + (dolist (method (generic-function-methods generic-function)) + (remhash method cache))))) (defun get-secondary-dispatch-function (gf methods types &optional method-alist wrappers) @@ -1656,7 +1670,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 all-applicable-p (all-sorted-p t) function-p) - (if (null methods) + (if (null methods) (if function-p (lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) @@ -1667,9 +1681,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (lambda (&rest args) (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) - (ht-value (or (gethash key *effective-method-cache*) - (setf (gethash key *effective-method-cache*) - (cons nil nil))))) + (ht *effective-method-cache*) + (ht-value (with-locked-hash-table (ht) + (or (gethash key ht) + (setf (gethash key ht) (cons nil nil)))))) (if (and (null (cdr methods)) all-applicable-p ; the most common case (null method-alist-p) wrappers-p (not function-p)) (or (car ht-value) @@ -1721,22 +1736,50 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return t))))) (defun update-dfun (generic-function &optional dfun cache info) - ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can - ;; access it, and so that it's there for eg. future cache updates. - ;; - ;; How atomic wrt. SET-FUNCALLABLE-INSTANCE-FUN does this need to - ;; be? - (set-dfun generic-function dfun cache info) - (let* ((early-p (early-gf-p generic-function)) - (dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function)))) - (set-funcallable-instance-function generic-function dfun) - (let ((gf-name (if early-p - (!early-gf-name generic-function) - (generic-function-name generic-function)))) - (set-fun-name generic-function gf-name) - dfun))) + (let ((early-p (early-gf-p generic-function))) + (flet ((update () + ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can + ;; access it, and so that it's there for eg. future cache updates. + (set-dfun generic-function dfun cache info) + (let ((dfun (if early-p + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function)))) + (set-funcallable-instance-function generic-function dfun) + (let ((gf-name (if early-p + (!early-gf-name generic-function) + (generic-function-name generic-function)))) + (set-fun-name generic-function gf-name) + dfun)))) + ;; This needs to be atomic per generic function, consider: + ;; 1. T1 sets dfun-state to S1 and computes discr. fun using S1 + ;; 2. T2 sets dfun-state to S2 and computes discr. fun using S2 + ;; 3. T2 sets fin + ;; 4. T1 sets fin + ;; Oops: now dfun-state and fin don't match! Since just calling + ;; a generic can cause the dispatch function to be updated we + ;; need a lock here. + ;; + ;; We need to accept recursion, because PCL is nasty and twisty, + ;; and we need to disable interrupts because it would be bad if + ;; we updated the DFUN-STATE but not the dispatch function. + ;; + ;; This is sufficient, because all the other calls to SET-DFUN + ;; are part of this same code path (done while the lock is held), + ;; which we AVER. + ;; + ;; FIXME: When our mutexes are smart about the need to wake up + ;; sleepers we can put a mutex here instead -- but in the meantime + ;; we use a spinlock to avoid a syscall for every dfun update. + ;; + ;; KLUDGE: No need to lock during bootstrap. + (if early-p + (update) + (let ((lock (gf-lock generic-function))) + ;; FIXME: GF-LOCK is a generic function... Are there cases + ;; where we can end up in a metacircular loop here? In + ;; case there are, better fetch it while interrupts are + ;; still enabled... + (sb-thread::call-with-recursive-system-spinlock #'update lock)))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) @@ -1746,7 +1789,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; I'm aware of, but they look like they might be useful for ;;; debugging or performance tweaking or something, so I've just ;;; commented them out instead of deleting them. -- WHN 2001-03-28 -#| (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (a (assq sym *dfun-list*))) @@ -1809,7 +1851,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (format t "~% ~S~%" (caddr type+count+sizes))) *dfun-count*) (values)) -|# +||# (defun gfs-of-type (type) (unless (consp type) (setq type (list type)))