X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=7fe8491f425e000feec1c7873d25c9345d3299a1;hb=961c6bf2eda5d492d5dbb7e275fe4e0931f7adf8;hp=ab34a564d6674be45471917eb925ef0eb93d0334;hpb=5a31671c1093aa155a7832277ebd46766eb7c6e4;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index ab34a56..7fe8491 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -181,24 +181,27 @@ 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)) (defun compute-standard-slot-locations () - (clrhash *standard-slot-locations*) - (dolist (class-name *standard-classes*) - (let ((class (find-class class-name))) - (dolist (slot (class-slots class)) - (setf (gethash (cons class (slot-definition-name slot)) - *standard-slot-locations*) - (slot-definition-location slot)))))) - -;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS -;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS. -(defun maybe-update-standard-class-locations (class) - (when (and (eq *boot-state* 'complete) + (let ((new (make-hash-table :test 'equal))) + (dolist (class-name *standard-classes*) + (let ((class (find-class class-name))) + (dolist (slot (class-slots class)) + (setf (gethash (cons class (slot-definition-name slot)) new) + (slot-definition-location slot))))) + (setf *standard-slot-locations* new))) + +(defun maybe-update-standard-slot-locations (class) + (when (and (eq **boot-state** 'complete) (memq (class-name class) *standard-classes*)) (compute-standard-slot-locations))) @@ -226,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*)) @@ -260,8 +267,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)) @@ -274,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))) @@ -401,7 +404,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (reader 'emit-one-index-readers) (boundp 'emit-one-index-boundps) (writer 'emit-one-index-writers))) - (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) + (cache (or cache (make-cache :key-count 1 :value nil :size 4))) (dfun-info (one-index-dfun-info type index cache))) (declare (type cache cache)) (values @@ -412,19 +415,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))) -(defun make-final-one-index-accessor-dfun (gf type index table) - (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn))) - (make-one-index-accessor-dfun gf type index cache))) - -(defun one-index-limit-fn (nlines) - (default-limit-fn nlines)) - (defun make-n-n-accessor-dfun (gf type &optional cache) (let* ((emit (ecase type (reader 'emit-n-n-readers) (boundp 'emit-n-n-boundps) (writer 'emit-n-n-writers))) - (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) + (cache (or cache (make-cache :key-count 1 :value t :size 2))) (dfun-info (n-n-dfun-info type cache))) (declare (type cache cache)) (values @@ -434,13 +430,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))) -(defun make-final-n-n-accessor-dfun (gf type table) - (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn))) - (make-n-n-accessor-dfun gf type cache))) - -(defun n-n-accessors-limit-fn (nlines) - (default-limit-fn nlines)) - (defun make-checking-dfun (generic-function function &optional cache) (unless cache (when (use-caching-dfun-p generic-function) @@ -457,7 +446,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 function) nil dfun-info)) - (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value nil :size 2))) (dfun-info (checking-dfun-info function cache))) (values (funcall (get-dfun-constructor 'emit-checking metatypes applyp) @@ -468,8 +457,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))))) -(defun make-final-checking-dfun (generic-function function - classes-list new-class) +(defun make-final-checking-dfun (generic-function function classes-list new-class) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq applyp nkeys)) @@ -477,9 +465,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (values (lambda (&rest args) (invoke-emf function args)) nil (default-method-only-dfun-info)) - (let ((cache (make-final-ordinary-dfun-internal - generic-function nil #'checking-limit-fn - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function nil classes-list new-class))) (make-checking-dfun generic-function function cache))))) (defun use-default-method-only-dfun-p (generic-function) @@ -489,11 +476,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (every (lambda (mt) (eq mt t)) metatypes))) (defun use-caching-dfun-p (generic-function) - (some (lambda (method) - (let ((fmf (if (listp method) - (third method) - (safe-method-fast-function method)))) - (method-function-get fmf :slot-name-lists))) + (some (lambda (method) (method-plist-value method :slot-name-lists)) ;; KLUDGE: As of sbcl-0.6.4, it's very important for ;; efficiency to know the type of the sequence argument to ;; quantifiers (SOME/NOTANY/etc.) at compile time, but @@ -504,9 +487,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (early-gf-p generic-function) (early-gf-methods generic-function) (generic-function-methods generic-function))))) - -(defun checking-limit-fn (nlines) - (default-limit-fn nlines)) (defun make-caching-dfun (generic-function &optional cache) (unless cache @@ -519,7 +499,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq)) - (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2))) (dfun-info (caching-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-caching metatypes applyp) @@ -530,14 +510,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 dfun-info)))) (defun make-final-caching-dfun (generic-function classes-list new-class) - (let ((cache (make-final-ordinary-dfun-internal - generic-function t #'caching-limit-fn - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function t classes-list new-class))) (make-caching-dfun generic-function cache))) -(defun caching-limit-fn (nlines) - (default-limit-fn nlines)) - (defun insure-caching-dfun (gf) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info gf) @@ -558,7 +534,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (generic-function-methods gf))) (default '(unknown))) (and (null applyp) - (or (not (eq *boot-state* 'complete)) + (or (not (eq **boot-state** 'complete)) ;; If COMPUTE-APPLICABLE-METHODS is specialized, we ;; can't use this, of course, because we can't tell ;; which methods will be considered applicable. @@ -579,17 +555,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; method has qualifiers, to make sure that emfs are really ;; method functions; see above. (dolist (method methods t) - (when (eq *boot-state* 'complete) + (when (eq **boot-state** 'complete) (when (or (some #'eql-specializer-p (safe-method-specializers method)) (safe-method-qualifiers method)) (return nil))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (safe-method-fast-function method) - (safe-method-function method))) - :constant-value default))) + (let ((value (method-plist-value method :constant-value default))) (when (or (eq value default) (and boolean-values-p (not (member value '(t nil))))) @@ -599,8 +570,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq applyp)) - (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2))) (dfun-info (constant-value-dfun-info cache))) + (declare (type cache cache)) (values (funcall (get-dfun-constructor 'emit-constant-value metatypes) cache @@ -610,15 +582,24 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 dfun-info)))) (defun make-final-constant-value-dfun (generic-function classes-list new-class) - (let ((cache (make-final-ordinary-dfun-internal - generic-function :constant-value #'caching-limit-fn - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function :constant-value classes-list new-class))) (make-constant-value-dfun generic-function cache))) +(defun gf-has-method-with-nonstandard-specializer-p (gf) + (let ((methods (generic-function-methods gf))) + (dolist (method methods nil) + (unless (every (lambda (s) (standard-specializer-p s)) + (method-specializers method)) + (return t))))) + (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) - (when (eq *boot-state* 'complete) + (when (eq **boot-state** 'complete) (unless (or caching-p - (gf-requires-emf-keyword-checks gf)) + (gf-requires-emf-keyword-checks gf) + ;; DISPATCH-DFUN-COST will error if it encounters a + ;; method with a non-standard specializer. + (gf-has-method-with-nonstandard-specializer-p gf)) ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, ;; return NIL if we might ever need to do more than @@ -633,9 +614,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((cdc (caching-dfun-cost gf))) ; fast (> cdc (dispatch-dfun-cost gf cdc)))))) -(defparameter *non-built-in-typep-cost* 1) -(defparameter *structure-typep-cost* 1) -(defparameter *built-in-typep-cost* 0) +(defparameter *non-built-in-typep-cost* 100) +(defparameter *structure-typep-cost* 15) +(defparameter *built-in-typep-cost* 5) ;;; According to comments in the original CMU CL version of PCL, ;;; the cost LIMIT is important to cut off exponential growth for @@ -666,9 +647,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 max-cost-so-far)) #'identity)) -(defparameter *cache-lookup-cost* 1) -(defparameter *wrapper-of-cost* 0) -(defparameter *secondary-dfun-call-cost* 1) +(defparameter *cache-lookup-cost* 30) +(defparameter *wrapper-of-cost* 15) +(defparameter *secondary-dfun-call-cost* 30) (defun caching-dfun-cost (gf) (let ((nreq (get-generic-fun-info gf))) @@ -679,13 +660,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 *secondary-dfun-call-cost* 0)))) -(setq *non-built-in-typep-cost* 100) -(setq *structure-typep-cost* 15) -(setq *built-in-typep-cost* 5) -(setq *cache-lookup-cost* 30) -(setq *wrapper-of-cost* 15) -(setq *secondary-dfun-call-cost* 30) - (declaim (inline make-callable)) (defun make-callable (gf methods generator method-alist wrappers) (let* ((*applicable-methods* methods) @@ -705,21 +679,11 @@ 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 fill-dfun-cache (table valuep nkeys limit-fn &optional cache) - (let ((cache (or cache (get-cache nkeys valuep limit-fn - (+ (hash-table-count table) 3))))) - (maphash (lambda (classes value) - (setq cache (fill-cache cache - (class-wrapper classes) - value))) - table) - cache)) - -(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn - classes-list new-class) +(defun make-final-ordinary-dfun-cache + (generic-function valuep classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (new-class (and new-class @@ -730,8 +694,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 new-class)) (cache (if new-class (copy-cache (gf-dfun-cache generic-function)) - (get-cache nkeys (not (null valuep)) limit-fn 4)))) - (make-emf-cache generic-function valuep cache classes-list new-class))) + (make-cache :key-count nkeys :value (not (null valuep)) + :size 4)))) + (make-emf-cache generic-function valuep cache classes-list new-class))) (defvar *dfun-miss-gfs-on-stack* ()) @@ -772,63 +737,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) -(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*)) -(defvar *max-emf-precomputation-methods* nil) - -(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) @@ -859,8 +782,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ((use-caching-dfun-p gf) (dfun-update gf #'make-caching-dfun)) (t - (dfun-update - gf #'make-checking-dfun + (dfun-update gf #'make-checking-dfun ;; nemf is suitable only for caching, have to do this: (cache-miss-values gf args 'checking)))))) @@ -869,51 +791,47 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (make-final-dfun-internal gf classes-list) (set-dfun gf dfun cache info))) +;;; FIXME: What is this? (defvar *new-class* nil) -(defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) - -(defmacro with-hash-table ((table test) &body forms) - `(let* ((.free. (assoc ',test *free-hash-tables*)) - (,table (if (cdr .free.) - (pop (cdr .free.)) - (make-hash-table :test ',test)))) - (multiple-value-prog1 - (progn ,@forms) - (clrhash ,table) - (push ,table (cdr .free.))))) - -(defmacro with-eq-hash-table ((table) &body forms) - `(with-hash-table (,table eq) ,@forms)) - (defun final-accessor-dfun-type (gf) (let ((methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf)))) (cond ((every (lambda (method) (if (consp method) - (eq *the-class-standard-reader-method* - (early-method-class method)) - (standard-reader-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-reader-method*) + (eq class *the-class-global-reader-method*))) + (or (standard-reader-method-p method) + (global-reader-method-p method)))) methods) 'reader) ((every (lambda (method) (if (consp method) - (eq *the-class-standard-boundp-method* - (early-method-class method)) - (standard-boundp-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-boundp-method*) + (eq class *the-class-global-boundp-method*))) + (or (standard-boundp-method-p method) + (global-boundp-method-p method)))) methods) 'boundp) ((every (lambda (method) (if (consp method) - (eq *the-class-standard-writer-method* - (early-method-class method)) - (standard-writer-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-writer-method*) + (eq class *the-class-global-writer-method*))) + (and + (or (standard-writer-method-p method) + (global-writer-method-p method)) + (not (safe-p + (slot-definition-class + (accessor-method-slot-definition method))))))) methods) 'writer)))) (defun make-final-accessor-dfun (gf type &optional classes-list new-class) - (with-eq-hash-table (table) + (let ((table (make-hash-table :test #'eq))) (multiple-value-bind (table all-index first second size no-class-slots-p) (make-accessor-table gf type table) (if table @@ -925,10 +843,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (w1 (class-wrapper second))) (make-two-class-accessor-dfun gf type w0 w1 all-index))) ((or (integerp all-index) (consp all-index)) - (make-final-one-index-accessor-dfun - gf type all-index table)) + (let ((cache (hash-table-to-cache table :value nil :key-count 1))) + (make-one-index-accessor-dfun gf type all-index cache))) (no-class-slots-p - (make-final-n-n-accessor-dfun gf type table)) + (let ((cache (hash-table-to-cache table :value t :key-count 1))) + (make-n-n-accessor-dfun gf type cache))) (t (make-final-caching-dfun gf classes-list new-class))) (make-final-caching-dfun gf classes-list new-class))))) @@ -940,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)) @@ -964,30 +883,23 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (t (make-final-caching-dfun gf classes-list new-class))))) -(defvar *accessor-miss-history* nil) +(defvar *pcl-misc-random-state* (make-random-state)) (defun accessor-miss (gf new object dfun-info) - (let ((wrapper (wrapper-of object)) - (previous-miss (assq gf *accessor-miss-history*))) - (when (eq wrapper (cdr previous-miss)) - (error "~@" - gf object)) - (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*)) - (ostate (type-of dfun-info)) - (otype (dfun-info-accessor-type dfun-info)) - oindex ow0 ow1 cache - (args (ecase otype - ((reader boundp) (list object)) - (writer (list new object))))) - (dfun-miss (gf args wrappers invalidp nemf ntype nindex) - ;; The following lexical functions change the state of the - ;; dfun to that which is their name. They accept arguments - ;; which are the parameters of the new state, and get other - ;; information from the lexical variables bound above. - (flet ((two-class (index w0 w1) - (when (zerop (random 2)) (psetf w0 w1 w1 w0)) + (let* ((ostate (type-of dfun-info)) + (otype (dfun-info-accessor-type dfun-info)) + oindex ow0 ow1 cache + (args (ecase otype + ((reader boundp) (list object)) + (writer (list new object))))) + (dfun-miss (gf args wrappers invalidp nemf ntype nindex) + ;; The following lexical functions change the state of the + ;; dfun to that which is their name. They accept arguments + ;; which are the parameters of the new state, and get other + ;; information from the lexical variables bound above. + (flet ((two-class (index w0 w1) + (when (zerop (random 2 *pcl-misc-random-state*)) + (psetf w0 w1 w1 w0)) (dfun-update gf #'make-two-class-accessor-dfun ntype @@ -1011,7 +923,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((ncache (fill-cache cache wrappers nindex))) (unless (eq ncache cache) (funcall update-fn ncache))))) - (cond ((null ntype) (caching)) ((or invalidp @@ -1048,7 +959,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (setq cache (dfun-info-cache dfun-info)) (if (consp nindex) (caching) - (do-fill #'n-n))))))))))) + (do-fill #'n-n)))))))))) (defun checking-miss (generic-function args dfun-info) (let ((oemf (dfun-info-function dfun-info)) @@ -1056,6 +967,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dfun-miss (generic-function args wrappers invalidp nemf) (cond (invalidp) ((eq oemf nemf) + ;; The cache of a checking dfun doesn't hold any values, + ;; so this NIL appears to be just a dummy-value we use in + ;; order to insert the wrappers into the cache. (let ((ncache (fill-cache cache wrappers nil))) (unless (eq ncache cache) (dfun-update generic-function #'make-checking-dfun @@ -1077,14 +991,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (unless invalidp - (let* ((function + (let* ((value (typecase emf - (fast-method-call (fast-method-call-function emf)) - (method-call (method-call-function emf)))) - (value (let ((val (method-function-get - function :constant-value '.not-found.))) - (aver (not (eq val '.not-found.))) - val)) + (constant-fast-method-call + (constant-fast-method-call-value emf)) + (constant-method-call + (constant-method-call-value emf)) + (t + (bug "~S with non-constant EMF ~S" 'constant-value-miss emf)))) (ncache (fill-cache ocache wrappers value))) (unless (eq ncache ocache) (dfun-update generic-function @@ -1202,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) @@ -1229,13 +1158,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (found-method nil)) (dolist (method (standard-slot-value/gf gf 'methods) found-method) (let ((specializers (standard-slot-value/method method 'specializers)) - (qualifiers (plist-value method 'qualifiers))) + (qualifiers (standard-slot-value/method method 'qualifiers))) (when (and (null qualifiers) (let ((subcpl (member (ecase type (reader (car specializers)) (writer (cadr specializers))) - cpl))) - (and subcpl (member found-specializer subcpl)))) + cpl :test #'eq))) + (and subcpl (member found-specializer subcpl :test #'eq)))) (setf found-specializer (ecase type (reader (car specializers)) (writer (cadr specializers)))) @@ -1258,40 +1187,35 @@ 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) - (method-qualifiers meth)) + (safe-method-qualifiers meth)) (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))) - (if early-p - (not (eq *the-class-standard-method* - (early-method-class meth))) - (standard-accessor-method-p meth)) - (if early-p - (early-accessor-method-slot-name 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))))) + (early-p (not (eq **boot-state** 'complete))) + (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 (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)) @@ -1304,7 +1228,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (generic-function-methods gf))) (all-index nil) (no-class-slots-p t) - (early-p (not (eq *boot-state* 'complete))) + (early-p (not (eq **boot-state** 'complete))) first second (size 0)) (declare (fixnum size)) ;; class -> {(specl slotd)} @@ -1317,9 +1241,9 @@ 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)))) - (so-p (member *the-class-standard-object* specl-cpl)) + (when (class-finalized-p specl) + (class-precedence-list specl)))) + (so-p (member *the-class-standard-object* specl-cpl :test #'eq)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) (early-method-standard-accessor-slot-name @@ -1327,23 +1251,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (accessor-method-slot-name method)))) (when (or (null specl-cpl) (null so-p) - (member *the-class-structure-object* specl-cpl)) + (member *the-class-structure-object* specl-cpl :test #'eq)) (return-from make-accessor-table nil)) ;; Collect all the slot-definitions for SLOT-NAME from SPECL and ;; 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) @@ -1405,7 +1326,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 precedence (lambda (class1 class2 index) (let* ((class (type-class (nth index types))) - (cpl (if (eq *boot-state* 'complete) + (cpl (if (eq **boot-state** 'complete) (class-precedence-list class) (early-class-precedence-list class)))) (if (memq class2 (memq class1 cpl)) @@ -1429,10 +1350,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (stable-sort methods #'sorter))) (defun order-specializers (specl1 specl2 index compare-classes-function) - (let ((type1 (if (eq *boot-state* 'complete) + (let ((type1 (if (eq **boot-state** 'complete) (specializer-type specl1) (!bootstrap-get-slot 'specializer specl1 '%type))) - (type2 (if (eq *boot-state* 'complete) + (type2 (if (eq **boot-state** 'complete) (specializer-type specl2) (!bootstrap-get-slot 'specializer specl2 '%type)))) (cond ((eq specl1 specl2) @@ -1453,9 +1374,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)))))))) @@ -1502,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)))) - (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) @@ -1514,22 +1441,32 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 argument-precedence-order))) (defun cpl-or-nil (class) - (if (eq *boot-state* 'complete) - ;; KLUDGE: why not use (slot-boundp class - ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is - ;; used within COMPUTE-APPLICABLE-METHODS, including for - ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for - ;; breaking such nasty cycles in effective method computation - ;; only works for readers and writers, not boundps. It might - ;; not be too hard to make it work for BOUNDP accessors, but in - ;; the meantime we use an extra slot for exactly the result of - ;; the SLOT-BOUNDP that we want. (We cannot use - ;; CLASS-FINALIZED-P, because in the process of class - ;; finalization we need to use the CPL which has been computed - ;; to cache effective methods for slot accessors.) -- CSR, - ;; 2004-09-19. - (when (cpl-available-p class) - (class-precedence-list class)) + (if (eq **boot-state** 'complete) + (progn + ;; KLUDGE: why not use (slot-boundp class + ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is + ;; used within COMPUTE-APPLICABLE-METHODS, including for + ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for + ;; breaking such nasty cycles in effective method computation + ;; only works for readers and writers, not boundps. It might + ;; not be too hard to make it work for BOUNDP accessors, but in + ;; the meantime we use an extra slot for exactly the result of + ;; the SLOT-BOUNDP that we want. (We cannot use + ;; CLASS-FINALIZED-P, because in the process of class + ;; finalization we need to use the CPL which has been computed + ;; to cache effective methods for slot accessors.) -- CSR, + ;; 2004-09-19. + + (when (cpl-available-p class) + (return-from cpl-or-nil (class-precedence-list class))) + + ;; 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-cpl-protocol-violation-p class))) + (finalize-inheritance class) + (class-precedence-list class))) + (early-class-precedence-list class))) (defun saut-and (specl type) @@ -1582,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 @@ -1648,8 +1585,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun map-all-classes (fun &optional (root t)) (let ((all-classes (make-hash-table :test 'eq)) - (braid-p (or (eq *boot-state* 'braid) - (eq *boot-state* 'complete)))) + (braid-p (or (eq **boot-state** 'braid) + (eq **boot-state** 'complete)))) (labels ((do-class (class) (unless (gethash class all-classes) (setf (gethash class all-classes) t) @@ -1663,11 +1600,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 root))) nil)) +;;; Not synchronized, as all the uses we have for it are multiple ones +;;; 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? +;;; +;;; 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-system-table (cache) + (dolist (method (generic-function-methods generic-function)) + (remhash method cache))))) (defun get-secondary-dispatch-function (gf methods types &optional method-alist wrappers) @@ -1683,20 +1630,16 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 all-applicable-p (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)))) + (if (null methods) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (lambda (&rest args) + (call-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-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 (null method-alist-p) wrappers-p (not function-p)) (or (car ht-value) @@ -1718,7 +1661,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 wrappers-p all-applicable-p all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) - (if (eq *boot-state* 'complete) + (if (eq **boot-state** 'complete) (let* ((combin (generic-function-method-combination gf)) (effective (compute-effective-method gf combin methods))) (make-effective-method-function1 gf effective method-alist-p @@ -1741,24 +1684,53 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p)) (defun methods-contain-eql-specializer-p (methods) - (and (eq *boot-state* 'complete) + (and (eq **boot-state** 'complete) (dolist (method methods nil) (when (dolist (spec (method-specializers method) nil) (when (eql-specializer-p spec) (return t))) (return t))))) (defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p generic-function))) - (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)))) + (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. + ;; + ;; 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-lock #'update lock)))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) @@ -1768,7 +1740,7 @@ 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*))) @@ -1831,7 +1803,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)))