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
(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)))
(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)
(let ((class (early-method-class method)))
(or (eq class *the-class-standard-writer-method*)
(eq class *the-class-global-writer-method*)))
- (or (standard-writer-method-p method)
- (global-writer-method-p 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
(t
(make-final-caching-dfun gf classes-list new-class)))))
-(defvar *accessor-miss-history* nil)
(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
(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))
(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))
root)))
nil))
\f
+;;; FIXME: Needs a lock.
(defvar *effective-method-cache* (make-hash-table :test 'eq))
(defun flush-effective-method-cache (generic-function)
projects / sbcl.git / blobdiff