X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=3be7f774be1cc42f6edf9ee579dac791de2f9b14;hb=127fd3d2fb843c6bb7ad0763e143d81877e760e8;hp=a10c91f01d0d6ef10c85eb50a3bc16aefb10e22b;hpb=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index a10c91f..3be7f77 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)) @@ -401,7 +401,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 +412,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 +427,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 +443,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,16 +454,16 @@ 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) - (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) +(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)) (if (every (lambda (mt) (eq mt t)) metatypes) (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) @@ -487,11 +473,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) - (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 @@ -502,9 +484,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 @@ -517,7 +496,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) @@ -528,14 +507,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) @@ -579,15 +554,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (method methods t) (when (eq *boot-state* 'complete) (when (or (some #'eql-specializer-p - (method-specializers method)) - (method-qualifiers method)) + (safe-method-specializers method)) + (safe-method-qualifiers method)) (return nil))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (method-fast-function method) - (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))))) @@ -597,8 +567,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 @@ -608,14 +579,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) - (unless (or caching-p (gf-requires-emf-keyword-checks gf)) + (unless (or caching-p + (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 @@ -630,9 +611,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 @@ -663,13 +644,12 @@ 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* ((arg-info (gf-arg-info gf)) - (nreq (length (arg-info-metatypes arg-info)))) + (let ((nreq (get-generic-fun-info gf))) (+ *cache-lookup-cost* (* *wrapper-of-cost* nreq) (if (methods-contain-eql-specializer-p @@ -677,13 +657,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) @@ -706,18 +679,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (gf (gfs-of-type '(dispatch initial-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 @@ -728,8 +691,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* ()) @@ -770,8 +734,16 @@ 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* nil) +(defvar *max-emf-precomputation-methods* 1) (defun finalize-specializers (gf) (let ((methods (generic-function-methods gf))) @@ -788,7 +760,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun make-initial-dfun (gf) (let ((initial-dfun - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) (cond @@ -833,17 +805,17 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let* ((methods (early-gf-methods gf)) (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type - (reader #'(instance-lambda (instance) + (reader #'(lambda (instance) (let* ((class (class-of instance)) (class-name (!bootstrap-get-slot 'class class 'name))) (!bootstrap-get-slot class-name instance slot-name)))) - (boundp #'(instance-lambda (instance) + (boundp #'(lambda (instance) (let* ((class (class-of instance)) (class-name (!bootstrap-get-slot 'class class 'name))) (not (eq +slot-unbound+ (!bootstrap-get-slot class-name instance slot-name)))))) - (writer #'(instance-lambda (new-value instance) + (writer #'(lambda (new-value instance) (let* ((class (class-of instance)) (class-name (!bootstrap-get-slot 'class class 'name))) (!bootstrap-set-slot class-name instance slot-name new-value))))))) @@ -857,8 +829,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)))))) @@ -867,51 +838,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 @@ -923,10 +890,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))))) @@ -937,7 +905,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 specls all-same-p) (cond ((null methods) (values - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (apply #'no-applicable-method gf args)) nil (no-methods-dfun-info))) @@ -962,23 +930,23 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (t (make-final-caching-dfun gf classes-list new-class))))) +(defvar *pcl-misc-random-state* (make-random-state)) + (defun accessor-miss (gf new object dfun-info) (let* ((ostate (type-of dfun-info)) (otype (dfun-info-accessor-type dfun-info)) oindex ow0 ow1 cache (args (ecase otype - ;; The congruence rules ensure that this is safe - ;; despite not knowing the new type yet. ((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 + ;; 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)) + (when (zerop (random 2 *pcl-misc-random-state*)) + (psetf w0 w1 w1 w0)) (dfun-update gf #'make-two-class-accessor-dfun ntype @@ -1002,7 +970,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 @@ -1047,6 +1014,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 @@ -1068,14 +1038,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 @@ -1215,12 +1185,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; function GF which reads/writes instances of class CLASS. ;;; TYPE is one of the symbols READER or WRITER. (defun find-standard-class-accessor-method (gf class type) - (let ((cpl (standard-slot-value/class class 'class-precedence-list)) + (let ((cpl (standard-slot-value/class class '%class-precedence-list)) (found-specializer *the-class-t*) (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)) @@ -1252,7 +1222,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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))) @@ -1260,7 +1230,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (consp meth) (and (early-method-standard-accessor-p meth) (early-method-standard-accessor-slot-name meth)) - (and (member *the-class-std-object* + (and (member *the-class-standard-object* (if early-p (early-class-precedence-list accessor-class) @@ -1269,7 +1239,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if early-p (not (eq *the-class-standard-method* (early-method-class meth))) - (standard-accessor-method-p meth)) + (accessor-method-p meth)) (if early-p (early-accessor-method-slot-name meth) (accessor-method-slot-name meth)))))) @@ -1282,7 +1252,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (find-slot-definition accessor-class slot-name))))) (when (and slotd (or early-p - (slot-accessor-std-p slotd accessor-type))) + (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)) @@ -1310,27 +1282,33 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (early-class-precedence-list specl) (and (class-finalized-p specl) (class-precedence-list specl)))) - (so-p (member *the-class-std-object* specl-cpl)) + (so-p (member *the-class-standard-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) (early-method-standard-accessor-slot-name method)) (accessor-method-slot-name method)))) (when (or (null specl-cpl) + (null so-p) (member *the-class-structure-object* specl-cpl)) (return-from make-accessor-table nil)) - (maphash (lambda (class slotd) - (let ((cpl (if early-p - (early-class-precedence-list class) - (class-precedence-list class)))) - (when (memq specl cpl) - (unless (and (or so-p - (member *the-class-std-object* cpl)) - (or early-p - (slot-accessor-std-p slotd type))) + ;; 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)))) + (when slotd + (unless (or early-p + (slot-accessor-std-p slotd type)) (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table))))) - (gethash slot-name *name->class->slotd-table*)))) + (push (cons specl slotd) (gethash class table)))) + (dolist (subclass (sb-pcl::class-direct-subclasses class)) + (aux subclass)))) + (aux specl)))) (maphash (lambda (class specl+slotd-list) (dolist (sclass (if early-p (early-class-precedence-list class) @@ -1359,10 +1337,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((definite-p t) (possibly-applicable-methods nil)) (dolist (method (if (early-gf-p generic-function) (early-gf-methods generic-function) - (generic-function-methods generic-function))) + (safe-generic-function-methods generic-function))) (let ((specls (if (consp method) (early-method-specializers method t) - (method-specializers method))) + (safe-method-specializers method))) (types types) (possibly-applicable-p t) (applicable-p t)) (dolist (specl specls) @@ -1376,15 +1354,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (when possibly-applicable-p (unless applicable-p (setq definite-p nil)) (push method possibly-applicable-methods)))) - (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) - (early-gf-arg-info - generic-function) - (gf-arg-info - generic-function))))) - (values (sort-applicable-methods precedence - (nreverse possibly-applicable-methods) - types) - definite-p)))) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-fun-info generic-function) + (declare (ignore nreq applyp metatypes nkeys)) + (let* ((precedence (arg-info-precedence arg-info))) + (values (sort-applicable-methods precedence + (nreverse possibly-applicable-methods) + types) + definite-p))))) (defun sort-applicable-methods (precedence methods types) (sort-methods methods @@ -1417,10 +1394,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun order-specializers (specl1 specl2 index compare-classes-function) (let ((type1 (if (eq *boot-state* 'complete) (specializer-type specl1) - (!bootstrap-get-slot 'specializer specl1 'type))) + (!bootstrap-get-slot 'specializer specl1 '%type))) (type2 (if (eq *boot-state* 'complete) (specializer-type specl2) - (!bootstrap-get-slot 'specializer specl2 'type)))) + (!bootstrap-get-slot 'specializer specl2 '%type)))) (cond ((eq specl1 specl2) nil) ((atom type1) @@ -1439,9 +1416,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)))))))) @@ -1501,21 +1486,30 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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)) + (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))) + (finalize-inheritance class) + (class-precedence-list class))) + (early-class-precedence-list class))) (defun saut-and (specl type) @@ -1632,19 +1626,24 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 'specializer-applicable-using-type-p type))))) -(defun map-all-classes (function &optional (root t)) - (let ((braid-p (or (eq *boot-state* 'braid) +(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)))) (labels ((do-class (class) - (mapc #'do-class - (if braid-p - (class-direct-subclasses class) - (early-class-direct-subclasses class))) - (funcall function class))) + (unless (gethash class all-classes) + (setf (gethash class all-classes) t) + (funcall fun class) + (mapc #'do-class + (if braid-p + (class-direct-subclasses class) + (early-class-direct-subclasses class)))))) (do-class (if (symbolp root) (find-class root) - root))))) + root))) + nil)) +;;; FIXME: Needs a lock. (defvar *effective-method-cache* (make-hash-table :test 'eq)) (defun flush-effective-method-cache (generic-function) @@ -1665,11 +1664,11 @@ 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)) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (apply #'no-applicable-method gf args))) (lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) @@ -1730,17 +1729,50 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return t))))) (defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p generic-function)) - (gf-name (if early-p - (!early-gf-name generic-function) - (generic-function-name 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) - (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) @@ -1750,7 +1782,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*))) @@ -1813,7 +1844,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)))