(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)))
(: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)))
(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
(safe-method-specializers method))
(safe-method-qualifiers 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)
;; DISPATCH-DFUN-COST will error if it encounters a
(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)
(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))
(safe-method-qualifiers meth))
(return-from accessor-values-internal (values nil nil))))
(let* ((meth (car methods))
- (early-p (not (eq *boot-state* 'complete)))
+ (early-p (not (eq **boot-state** 'complete)))
(slot-name (when accessor-class
(if (consp meth)
(and (early-method-standard-accessor-p meth)
(class-precedence-list
accessor-class))
:test #'eq)
- (if early-p
- (not (eq *the-class-standard-method*
- (early-method-class meth)))
- (accessor-method-p meth))
- (if early-p
- (early-accessor-method-slot-name meth)
- (accessor-method-slot-name meth))))))
+ (accessor-method-p meth)
+ (accessor-method-slot-name meth)))))
(slotd (and accessor-class
(if early-p
(dolist (slot (early-class-slotds accessor-class) nil)
(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)}
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)
+ (type2 (if (eq **boot-state** 'complete)
(specializer-type specl2)
(!bootstrap-get-slot 'specializer specl2 '%type))))
(cond ((eq specl1 specl2)
;;; 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)
argument-precedence-order)))
(defun cpl-or-nil (class)
- (if (eq *boot-state* 'complete)
+ (if (eq **boot-state** 'complete)
(progn
;; KLUDGE: why not use (slot-boundp class
;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is
(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
(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))))
+ (braid-p (or (eq **boot-state** 'braid)
+ (eq **boot-state** 'complete))))
(labels ((do-class (class)
(unless (gethash class all-classes)
(setf (gethash class all-classes) t)
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)))))
(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))))
+ (lambda (method-alist wrappers)
+ (declare (ignore method-alist wrappers))
+ (lambda (&rest args)
+ (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
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)))
;; 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)