X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=a83e0373204881bfa8ef2d8ef9bc618688694ef8;hb=1dc3a468ba32755c51747d6e85ed32d989f2dd49;hp=1db2f02d2cf2fe624bfe517a4ad4c2220345a526;hpb=a987d443ea0935bfdfa2eb8547218fef9730a14f;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 1db2f02..a83e037 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -489,11 +489,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (every (lambda (mt) (eq mt t)) metatypes))) (defun use-caching-dfun-p (generic-function) - (some (lambda (method) - (let ((fmf (if (listp method) - (third method) - (safe-method-fast-function method)))) - (method-function-get fmf :slot-name-lists))) + (some (lambda (method) (method-plist-value method :slot-name-lists)) ;; KLUDGE: As of sbcl-0.6.4, it's very important for ;; efficiency to know the type of the sequence argument to ;; quantifiers (SOME/NOTANY/etc.) at compile time, but @@ -584,12 +580,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (safe-method-specializers method)) (safe-method-qualifiers method)) (return nil))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (safe-method-fast-function method) - (safe-method-function method))) - :constant-value default))) + (let ((value (method-plist-value method :constant-value default))) (when (or (eq value default) (and boolean-values-p (not (member value '(t nil))))) @@ -633,9 +624,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((cdc (caching-dfun-cost gf))) ; fast (> cdc (dispatch-dfun-cost gf cdc)))))) -(defparameter *non-built-in-typep-cost* 1) -(defparameter *structure-typep-cost* 1) -(defparameter *built-in-typep-cost* 0) +(defparameter *non-built-in-typep-cost* 100) +(defparameter *structure-typep-cost* 15) +(defparameter *built-in-typep-cost* 5) ;;; According to comments in the original CMU CL version of PCL, ;;; the cost LIMIT is important to cut off exponential growth for @@ -666,9 +657,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 max-cost-so-far)) #'identity)) -(defparameter *cache-lookup-cost* 1) -(defparameter *wrapper-of-cost* 0) -(defparameter *secondary-dfun-call-cost* 1) +(defparameter *cache-lookup-cost* 30) +(defparameter *wrapper-of-cost* 15) +(defparameter *secondary-dfun-call-cost* 30) (defun caching-dfun-cost (gf) (let ((nreq (get-generic-fun-info gf))) @@ -679,13 +670,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 *secondary-dfun-call-cost* 0)))) -(setq *non-built-in-typep-cost* 100) -(setq *structure-typep-cost* 15) -(setq *built-in-typep-cost* 5) -(setq *cache-lookup-cost* 30) -(setq *wrapper-of-cost* 15) -(setq *secondary-dfun-call-cost* 30) - (declaim (inline make-callable)) (defun make-callable (gf methods generator method-alist wrappers) (let* ((*applicable-methods* methods) @@ -892,23 +876,33 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (generic-function-methods gf)))) (cond ((every (lambda (method) (if (consp method) - (eq *the-class-standard-reader-method* - (early-method-class method)) - (standard-reader-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-reader-method*) + (eq class *the-class-global-reader-method*))) + (or (standard-reader-method-p method) + (global-reader-method-p method)))) methods) 'reader) ((every (lambda (method) (if (consp method) - (eq *the-class-standard-boundp-method* - (early-method-class method)) - (standard-boundp-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-boundp-method*) + (eq class *the-class-global-boundp-method*))) + (or (standard-boundp-method-p method) + (global-boundp-method-p method)))) methods) 'boundp) ((every (lambda (method) (if (consp method) - (eq *the-class-standard-writer-method* - (early-method-class method)) - (standard-writer-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-writer-method*) + (eq class *the-class-global-writer-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)))) @@ -1078,14 +1072,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (unless invalidp - (let* ((function + (let* ((value (typecase emf - (fast-method-call (fast-method-call-function emf)) - (method-call (method-call-function emf)))) - (value (let ((val (method-function-get - function :constant-value '.not-found.))) - (aver (not (eq val '.not-found.))) - val)) + (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)))) (ncache (fill-cache ocache wrappers value))) (unless (eq ncache ocache) (dfun-update generic-function @@ -1230,7 +1223,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (found-method nil)) (dolist (method (standard-slot-value/gf gf 'methods) found-method) (let ((specializers (standard-slot-value/method method 'specializers)) - (qualifiers (plist-value method 'qualifiers))) + (qualifiers (standard-slot-value/method method 'qualifiers))) (when (and (null qualifiers) (let ((subcpl (member (ecase type (reader (car specializers)) @@ -1262,7 +1255,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (meth methods) (when (if (consp meth) (early-method-qualifiers meth) - (method-qualifiers meth)) + (safe-method-qualifiers meth)) (return-from accessor-values-internal (values nil nil)))) (let* ((meth (car methods)) (early-p (not (eq *boot-state* 'complete))) @@ -1279,7 +1272,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if early-p (not (eq *the-class-standard-method* (early-method-class meth))) - (standard-accessor-method-p meth)) + (accessor-method-p meth)) (if early-p (early-accessor-method-slot-name meth) (accessor-method-slot-name meth)))))) @@ -1292,7 +1285,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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)) @@ -1516,21 +1511,30 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun cpl-or-nil (class) (if (eq *boot-state* 'complete) - ;; KLUDGE: why not use (slot-boundp class - ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is - ;; used within COMPUTE-APPLICABLE-METHODS, including for - ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for - ;; breaking such nasty cycles in effective method computation - ;; only works for readers and writers, not boundps. It might - ;; not be too hard to make it work for BOUNDP accessors, but in - ;; the meantime we use an extra slot for exactly the result of - ;; the SLOT-BOUNDP that we want. (We cannot use - ;; CLASS-FINALIZED-P, because in the process of class - ;; finalization we need to use the CPL which has been computed - ;; to cache effective methods for slot accessors.) -- CSR, - ;; 2004-09-19. - (when (cpl-available-p class) - (class-precedence-list class)) + (progn + ;; KLUDGE: why not use (slot-boundp class + ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is + ;; used within COMPUTE-APPLICABLE-METHODS, including for + ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for + ;; breaking such nasty cycles in effective method computation + ;; only works for readers and writers, not boundps. It might + ;; not be too hard to make it work for BOUNDP accessors, but in + ;; the meantime we use an extra slot for exactly the result of + ;; the SLOT-BOUNDP that we want. (We cannot use + ;; CLASS-FINALIZED-P, because in the process of class + ;; finalization we need to use the CPL which has been computed + ;; to cache effective methods for slot accessors.) -- CSR, + ;; 2004-09-19. + + (when (cpl-available-p class) + (return-from cpl-or-nil (class-precedence-list class))) + + ;; if we can finalize an unfinalized class, then do so + (when (and (not (class-finalized-p class)) + (not (class-has-a-forward-referenced-superclass-p class))) + (finalize-inheritance class) + (class-precedence-list class))) + (early-class-precedence-list class))) (defun saut-and (specl type)