X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=0e816d0dddc4e99863503e1a9f1f4d12b77b409b;hb=17532463fa19f2fc2aba53b65c32e200a27ccd6a;hp=37650074eb5d10c24bdf459d294c3721386d87c3;hpb=832f3b5652ae1b4a8888829cd4a1b391a8ca9952;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3765007..0e816d0 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -756,8 +756,16 @@ 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* nil) +(defvar *max-emf-precomputation-methods* 1) (defun finalize-specializers (gf) (let ((methods (generic-function-methods gf))) @@ -855,21 +863,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defvar *new-class* nil) -(defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) - -(defmacro with-hash-table ((table test) &body forms) - `(let* ((.free. (assoc ',test *free-hash-tables*)) - (,table (if (cdr .free.) - (pop (cdr .free.)) - (make-hash-table :test ',test)))) - (multiple-value-prog1 - (progn ,@forms) - (clrhash ,table) - (push ,table (cdr .free.))))) - -(defmacro with-eq-hash-table ((table) &body forms) - `(with-hash-table (,table eq) ,@forms)) - (defun final-accessor-dfun-type (gf) (let ((methods (if (early-gf-p gf) (early-gf-methods gf) @@ -897,13 +890,17 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((class (early-method-class method))) (or (eq class *the-class-standard-writer-method*) (eq class *the-class-global-writer-method*))) - (or (standard-writer-method-p method) - (global-writer-method-p 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)))) (defun make-final-accessor-dfun (gf type &optional classes-list new-class) - (with-eq-hash-table (table) + (let ((table (make-hash-table :test #'eq))) (multiple-value-bind (table all-index first second size no-class-slots-p) (make-accessor-table gf type table) (if table @@ -954,29 +951,20 @@ 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 ((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) + (let* ((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 *pcl-misc-random-state*)) (psetf w0 w1 w1 w0)) (dfun-update gf @@ -1039,7 +1027,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)) @@ -1281,7 +1269,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)) @@ -1662,6 +1652,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 root))) nil)) +;;; FIXME: Needs a lock. (defvar *effective-method-cache* (make-hash-table :test 'eq)) (defun flush-effective-method-cache (generic-function)