(: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)))
(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 make-final-ordinary-dfun-cache
(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* 1)
-
-(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)
;;; 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)) :test #'eq))
- (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)
(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
nil))
\f
;;; Not synchronized, as all the uses we have for it are multiple ones
-;;; and need WITH-LOCKED-HASH-TABLE in any case.
+;;; 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?
(defun flush-effective-method-cache (generic-function)
(let ((cache *effective-method-cache*))
- (with-locked-hash-table (cache)
+ (with-locked-system-table (cache)
(dolist (method (generic-function-methods generic-function))
(remhash method cache)))))
(call-no-applicable-method gf args)))
(let* ((key (car methods))
(ht *effective-method-cache*)
- (ht-value (with-locked-hash-table (ht)
+ (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
;; 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)
;; 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))))))
+ (sb-thread::call-with-recursive-system-lock #'update lock))))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)