;;; 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)))
(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*))
\f
;;; 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))
(: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)))
(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
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
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)
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)
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)
(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
(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))
\f
(defun make-caching-dfun (generic-function &optional cache)
(unless cache
(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)
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)
(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.
;; 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
- (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)))))
(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
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
(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
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
*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)
(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
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)))
\f
(defvar *dfun-miss-gfs-on-stack* ())
(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)
((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))))))
(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
(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)))))
(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))
(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
(let ((ncache (fill-cache cache wrappers nindex)))
(unless (eq ncache cache)
(funcall update-fn ncache)))))
-
(cond ((null ntype)
(caching))
((or invalidp
(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
(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
;;; 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)
;;; 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))
(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))))
(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-std-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 (atom 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))
(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)}
(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-std-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
method))
(accessor-method-slot-name method))))
(when (or (null specl-cpl)
- (member *the-class-structure-object* specl-cpl))
+ (null so-p)
+ (member *the-class-structure-object* specl-cpl :test #'eq))
(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)
+ (let ((slotd (find-slot-definition class slot-name)))
+ (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))
+ (unless (class-finalized-p subclass)
+ (return-from make-accessor-table nil))
+ (aux subclass))))
+ (aux specl))))
(maphash (lambda (class specl+slotd-list)
(dolist (sclass (if early-p
(early-class-precedence-list class)
(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)
(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
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))
(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)
+ (!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)
(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))))))))
;;; 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)
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)
(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
'specializer-applicable-using-type-p
type)))))
-(defun map-all-classes (function &optional (root t))
- (let ((braid-p (or (eq *boot-state* 'braid)
- (eq *boot-state* 'complete))))
+(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))
\f
+;;; 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)
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)
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
(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)))))
\f
(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.
+ ;;
+ ;; 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))))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)
;;; 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*)))
(format t "~% ~S~%" (caddr type+count+sizes)))
*dfun-count*)
(values))
-|#
+||#
(defun gfs-of-type (type)
(unless (consp type) (setq type (list type)))
projects / sbcl.git / blobdiff