X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=7fe8491f425e000feec1c7873d25c9345d3299a1;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=97bb828be136ef1b6ce38f0b0f46234ed2393074;hpb=1ca4f69009204caee2484161e6eb89fa6c5fd3f6;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 97bb828..7fe8491 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -181,8 +181,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; lookup machinery. (defvar *standard-classes* + ;; KLUDGE: order matters! finding effective slot definitions + ;; involves calling slot-definition-name, and we need to do that to + ;; break metacycles, so STANDARD-EFFECTIVE-SLOT-DEFINITION must + ;; precede STANDARD-DIRECT-SLOT-DEFINITION in this list, at least + ;; until ACCESSES-STANDARD-CLASS-SLOT-P is generalized '(standard-method standard-generic-function standard-class - standard-effective-slot-definition)) + standard-effective-slot-definition standard-direct-slot-definition)) (defvar *standard-slot-locations* (make-hash-table :test 'equal)) @@ -224,6 +229,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (standard-slot-value slotd slot-name *the-class-standard-effective-slot-definition*)) +(defun standard-slot-value/dslotd (slotd slot-name) + (standard-slot-value slotd slot-name + *the-class-standard-direct-slot-definition*)) + (defun standard-slot-value/class (class slot-name) (standard-slot-value class slot-name *the-class-standard-class*)) @@ -272,10 +281,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (:include dfun-info) (:copier nil))) -(defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ()) - (:include dfun-info) - (:copier nil))) - (defstruct (dispatch (:constructor dispatch-dfun-info ()) (:include dfun-info) (:copier nil))) @@ -674,7 +679,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (make-dispatch-dfun gf)) (defun update-dispatch-dfuns () - (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) + (dolist (gf (gfs-of-type '(dispatch))) (dfun-update gf #'make-dispatch-dfun))) (defun make-final-ordinary-dfun-cache @@ -732,71 +737,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) -;;; This variable is used for controlling the load-time effective -;;; method precomputation: precomputation will only be done for emfs -;;; with fewer than methods than this value. This value has -;;; traditionally been NIL on SBCL (meaning that precomputation will -;;; always be done) but that makes method loading O(n^2). Use a small -;;; value for now, to flush out any possible problems that doing a -;;; limited amount of precomputation might cause. If none appear, we -;;; might change it to a larger value later. -- JES, 2006-12-01 -(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*)) -(defvar *max-emf-precomputation-methods* 1) - -(defun finalize-specializers (gf) - (let ((methods (generic-function-methods gf))) - (when (or (null *max-emf-precomputation-methods*) - (<= (length methods) *max-emf-precomputation-methods*)) - (let ((all-finalized t)) - (dolist (method methods all-finalized) - (dolist (specializer (method-specializers method)) - (when (and (classp specializer) - (not (class-finalized-p specializer))) - (if (class-has-a-forward-referenced-superclass-p specializer) - (setq all-finalized nil) - (finalize-inheritance specializer))))))))) - (defun make-initial-dfun (gf) - (let ((initial-dfun - #'(lambda (&rest args) - (initial-dfun gf args)))) + (let ((initial-dfun #'(lambda (&rest args) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) - (cond - ((and (eq **boot-state** 'complete) - (not (finalize-specializers gf))) - (values initial-dfun nil (initial-dfun-info))) - ((and (eq **boot-state** 'complete) - (compute-applicable-methods-emf-std-p gf)) - (let* ((caching-p (use-caching-dfun-p gf)) - ;; KLUDGE: the only effect of this (when - ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is) - ;; is to signal an error when we try to add methods - ;; with the wrong qualifiers to a generic function. - (classes-list (precompute-effective-methods - gf caching-p - (not *lazy-dfun-compute-p*)))) - (if *lazy-dfun-compute-p* - (cond ((use-dispatch-dfun-p gf caching-p) - (values initial-dfun - nil - (initial-dispatch-dfun-info))) - (caching-p - (insure-caching-dfun gf) - (values initial-dfun nil (initial-dfun-info))) - (t - (values initial-dfun nil (initial-dfun-info)))) - (make-final-dfun-internal gf classes-list)))) - (t - (let ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (type nil)) - (if (and (gf-precompute-dfun-and-emf-p arg-info) - (setq type (final-accessor-dfun-type gf))) - (if *early-p* - (values (make-early-accessor gf type) nil nil) - (make-final-accessor-dfun gf type)) - (values initial-dfun nil (initial-dfun-info)))))) + (if (eq **boot-state** 'complete) + (values initial-dfun nil (initial-dfun-info)) + (let ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (type nil)) + (if (and (gf-precompute-dfun-and-emf-p arg-info) + (setq type (final-accessor-dfun-type gf))) + (if *early-p* + (values (make-early-accessor gf type) nil nil) + (make-final-accessor-dfun gf type)) + (values initial-dfun nil (initial-dfun-info))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) @@ -904,7 +859,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (cond ((null methods) (values #'(lambda (&rest args) - (apply #'no-applicable-method gf args)) + (call-no-applicable-method gf args)) nil (no-methods-dfun-info))) ((setq type (final-accessor-dfun-type gf)) @@ -1161,17 +1116,32 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; object of the slot accessed, and ACCESSOR-TYPE is one of the symbols ;;; READER or WRITER describing the slot access. (defun accesses-standard-class-slot-p (gf) - (flet ((standard-class-slot-access (gf class) - (loop with gf-name = (standard-slot-value/gf gf 'name) - for slotd in (standard-slot-value/class class 'slots) - ;; FIXME: where does BOUNDP fit in here? Is it - ;; relevant? - as readers = (standard-slot-value/eslotd slotd 'readers) - as writers = (standard-slot-value/eslotd slotd 'writers) - if (member gf-name readers :test #'equal) - return (values slotd 'reader) - else if (member gf-name writers :test #'equal) - return (values slotd 'writer)))) + (labels + ((all-dslotds (class &aux done) + (labels ((all-dslotds-aux (class) + (if (or (member class done) (not (eq (class-of class) *the-class-standard-class*))) + nil + (progn + (push class done) + (append (standard-slot-value/class class 'direct-slots) + (mapcan #'(lambda (c) + (copy-list (all-dslotds-aux c))) + (standard-slot-value/class class 'direct-superclasses))))))) + (all-dslotds-aux class))) + (standard-class-slot-access (gf class) + + (loop with gf-name = (standard-slot-value/gf gf 'name) + with eslotds = (standard-slot-value/class class 'slots) + with dslotds = (all-dslotds class) + for dslotd in dslotds + as readers = (standard-slot-value/dslotd dslotd 'readers) + as writers = (standard-slot-value/dslotd dslotd 'writers) + as name = (standard-slot-value/dslotd dslotd 'name) + as eslotd = (find name eslotds :key (lambda (x) (standard-slot-value/eslotd x 'name))) + if (member gf-name readers :test #'equal) + return (values eslotd 'reader) + else if (member gf-name writers :test #'equal) + return (values eslotd 'writer)))) (dolist (class-name *standard-classes*) (let ((class (find-class class-name))) (multiple-value-bind (slotd accessor-type) @@ -1217,6 +1187,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values-internal (accessor-type accessor-class methods) + (unless accessor-class + (return-from accessor-values-internal (values nil nil))) (dolist (meth methods) (when (if (consp meth) (early-method-qualifiers meth) @@ -1224,31 +1196,26 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return-from accessor-values-internal (values nil nil)))) (let* ((meth (car methods)) (early-p (not (eq **boot-state** 'complete))) - (slot-name (when accessor-class - (if (consp meth) - (and (early-method-standard-accessor-p meth) - (early-method-standard-accessor-slot-name meth)) - (and (member *the-class-standard-object* - (if early-p - (early-class-precedence-list - accessor-class) - (class-precedence-list - accessor-class)) - :test #'eq) - (accessor-method-p meth) - (accessor-method-slot-name meth))))) - (slotd (and accessor-class - (if early-p - (dolist (slot (early-class-slotds accessor-class) nil) - (when (eql slot-name - (early-slot-definition-name slot)) - (return slot))) - (find-slot-definition accessor-class slot-name))))) + (slot-name + (cond + ((and (consp meth) + (early-method-standard-accessor-p meth)) + (early-method-standard-accessor-slot-name meth)) + ((and (accessor-method-p meth) + (member *the-class-standard-object* + (if early-p + (early-class-precedence-list accessor-class) + (class-precedence-list accessor-class)))) + (accessor-method-slot-name meth)) + (t (return-from accessor-values-internal (values nil nil))))) + (slotd (if early-p + (dolist (slot (early-class-slotds accessor-class) nil) + (when (eql slot-name (early-slot-definition-name slot)) + (return slot))) + (find-slot-definition accessor-class slot-name)))) (when (and slotd - (or early-p - (slot-accessor-std-p slotd accessor-type)) - (or early-p - (not (safe-p accessor-class)))) + (or early-p (slot-accessor-std-p slotd accessor-type)) + (or early-p (not (safe-p accessor-class)))) (values (if early-p (early-slot-definition-location slotd) (slot-definition-location slotd)) @@ -1464,9 +1431,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; CMUCL comment: used only in map-all-orders (defun class-might-precede-p (class1 class2) - (if (not *in-precompute-effective-methods-p*) - (not (member class1 (cdr (class-precedence-list class2)) :test #'eq)) - (class-can-precede-p class1 class2))) + (not (member class1 (cdr (class-precedence-list class2)) :test #'eq))) (defun compute-precedence (lambda-list nreq argument-precedence-order) (if (null argument-precedence-order) @@ -1497,7 +1462,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; if we can finalize an unfinalized class, then do so (when (and (not (class-finalized-p class)) - (not (class-has-a-forward-referenced-superclass-p class))) + (not (class-has-a-forward-referenced-superclass-p class)) + (not (class-has-a-cpl-protocol-violation-p class))) (finalize-inheritance class) (class-precedence-list class))) @@ -1553,7 +1519,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((pred (memq specl (cpl-or-nil type)))) (values pred (or pred - (if (not *in-precompute-effective-methods-p*) + (if (not *in-*subtypep*) ;; classes might get common subclass (superclasses-compatible-p specl type) ;; worry only about existing classes @@ -1635,7 +1601,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 nil)) ;;; Not synchronized, as all the uses we have for it are multiple ones -;;; and need WITH-LOCKED-HASH-TABLE in any case. +;;; and need WITH-LOCKED-SYSTEM-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? @@ -1646,7 +1612,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun flush-effective-method-cache (generic-function) (let ((cache *effective-method-cache*)) - (with-locked-hash-table (cache) + (with-locked-system-table (cache) (dolist (method (generic-function-methods generic-function)) (remhash method cache))))) @@ -1665,18 +1631,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (all-sorted-p t) function-p) (if (null methods) - (if function-p - (lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(lambda (&rest args) - (apply #'no-applicable-method gf args))) - (lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - (lambda (&rest args) - (apply #'no-applicable-method gf args)))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (lambda (&rest args) + (call-no-applicable-method gf args))) (let* ((key (car methods)) (ht *effective-method-cache*) - (ht-value (with-locked-hash-table (ht) + (ht-value (with-locked-system-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 @@ -1761,10 +1722,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; 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) @@ -1773,7 +1730,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; 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)))))) + (sb-thread::call-with-recursive-system-lock #'update lock)))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil)