X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=92e10181a859686f2d181de3d3f2a58f802b2f0b;hb=effa5c5b6a302cbcde162c49a1aaa6d96a030add;hp=ac1234f7a466b9b65bd944aedc959296ef1af440;hpb=3a2e34d8ed1293f2cecb5c2c6ea359b622e3f4f8;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index ac1234f..92e1018 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -470,7 +470,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun make-final-checking-dfun (generic-function function classes-list new-class) - (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-fun-info generic-function) + (declare (ignore nreq applyp nkeys)) (if (every (lambda (mt) (eq mt t)) metatypes) (values (lambda (&rest args) (invoke-emf function args)) @@ -490,7 +492,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (some (lambda (method) (let ((fmf (if (listp method) (third method) - (method-fast-function method)))) + (safe-method-fast-function method)))) (method-function-get fmf :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 @@ -579,14 +581,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (method methods t) (when (eq *boot-state* 'complete) (when (or (some #'eql-specializer-p - (method-specializers method)) - (method-qualifiers method)) + (safe-method-specializers method)) + (safe-method-qualifiers method)) (return nil))) (let ((value (method-function-get (if early-p (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) + (or (safe-method-fast-function method) + (safe-method-function method))) :constant-value default))) (when (or (eq value default) (and boolean-values-p @@ -615,7 +617,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) - (unless (or caching-p + (unless (or caching-p (gf-requires-emf-keyword-checks gf)) ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, @@ -669,8 +671,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defparameter *secondary-dfun-call-cost* 1) (defun caching-dfun-cost (gf) - (let* ((arg-info (gf-arg-info gf)) - (nreq (length (arg-info-metatypes arg-info)))) + (let ((nreq (get-generic-fun-info gf))) (+ *cache-lookup-cost* (* *wrapper-of-cost* nreq) (if (methods-contain-eql-specializer-p @@ -963,22 +964,29 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (t (make-final-caching-dfun gf classes-list new-class))))) +(defvar *accessor-miss-history* nil) + (defun accessor-miss (gf new object dfun-info) - (let* ((ostate (type-of dfun-info)) - (otype (dfun-info-accessor-type dfun-info)) - oindex ow0 ow1 cache - (args (ecase otype - ;; The congruence rules ensure that this is safe - ;; despite not knowing the new type yet. - ((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 ((wrapper (wrapper-of object)) + (previous-miss (assq gf *accessor-miss-history*))) + (when (eq wrapper (cdr previous-miss)) + (error "~@" + 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) (when (zerop (random 2)) (psetf w0 w1 w1 w0)) (dfun-update gf #'make-two-class-accessor-dfun @@ -1040,7 +1048,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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)) @@ -1261,7 +1269,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (consp meth) (and (early-method-standard-accessor-p meth) (early-method-standard-accessor-slot-name meth)) - (and (member *the-class-std-object* + (and (member *the-class-standard-object* (if early-p (early-class-precedence-list accessor-class) @@ -1311,7 +1319,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (early-class-precedence-list specl) (and (class-finalized-p specl) (class-precedence-list specl)))) - (so-p (member *the-class-std-object* specl-cpl)) + (so-p (member *the-class-standard-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) (early-method-standard-accessor-slot-name @@ -1326,7 +1334,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (class-precedence-list class)))) (when (memq specl cpl) (unless (and (or so-p - (member *the-class-std-object* cpl)) + (member *the-class-standard-object* + cpl)) (or early-p (slot-accessor-std-p slotd type))) (return-from make-accessor-table nil)) @@ -1360,10 +1369,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((definite-p t) (possibly-applicable-methods nil)) (dolist (method (if (early-gf-p generic-function) (early-gf-methods generic-function) - (generic-function-methods generic-function))) + (safe-generic-function-methods generic-function))) (let ((specls (if (consp method) (early-method-specializers method t) - (method-specializers method))) + (safe-method-specializers method))) (types types) (possibly-applicable-p t) (applicable-p t)) (dolist (specl specls) @@ -1377,15 +1386,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (when possibly-applicable-p (unless applicable-p (setq definite-p nil)) (push method possibly-applicable-methods)))) - (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) - (early-gf-arg-info - generic-function) - (gf-arg-info - generic-function))))) - (values (sort-applicable-methods precedence - (nreverse possibly-applicable-methods) - types) - definite-p)))) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-fun-info generic-function) + (declare (ignore nreq applyp metatypes nkeys)) + (let* ((precedence (arg-info-precedence arg-info))) + (values (sort-applicable-methods precedence + (nreverse possibly-applicable-methods) + types) + definite-p))))) (defun sort-applicable-methods (precedence methods types) (sort-methods methods @@ -1633,15 +1641,18 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 'specializer-applicable-using-type-p type))))) -(defun map-all-classes (function &optional (root t)) - (let ((braid-p (or (eq *boot-state* 'braid) +(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)))) (labels ((do-class (class) - (mapc #'do-class - (if braid-p - (class-direct-subclasses class) - (early-class-direct-subclasses class))) - (funcall function class))) + (unless (gethash class all-classes) + (setf (gethash class all-classes) t) + (funcall fun class) + (mapc #'do-class + (if braid-p + (class-direct-subclasses class) + (early-class-direct-subclasses class)))))) (do-class (if (symbolp root) (find-class root) root))))) @@ -1731,17 +1742,17 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return t))))) (defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p generic-function)) - (gf-name (if early-p - (!early-gf-name generic-function) - (generic-function-name generic-function)))) + (let* ((early-p (early-gf-p generic-function))) (set-dfun generic-function dfun cache info) (let ((dfun (if early-p (or dfun (make-initial-dfun generic-function)) (compute-discriminating-function generic-function)))) (set-funcallable-instance-function generic-function dfun) - (set-fun-name generic-function gf-name) - dfun))) + (let ((gf-name (if early-p + (!early-gf-name generic-function) + (generic-function-name generic-function)))) + (set-fun-name generic-function gf-name) + dfun)))) (defvar *dfun-count* nil) (defvar *dfun-list* nil)