1.0.5.47: cacheability of EMFs from methods with non-standard specializers
[sbcl.git] / src / pcl / dfun.lisp
index ae44d78..3b5a599 100644 (file)
@@ -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))
@@ -487,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)
-                         (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
@@ -579,15 +577,10 @@ 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)))
-                           :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)))))
@@ -613,10 +606,20 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                 classes-list new-class)))
     (make-constant-value-dfun generic-function cache)))
 
+(defun gf-has-method-with-nonstandard-specializer-p (gf)
+  (let ((methods (generic-function-methods gf)))
+    (dolist (method methods nil)
+      (unless (every (lambda (s) (standard-specializer-p s))
+                     (method-specializers method))
+        (return t)))))
+
 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
   (when (eq *boot-state* 'complete)
     (unless (or caching-p
-                (gf-requires-emf-keyword-checks gf))
+                (gf-requires-emf-keyword-checks gf)
+                ;; DISPATCH-DFUN-COST will error if it encounters a
+                ;; method with a non-standard specializer.
+                (gf-has-method-with-nonstandard-specializer-p gf))
       ;; This should return T when almost all dispatching is by
       ;; eql specializers or built-in classes. In other words,
       ;; return NIL if we might ever need to do more than
@@ -631,9 +634,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
@@ -664,13 +667,12 @@ 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* ((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
@@ -678,13 +680,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)
@@ -771,8 +766,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)))
@@ -870,49 +873,44 @@ 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)
                      (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))))
 
 (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
@@ -963,23 +961,22 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
           (t
            (make-final-caching-dfun gf classes-list new-class)))))
 
+
 (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
+      ;; 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))
+               (when (zerop (random 2 *pcl-misc-random-state*))
+                 (psetf w0 w1 w1 w0))
                (dfun-update gf
                             #'make-two-class-accessor-dfun
                             ntype
@@ -1069,14 +1066,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
@@ -1216,12 +1212,12 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; function GF which reads/writes instances of class CLASS.
 ;;; TYPE is one of the symbols READER or WRITER.
 (defun find-standard-class-accessor-method (gf class type)
-  (let ((cpl (standard-slot-value/class class 'class-precedence-list))
+  (let ((cpl (standard-slot-value/class class '%class-precedence-list))
         (found-specializer *the-class-t*)
         (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))
@@ -1253,7 +1249,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)))
@@ -1270,7 +1266,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))))))
@@ -1283,7 +1279,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))
@@ -1318,21 +1316,26 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                                   method))
                             (accessor-method-slot-name method))))
         (when (or (null specl-cpl)
+                  (null so-p)
                   (member *the-class-structure-object* specl-cpl))
           (return-from make-accessor-table nil))
-        (maphash (lambda (class slotd)
-                   (let ((cpl (if early-p
-                                  (early-class-precedence-list class)
-                                  (class-precedence-list class))))
-                     (when (memq specl cpl)
-                       (unless (and (or so-p
-                                        (member *the-class-standard-object*
-                                                cpl))
-                                    (or early-p
-                                        (slot-accessor-std-p slotd type)))
+        ;; Collect all the slot-definitions for SLOT-NAME from SPECL and
+        ;; all of its subclasses. If either SPECL or one of the subclasses
+        ;; is not a standard-class, bail out.
+        (labels ((aux (class)
+                   ;; FIND-SLOT-DEFINITION might not be defined yet
+                   (let ((slotd (find-if (lambda (x)
+                                           (eq (sb-pcl::slot-definition-name x)
+                                               slot-name))
+                                         (sb-pcl::class-slots class))))
+                     (when slotd
+                       (unless (or early-p
+                                   (slot-accessor-std-p slotd type))
                          (return-from make-accessor-table nil))
-                       (push (cons specl slotd) (gethash class table)))))
-                 (gethash slot-name *name->class->slotd-table*))))
+                       (push (cons specl slotd) (gethash class table))))
+                   (dolist (subclass (sb-pcl::class-direct-subclasses class))
+                     (aux subclass))))
+          (aux specl))))
     (maphash (lambda (class specl+slotd-list)
                (dolist (sclass (if early-p
                                    (early-class-precedence-list class)
@@ -1361,10 +1364,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)
@@ -1378,15 +1381,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
@@ -1419,10 +1421,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 (defun order-specializers (specl1 specl2 index compare-classes-function)
   (let ((type1 (if (eq *boot-state* 'complete)
                    (specializer-type specl1)
-                   (!bootstrap-get-slot 'specializer specl1 'type)))
+                   (!bootstrap-get-slot 'specializer specl1 '%type)))
         (type2 (if (eq *boot-state* 'complete)
                    (specializer-type specl2)
-                   (!bootstrap-get-slot 'specializer specl2 'type))))
+                   (!bootstrap-get-slot 'specializer specl2 '%type))))
     (cond ((eq specl1 specl2)
            nil)
           ((atom type1)
@@ -1503,21 +1505,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)
@@ -1634,19 +1645,24 @@ 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)))))
+                    root)))
+    nil))
 \f
+;;; FIXME: Needs a lock.
 (defvar *effective-method-cache* (make-hash-table :test 'eq))
 
 (defun flush-effective-method-cache (generic-function)
@@ -1732,17 +1748,17 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            (return t)))))
 \f
 (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))))
 \f
 (defvar *dfun-count* nil)
 (defvar *dfun-list* nil)