X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=35e9fba09f208382d44e0093cb5cb1c98201e879;hb=3031b264496451e796282d7309c2221d89ee62c1;hp=c9bdfc3940e7a71ff6d8fad73d24ae6c4f2332dc;hpb=95f17ca63742f8c164309716b35bc25545a849a6;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index c9bdfc3..35e9fba 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -196,7 +196,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (setf *standard-slot-locations* new))) (defun maybe-update-standard-slot-locations (class) - (when (and (eq *boot-state* 'complete) + (when (and (eq **boot-state** 'complete) (memq (class-name class) *standard-classes*)) (compute-standard-slot-locations))) @@ -272,10 +272,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (: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))) @@ -529,7 +525,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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. @@ -550,7 +546,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; 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)) @@ -589,7 +585,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -674,7 +670,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -732,71 +728,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) @@ -904,7 +850,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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)) @@ -1223,7 +1169,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) @@ -1235,13 +1181,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) @@ -1266,7 +1207,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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)} @@ -1364,7 +1305,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 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)) @@ -1388,10 +1329,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) @@ -1469,9 +1410,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; 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) @@ -1481,7 +1420,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 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 @@ -1558,7 +1497,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -1624,8 +1563,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) @@ -1640,7 +1579,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 nil)) ;;; 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? @@ -1651,7 +1590,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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))))) @@ -1670,18 +1609,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -1705,7 +1639,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 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 @@ -1728,7 +1662,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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))) @@ -1766,10 +1700,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; 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) @@ -1778,7 +1708,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; 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)))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil)