;;; 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))
(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)
+(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))
(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)
(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)
(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)
(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
(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
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* ())
((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)
'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)))))
(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 "~@<Vicious metacircle: The computation of a ~
- dfun of ~s for argument ~s uses the dfun being ~
- computed.~@:>"
- 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)
+ (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
(let ((ncache (fill-cache cache wrappers nindex)))
(unless (eq ncache cache)
(funcall update-fn ncache)))))
-
(cond ((null ntype)
(caching))
((or invalidp
(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))
(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
(typecase emf
(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))))
+ (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
(writer (cadr specializers))))
(specl-cpl (if early-p
(early-class-precedence-list specl)
- (and (class-finalized-p specl)
- (class-precedence-list specl))))
+ (when (class-finalized-p specl)
+ (class-precedence-list specl))))
(so-p (member *the-class-standard-object* specl-cpl))
(slot-name (if (consp method)
(and (early-method-standard-accessor-p method)
;; 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)
(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))))))))
root)))
nil))
\f
+;;; Not synchronized, as all the uses we have for it are multiple ones
+;;; and need WITH-LOCKED-HASH-TABLE in any case.
+;;;
+;;; FIXME: Is it really more efficient to store this stuff in a global
+;;; table instead of having a slot in each method?
+;;;
+;;; FIXME: This table also seems to contain early methods, which should
+;;; presumably be dropped during the bootstrap.
(defvar *effective-method-cache* (make-hash-table :test 'eq))
(defun flush-effective-method-cache (generic-function)
- (dolist (method (generic-function-methods generic-function))
- (remhash method *effective-method-cache*)))
+ (let ((cache *effective-method-cache*))
+ (with-locked-hash-table (cache)
+ (dolist (method (generic-function-methods generic-function))
+ (remhash method cache)))))
(defun get-secondary-dispatch-function (gf methods types
&optional method-alist wrappers)
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))
(lambda (&rest args)
(apply #'no-applicable-method gf args))))
(let* ((key (car methods))
- (ht-value (or (gethash key *effective-method-cache*)
- (setf (gethash key *effective-method-cache*)
- (cons nil nil)))))
+ (ht *effective-method-cache*)
+ (ht-value (with-locked-hash-table (ht)
+ (or (gethash key ht)
+ (setf (gethash key ht) (cons nil nil))))))
(if (and (null (cdr methods)) all-applicable-p ; the most common case
(null method-alist-p) wrappers-p (not function-p))
(or (car ht-value)
(return t)))))
\f
(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.
+ ;;
+ ;; 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))))))
\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)))