From 4ff2057326cb82db04380aae96493bd5fcb3c203 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 30 May 2008 13:16:24 +0000
Subject: [PATCH] 1.0.17.9: grab-bag of PCL hackery

 * Make REAL-ADD-METHOD suck slightly less: instead of paying for
   generic dispatch for all METHOD-FOO accessors, use a single call
   to a method that gets the benefit of permutation vectors and
   returns all we want as multiple values.

   ...this assumes that users are not allowed to override METHOD-FOO
   accessors. My current reading of AMOP is that overriding them is
   not specified at all -- but if someone needs it, we can use
   CLASS-EQ specializer magic to make that work.

 * A smattering of :TEST #'EQs for PUSHNEW, MEMBER, and ADJOIN.

 * Global specializer tables need to be synchronized now that our
   hash-tables aren't thread safe by default anymore.
---
 src/pcl/boot.lisp      |    2 +-
 src/pcl/ctor.lisp      |    2 +-
 src/pcl/defclass.lisp  |    6 ++--
 src/pcl/defcombin.lisp |    2 +-
 src/pcl/defs.lisp      |    2 +-
 src/pcl/dfun.lisp      |   13 ++++----
 src/pcl/methods.lisp   |   78 +++++++++++++++++++++++++++++-------------------
 src/pcl/std-class.lisp |   27 ++++++++---------
 src/pcl/vector.lisp    |    4 +--
 src/pcl/walk.lisp      |    6 ++--
 version.lisp-expr      |    2 +-
 11 files changed, 81 insertions(+), 63 deletions(-)

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index e600694..89ba91e 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -1496,7 +1496,7 @@ bootstrapping.
                           ;; another binding it won't have a %CLASS
                           ;; declaration anymore, and this won't get
                           ;; executed.
-                          (pushnew var parameters-setqd))))
+                          (pushnew var parameters-setqd :test #'eq))))
                     form)
                    ((and (eq (car form) 'function)
                          (cond ((eq (cadr form) 'call-next-method)
diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 9baa699..9b565be 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -252,7 +252,7 @@
     (when (eq (layout-invalid (class-wrapper class)) t)
       (force-cache-flushes class))
     (setf (ctor-class ctor) class)
-    (pushnew ctor (plist-value class 'ctors))
+    (pushnew ctor (plist-value class 'ctors) :test #'eq)
     (setf (funcallable-instance-fun ctor)
           (multiple-value-bind (form locations names)
               (constructor-function-form ctor)
diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 75ed5b4..5d79f0e 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -121,7 +121,7 @@
 (defun canonize-defclass-options (class-name options)
   (maplist (lambda (sublist)
              (let ((option-name (first (pop sublist))))
-               (when (member option-name sublist :key #'first)
+               (when (member option-name sublist :key #'first :test #'eq)
                  (error 'simple-program-error
                         :format-control "Multiple ~S options in DEFCLASS ~S."
                         :format-arguments (list option-name class-name)))))
@@ -145,7 +145,7 @@
           (:default-initargs
            (let (initargs arg-names)
              (doplist (key val) (cdr option)
-               (when (member key arg-names)
+               (when (member key arg-names :test #'eq)
                  (error 'simple-program-error
                         :format-control "~@<Duplicate initialization argument ~
                                            name ~S in :DEFAULT-INITARGS of ~
@@ -261,7 +261,7 @@
            (slot-name-illegal "a keyword"))
           ((constantp name env)
            (slot-name-illegal "a constant"))
-          ((member name *slot-names-for-this-defclass*)
+          ((member name *slot-names-for-this-defclass* :test #'eq)
            (error 'simple-program-error
                   :format-control "Multiple slots named ~S in DEFCLASS ~S."
                   :format-arguments (list name class-name))))))
diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index f3296a9..c4dc449 100644
--- a/src/pcl/defcombin.lisp
+++ b/src/pcl/defcombin.lisp
@@ -437,7 +437,7 @@
   (let ((intercept-rebindings
          (let (rebindings)
            (dolist (arg args-lambda-list (nreverse rebindings))
-             (unless (member arg lambda-list-keywords)
+             (unless (member arg lambda-list-keywords :test #'eq)
                (typecase arg
                  (symbol (push `(,arg ',arg) rebindings))
                  (cons
diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index cea2b0e..5bfa675 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -230,7 +230,7 @@
                    (dohash ((sub v) subs)
                      (declare (ignore v))
                      (/noshow sub)
-                     (when (member class (direct-supers sub))
+                     (when (member class (direct-supers sub) :test #'eq)
                        (res sub)))))
                (res))))
     (mapcar (lambda (kernel-bic-entry)
diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 5532c12..3d5f353 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -1195,8 +1195,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                    (let ((subcpl (member (ecase type
                                            (reader (car specializers))
                                            (writer (cadr specializers)))
-                                         cpl)))
-                     (and subcpl (member found-specializer subcpl))))
+                                         cpl :test #'eq)))
+                     (and subcpl (member found-specializer subcpl :test #'eq))))
           (setf found-specializer (ecase type
                                     (reader (car specializers))
                                     (writer (cadr specializers))))
@@ -1235,7 +1235,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                                            (early-class-precedence-list
                                             accessor-class)
                                            (class-precedence-list
-                                            accessor-class)))
+                                            accessor-class))
+                                       :test #'eq)
                                (if early-p
                                    (not (eq *the-class-standard-method*
                                             (early-method-class meth)))
@@ -1282,7 +1283,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                             (early-class-precedence-list specl)
                             (when (class-finalized-p specl)
                               (class-precedence-list specl))))
-             (so-p (member *the-class-standard-object* specl-cpl))
+             (so-p (member *the-class-standard-object* specl-cpl :test #'eq))
              (slot-name (if (consp method)
                             (and (early-method-standard-accessor-p method)
                                  (early-method-standard-accessor-slot-name
@@ -1290,7 +1291,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                             (accessor-method-slot-name method))))
         (when (or (null specl-cpl)
                   (null so-p)
-                  (member *the-class-structure-object* specl-cpl))
+                  (member *the-class-structure-object* specl-cpl :test #'eq))
           (return-from make-accessor-table nil))
         ;; Collect all the slot-definitions for SLOT-NAME from SPECL and
         ;; all of its subclasses. If either SPECL or one of the subclasses
@@ -1471,7 +1472,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))))
+      (not (member class1 (cdr (class-precedence-list class2)) :test #'eq))
       (class-can-precede-p class1 class2)))
 
 (defun compute-precedence (lambda-list nreq argument-precedence-order)
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 657e665..a734f6b 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -345,7 +345,7 @@
     (let ((pos 0))
       (dolist (type-spec (method-specializers method))
         (unless (eq type-spec *the-class-t*)
-          (pushnew pos specialized-argument-positions))
+          (pushnew pos specialized-argument-positions :test #'eq))
         (incf pos)))
     ;; Finally merge the values for this method into the values
     ;; for the exisiting methods and return them. Note that if
@@ -433,41 +433,58 @@
       (list '(:sbcl :node "Metaobject Protocol")
             '(:amop :generic-function (setf slot-value-using-class)))))
 
+(defgeneric values-for-add-method (gf method)
+  (:method ((gf standard-generic-function) (method standard-method))
+    ;; KLUDGE: Just a single generic dispatch, and everything else
+    ;; comes from permutation vectors. Would be nicer to define 
+    ;; REAL-ADD-METHOD with a proper method so that we could efficiently
+    ;; use SLOT-VALUE there.
+    ;;
+    ;; Optimization note: REAL-ADD-METHOD has a lot of O(N) stuff in it (as
+    ;; does PCL as a whole). It should not be too hard to internally store
+    ;; many of the things we now keep in lists as either purely functional
+    ;; O(log N) sets, or --if we don't mind the memory cost-- using
+    ;; specialized hash-tables: most things are used to answer questions about
+    ;; set-membership, not ordering.
+    (values (slot-value gf '%lock)
+            (slot-value method 'qualifiers)
+            (slot-value method 'specializers)
+            (slot-value method 'lambda-list)
+            (slot-value method '%generic-function))))
+
 (defun real-add-method (generic-function method &optional skip-dfun-update-p)
-  (when (method-generic-function method)
-    (error "~@<The method ~S is already part of the generic ~
-            function ~S; it can't be added to another generic ~
-            function until it is removed from the first one.~@:>"
-           method (method-generic-function method)))
-  (flet ((similar-lambda-lists-p (method-a method-b)
+  (flet ((similar-lambda-lists-p (old-method new-lambda-list)
            (multiple-value-bind (a-nreq a-nopt a-keyp a-restp)
-               (analyze-lambda-list (method-lambda-list method-a))
+               (analyze-lambda-list (method-lambda-list old-method))
              (multiple-value-bind (b-nreq b-nopt b-keyp b-restp)
-                 (analyze-lambda-list (method-lambda-list method-b))
+                 (analyze-lambda-list new-lambda-list)
                (and (= a-nreq b-nreq)
                     (= a-nopt b-nopt)
                     (eq (or a-keyp a-restp)
                         (or b-keyp b-restp)))))))
-    (let ((lock (gf-lock generic-function)))
-      ;; HANDLER-CASE takes care of releasing the lock and enabling
-      ;; interrupts before going forth with the error.
+    (multiple-value-bind (lock qualifiers specializers new-lambda-list
+                          method-gf)
+        (values-for-add-method generic-function method)
+      (when method-gf
+        (error "~@<The method ~S is already part of the generic ~
+                function ~S; it can't be added to another generic ~
+                function until it is removed from the first one.~@:>"
+               method method-gf))
       (handler-case
           ;; System lock because interrupts need to be disabled as
           ;; well: it would be bad to unwind and leave the gf in an
           ;; inconsistent state.
           (sb-thread::with-recursive-system-spinlock (lock)
-            (let* ((qualifiers (method-qualifiers method))
-                   (specializers (method-specializers method))
-                   (existing (get-method generic-function
-                                         qualifiers
-                                         specializers
-                                         nil)))
+            (let ((existing (get-method generic-function
+                                        qualifiers
+                                        specializers
+                                        nil)))
 
               ;; If there is already a method like this one then we must get
               ;; rid of it before proceeding.  Note that we call the generic
               ;; function REMOVE-METHOD to remove it rather than doing it in
               ;; some internal way.
-              (when (and existing (similar-lambda-lists-p existing method))
+              (when (and existing (similar-lambda-lists-p existing new-lambda-list))
                 (remove-method generic-function existing))
 
               ;; KLUDGE: We have a special case here, as we disallow
@@ -481,7 +498,7 @@
                 (error 'new-value-specialization :method  method))
 
               (setf (method-generic-function method) generic-function)
-              (pushnew method (generic-function-methods generic-function))
+              (pushnew method (generic-function-methods generic-function) :test #'eq)
               (dolist (specializer specializers)
                 (add-direct-method specializer method))
 
@@ -589,7 +606,7 @@
   (dolist (class classes)
     (dolist (other-class classes)
       (unless (eq class other-class)
-        (pushnew other-class (class-incompatible-superclass-list class))))))
+        (pushnew other-class (class-incompatible-superclass-list class) :test #'eq)))))
 
 (defun superclasses-compatible-p (class1 class2)
   (let ((cpl1 (cpl-or-nil class1))
@@ -730,22 +747,23 @@
   (let ((methods (generic-function-methods c-a-m-gf)))
     (if (and *old-c-a-m-gf-methods*
              (every (lambda (old-method)
-                      (member old-method methods))
+                      (member old-method methods :test #'eq))
                     *old-c-a-m-gf-methods*))
         (let ((gfs-to-do nil)
               (gf-classes-to-do nil))
           (dolist (method methods)
-            (unless (member method *old-c-a-m-gf-methods*)
+            (unless (member method *old-c-a-m-gf-methods* :test #'eq)
               (let ((specl (car (method-specializers method))))
                 (if (eql-specializer-p specl)
-                    (pushnew (specializer-object specl) gfs-to-do)
-                    (pushnew (specializer-class specl) gf-classes-to-do)))))
+                    (pushnew (specializer-object specl) gfs-to-do :test #'eq)
+                    (pushnew (specializer-class specl) gf-classes-to-do :test #'eq)))))
           (map-all-generic-functions
            (lambda (gf)
-             (when (or (member gf gfs-to-do)
+             (when (or (member gf gfs-to-do :test #'eq)
                        (dolist (class gf-classes-to-do nil)
                          (member class
-                                 (class-precedence-list (class-of gf)))))
+                                 (class-precedence-list (class-of gf))
+                                 :test #'eq)))
                (update-c-a-m-gf-info gf)))))
         (map-all-generic-functions #'update-c-a-m-gf-info))
     (setq *old-c-a-m-gf-methods* methods)))
@@ -816,8 +834,8 @@
                  (get-optimized-std-slot-value-using-class-method-function
                   class slotd type))
                 (method-alist
-                 `((,(car (or (member std-method methods)
-                              (member str-method methods)
+                 `((,(car (or (member std-method methods :test #'eq)
+                              (member str-method methods :test #'eq)
                               (bug "error in ~S"
                                    'get-accessor-method-function)))
                     ,optimized-std-fun)))
@@ -1623,4 +1641,4 @@
       (parse-lambda-list lambda-list)
     (declare (ignore restp keyp auxp aux morep))
     (declare (ignore more-context more-count))
-    (values required optional rest keys allowp)))
\ No newline at end of file
+    (values required optional rest keys allowp)))
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index a82dc8c..0849a80 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -150,7 +150,7 @@
 ;;; here, the values are read by an automatically generated reader method.
 (defmethod add-direct-subclass ((class class) (subclass class))
   (with-slots (direct-subclasses) class
-    (pushnew subclass direct-subclasses)
+    (pushnew subclass direct-subclasses :test #'eq)
     subclass))
 (defmethod remove-direct-subclass ((class class) (subclass class))
   (with-slots (direct-subclasses) class
@@ -196,7 +196,7 @@
     ;; be in progress, and because if an interrupt catches us we
     ;; need to have a consistent state.
     (setf (cdr cell) ()
-          (car cell) (adjoin method (car cell))))
+          (car cell) (adjoin method (car cell) :test #'eq)))
   method)
 
 (defmethod remove-direct-method ((specializer class) (method method))
@@ -229,8 +229,10 @@
 
 ;;; This hash table is used to store the direct methods and direct generic
 ;;; functions of EQL specializers. Each value in the table is the cons.
-(defvar *eql-specializer-methods* (make-hash-table :test 'eql))
-(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
+;;;
+;;; These tables are shared between threads, so they need to be synchronized.
+(defvar *eql-specializer-methods* (make-hash-table :test 'eql :synchronized t))
+(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq :synchronized t))
 
 (defmethod specializer-method-table ((specializer eql-specializer))
   *eql-specializer-methods*)
@@ -243,9 +245,6 @@
   (let* ((object (specializer-object specializer))
          (table (specializer-method-table specializer))
          (entry (gethash object table)))
-    ;; This table is shared between multiple specializers, but
-    ;; no worries as (at least for the time being) our hash-tables
-    ;; are thread safe.
     (unless entry
       (setf entry
             (setf (gethash object table) (cons nil nil))))
@@ -253,7 +252,7 @@
     ;; be in progress, and because if an interrupt catches us we
     ;; need to have a consistent state.
     (setf (cdr entry) ()
-          (car entry) (adjoin method (car entry)))
+          (car entry) (adjoin method (car entry) :test #'eq))
     method))
 
 (defmethod remove-direct-method ((specializer specializer-with-object)
@@ -433,7 +432,7 @@
                      (old (assoc name old-class-slot-cells)))
                 (if (or (not old)
                         (eq t slot-names)
-                        (member name slot-names))
+                        (member name slot-names :test #'eq))
                     (let* ((initfunction (slot-definition-initfunction dslotd))
                            (value (if initfunction
                                       (funcall initfunction)
@@ -847,11 +846,11 @@
   (when cpl
     (let ((first (car cpl)))
       (dolist (c (cdr cpl))
-        (pushnew c (slot-value first 'can-precede-list))))
+        (pushnew c (slot-value first 'can-precede-list) :test #'eq)))
     (update-class-can-precede-p (cdr cpl))))
 
 (defun class-can-precede-p (class1 class2)
-  (member class2 (class-can-precede-list class1)))
+  (member class2 (class-can-precede-list class1) :test #'eq))
 
 (defun update-slots (class eslotds)
   (let ((instance-slots ())
@@ -933,9 +932,9 @@
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)
              (let ((cpl (class-precedence-list class)))
-               (or (member *the-class-slot-class* cpl)
+               (or (member *the-class-slot-class* cpl :test #'eq)
                    (member *the-class-standard-effective-slot-definition*
-                           cpl))))
+                           cpl :test #'eq))))
     (let ((gf-table (make-hash-table :test 'eq)))
       (labels ((collect-gfs (class)
                  (dolist (gf (specializer-direct-generic-functions class))
@@ -1590,7 +1589,7 @@
   t)
 
 (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
-  (pushnew dependent (plist-value metaobject 'dependents)))
+  (pushnew dependent (plist-value metaobject 'dependents) :test #'eq))
 
 (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
   (setf (plist-value metaobject 'dependents)
diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 21874fe..df531b1 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -574,7 +574,7 @@
                                     (list name (pop tail))
                                     (list name))))
                      (dolist (var tail)
-                       (if (member var args)
+                       (if (member var args :test #'eq)
                            ;; Quietly remove IGNORE declarations on
                            ;; args when a next-method is involved, to
                            ;; prevent compiler warnings about ignored
@@ -652,7 +652,7 @@
   ;; Given a valid lambda list, extract the parameter names.
   (loop for x in lambda-list
         with res = nil
-        do (unless (member x lambda-list-keywords)
+        do (unless (member x lambda-list-keywords :test #'eq)
              (if (consp x)
                  (let ((name (car x)))
                    (if (consp name)
diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index 30906c7..1a7bf6f 100644
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -267,12 +267,12 @@
   (push (list thing :lexical-var) (cadddr (env-lock env))))
 
 (defun var-lexical-p (var env)
-  (let ((entry (member var (env-lexical-variables env) :key #'car)))
+  (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
     (when (eq (cadar entry) :lexical-var)
       entry)))
 
 (defun variable-symbol-macro-p (var env)
-  (let ((entry (member var (env-lexical-variables env) :key #'car)))
+  (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
     (when (eq (cadar entry) 'sb!sys:macro)
       entry)))
 
@@ -668,7 +668,7 @@
                                          &aux arg)
   (cond ((null arglist) ())
         ((symbolp (setq arg (car arglist)))
-         (or (member arg lambda-list-keywords)
+         (or (member arg lambda-list-keywords :test #'eq)
              (note-lexical-binding arg env))
          (recons arglist
                  arg
diff --git a/version.lisp-expr b/version.lisp-expr
index 60a95f9..e572e1b 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.17.8"
+"1.0.17.9"
-- 
1.7.10.4